diff --git a/.gitmodules b/.gitmodules index 752c3bf4f7..dc3866ecd8 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,7 +36,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/ESCOMP/atmospheric_physics - fxtag = atmos_phys0_07_001 + fxtag = atmos_phys0_08_000 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics @@ -144,7 +144,7 @@ fxDONOTUSEurl = https://github.com/ESCOMP/mizuRoute [submodule "ccs_config"] path = ccs_config url = https://github.com/ESMCI/ccs_config_cesm.git -fxtag = ccs_config_cesm1.0.8 +fxtag = ccs_config_cesm1.0.21 fxrequired = ToplevelRequired fxDONOTUSEurl = https://github.com/ESMCI/ccs_config_cesm.git diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md deleted file mode 100644 index 10dc362beb..0000000000 --- a/CODE_OF_CONDUCT.md +++ /dev/null @@ -1,84 +0,0 @@ -# Contributor Code of Conduct -_The Contributor Code of Conduct is for participants in our software projects and community._ - -## Our Pledge -We, as contributors, creators, stewards, and maintainers (participants), of the Community Atmosphere Model (CAM) pledge to make participation in our software, system or hardware project and community a safe, productive, welcoming and inclusive experience for everyone. -All participants are required to abide by this Code of Conduct. -This includes respectful treatment of everyone regardless of age, body size, disability, ethnicity, gender identity or expression, level of experience, nationality, political affiliation, veteran status, pregnancy, genetic information, physical appearance, race, religion, or sexual orientation, as well as any other characteristic protected under applicable US federal or state law. - -## Our Standards -Examples of behaviors that contribute to a positive environment include: - -* All participants are treated with respect and consideration, valuing a diversity of views and opinions -* Be considerate, respectful, and collaborative -* Communicate openly with respect for others, critiquing ideas rather than individuals and gracefully accepting criticism -* Acknowledging the contributions of others -* Avoid personal attacks directed toward other participants -* Be mindful of your surroundings and of your fellow participants -* Alert UCAR staff and suppliers/vendors if you notice a dangerous situation or someone in distress -* Respect the rules and policies of the project and venue - -Examples of unacceptable behavior include, but are not limited to: - -* Harassment, intimidation, or discrimination in any form -* Physical, verbal, or written abuse by anyone to anyone, including repeated use of pronouns other than those requested -* Unwelcome sexual attention or advances -* Personal attacks directed at other guests, members, participants, etc. -* Publishing others' private information, such as a physical or electronic address, without explicit permission -* Alarming, intimidating, threatening, or hostile comments or conduct -* Inappropriate use of nudity and/or sexual images -* Threatening or stalking anyone, including a participant -* Other conduct which could reasonably be considered inappropriate in a professional setting - -## Scope -This Code of Conduct applies to all spaces managed by the Project whether they be physical, online or face-to-face. -This includes project code, code repository, associated web pages, documentation, mailing lists, project websites and wiki pages, issue tracker, meetings, telecons, events, project social media accounts, and any other forums created by the project team which the community uses for communication. -In addition, violations of this Code of Conduct outside these spaces may affect a person's ability to participate within them. -Representation of a project may be further defined and clarified by project maintainers. - -## Community Responsibilities -Everyone in the community is empowered to respond to people who are showing unacceptable behavior. -They can talk to them privately or publicly. -Anyone requested to stop unacceptable behavior is expected to comply immediately. -If the behavior continues concerns may be brought to the project administrators or to any other party listed in the [Reporting](#reporting) section below. - -## Project Administrator Responsibilities -Project administrators are responsible for clarifying the standards of acceptable behavior and are encouraged to model appropriate behavior and provide support when people in the community point out inappropriate behavior. -Project administrator(s) are normally the ones that would be tasked to carry out the actions in the [Consequences](#consequences) section below. - -Project administrators are also expected to keep this Code of Conduct updated with the main one housed at UCAR, as listed below in the [Attribution](#attribution) section. - -## Reporting -Instances of unacceptable behavior can be brought to the attention of the project administrator(s) who may take any action as outlined in the [Consequences](#consequences) section below. -However, making a report to a project administrator is not considered an 'official report' to UCAR. - -Instances of unacceptable behavior may also be reported directly to UCAR pursuant to [UCAR's Harassment Reporting and Complaint Procedure](https://www2.fin.ucar.edu/procedures/hr/harassment-reporting-and-complaint-procedure), or anonymously through [UCAR's EthicsPoint Hotline](https://www2.fin.ucar.edu/ethics/anonymous-reporting). - -Complaints received by UCAR will be handled pursuant to the procedures outlined in UCAR's Harassment Reporting and Complaint Procedure. -Complaints to UCAR will be held as confidential as practicable under the circumstances, and retaliation against a person who initiates a complaint or an inquiry about inappropriate behavior will not be tolerated. - -Any Contributor can use these reporting methods even if they are not directly affiliated with UCAR. -The Frequently Asked Questions (FAQ) page for reporting is [here](https://www2.fin.ucar.edu/procedures/hr/reporting-faqs). - -## Consequences -Upon receipt of a complaint, the project administrator(s) may take any action deemed necessary and appropriate under the circumstances. -Such action can include things such as: removing, editing, or rejecting comments, commits, code, wiki edits, email, issues, and other contributions that are not aligned to this Code of Conduct, or banning temporarily or permanently any contributor for other behaviors that are deemed inappropriate, threatening, offensive, or harmful. -Project administrators also have the right to report violations to UCAR HR and/or UCAR's Office of Diversity, Equity and Inclusion (ODEI), as well as a participant's home institution and/or law enforcement. -In the event an incident is reported to UCAR, UCAR will follow its Harassment Reporting and Complaint Procedure. - -## Process for Changes -All UCAR managed projects are required to adopt this Contributor Code of Conduct. -Adoption is assumed even if not expressly stated in the repository. -Projects should fill in sections where prompted with project-specific information, including, project name and adoption date. - -Projects that adopt this Code of Conduct need to stay up to date with UCAR's Contributor Code of Conduct, linked with a DOI in the [Attribution](#attribution) section below. -Projects can make limited substantive changes to the Code of Conduct, however, the changes must be limited in scope and may not contradict the UCAR Contributor Code of Conduct. - -## Attribution -This Code of Conduct was originally adapted from the [Contributor Covenant](http://contributor-covenant.org/version/1/4), version 1.4. -We then aligned it with the UCAR Participant Code of Conduct, which also borrows from the American Geophysical Union (AGU) Code of Conduct. -The UCAR Participant Code of Conduct applies to both UCAR employees as well as participants in activities run by UCAR. -The original version of this for all software projects that have strong management from UCAR or UCAR staff is available on the UCAR website at https://doi.org/10.5065/6w2c-a132. -The date that it was adopted by this project was 2020-04-08 and replaces the previous version. -When responding to complaints, UCAR HR and ODEI will do so based on the latest published version. -Therefore, any project-specific changes should follow the [Process for Changes](#process-for-changes) section above. diff --git a/bld/build-namelist b/bld/build-namelist index fd59776073..665b5767da 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -760,11 +760,9 @@ if ($rad_pkg =~ /rrtmg/ or $chem =~ /waccm/) { # use solar data file as the default for rrtmg and waccm_ma add_default($nl, 'solar_irrad_data_file'); - # This option only used by camrt and rrtmg radiation schemes. - # The solar spectral scaling is done internal to RRTMGP code. - if ($rad_pkg ne 'rrtmgp') { - add_default($nl, 'solar_htng_spctrl_scl', 'val'=>'.true.'); - } + # The solar spectral scaling is done based on the distribution from + # the solar_irrad_data_file. + add_default($nl, 'solar_htng_spctrl_scl', 'val'=>'.true.'); } elsif (!$simple_phys) { @@ -3660,7 +3658,6 @@ if (!$simple_phys) { add_default($nl, 'zmconv_c0_ocn'); add_default($nl, 'zmconv_ke'); add_default($nl, 'zmconv_ke_lnd'); - add_default($nl, 'zmconv_org'); add_default($nl, 'zmconv_num_cin'); add_default($nl, 'zmconv_dmpdz'); add_default($nl, 'zmconv_tiedke_add'); @@ -3689,7 +3686,7 @@ if ($cfg->get('microphys') eq 'rk') { } # Eddy Diffusivity Adjustments -if ($cfg->get('pbl') eq "uw" or $cfg->get('pbl') eq "spcam_m2005") { +if ($cfg->get('pbl') eq "uw") { add_default($nl, 'kv_top_pressure'); add_default($nl, 'kv_top_scale'); add_default($nl, 'kv_freetrop_scale'); @@ -3777,6 +3774,14 @@ if (!$simple_phys) { add_default($nl, 'use_gw_movmtn_pbl', 'val'=>'.true.'); } + my $use_gw_movmtn_pbl = $nl->get_value('use_gw_movmtn_pbl'); + if ($use_gw_movmtn_pbl =~ /$TRUE/io) { + if ( ! ($dyn =~ /se/) ) { + die "$ProgName - ERROR: use_gw_movmtn_pbl is only available with the SE dycore \n"; + + } + } + add_default($nl, 'use_gw_rdg_gamma' , 'val'=>'.false.'); add_default($nl, 'use_gw_front_igw' , 'val'=>'.false.'); add_default($nl, 'use_gw_convect_sh', 'val'=>'.false.'); @@ -3838,6 +3843,7 @@ my $do_gw_convect_sh = ($nl->get_value('use_gw_convect_sh') =~ /$TRUE/io); my $do_gw_movmtn_pbl = ($nl->get_value('use_gw_movmtn_pbl') =~ /$TRUE/io); my $do_gw_rdg_beta = ($nl->get_value('use_gw_rdg_beta') =~ /$TRUE/io); my $do_gw_rdg_gamma = ($nl->get_value('use_gw_rdg_gamma') =~ /$TRUE/io); +my $do_gw_rdg_resid = ($nl->get_value('use_gw_rdg_resid') =~ /$TRUE/io); my $do_divstream = ($nl->get_value('gw_rdg_do_divstream') =~ /$TRUE/io); @@ -3892,6 +3898,10 @@ if ($do_gw_convect_sh) { if ($do_gw_movmtn_pbl) { add_default($nl, 'gw_drag_file_mm'); add_default($nl, 'alpha_gw_movmtn'); + add_default($nl, 'effgw_movmtn_pbl'); + add_default($nl, 'movmtn_source'); + add_default($nl, 'movmtn_psteer'); + add_default($nl, 'movmtn_plaunch'); } if ($do_gw_rdg_beta) { @@ -3911,6 +3921,10 @@ if ($do_gw_rdg_beta) { add_default($nl, 'gw_prndl'); } +if ($do_gw_rdg_resid) { + add_default($nl, 'effgw_rdg_resid' ); +} + if ($do_gw_rdg_gamma) { add_default($nl, 'n_rdg_gamma', 'val'=>'-1'); add_default($nl, 'effgw_rdg_gamma', 'val'=>'1.0D0'); @@ -4334,11 +4348,6 @@ if ($offline_drv ne 'stub') { } } -if ($phys eq 'spcam_sam1mom' or $phys eq 'spcam_m2005') { - add_default($nl, 'iradsw', 'val'=>'1'); - add_default($nl, 'iradlw', 'val'=>'1'); -} - #----------------------------------------------------------------------------------------------- # Rename component logfiles. # diff --git a/bld/config_files/definition.xml b/bld/config_files/definition.xml index eeee8504a2..c3af153035 100644 --- a/bld/config_files/definition.xml +++ b/bld/config_files/definition.xml @@ -57,19 +57,19 @@ Option to turn on waccmx thermosphere/ionosphere extension: 0 => no, 1 => yes Ionosphere model used in WACCMX. - -Physics package: cam4, cam5, cam6, cam7, held_suarez, adiabatic, kessler, tj2016, grayrad, spcam_sam1mom, spcam_m2005. + +Physics package: cam4, cam5, cam6, cam7, held_suarez, adiabatic, kessler, tj2016, grayrad. Switch to turn on Harmonized Emissions Component (HEMCO) for chemistry: 0 => no, 1 => yes. - + Microphysics package: rk (Rasch and Kristjansson), mg1 (Morrison and Gettelman two moment scheme CAM5.1), mg2 (Morrison and Gettelman second -version CAM6), mg3 (MG scheme 3rd version, graupel), PUMAS, SPCAM_m2005, SPCAM_sam1mom. +version CAM6), mg3 (MG scheme 3rd version, graupel), PUMAS. - -Macrophysics package: RK, Park, CLUBB_SGS, SPCAM_sam1mom, SPCAM_m2005. + +Macrophysics package: RK, Park, CLUBB_SGS. Switch to turn on CLUBB_SGS package: 0 => no, 1 => yes @@ -83,13 +83,9 @@ Switch to turn on UNICON package: 0 => off, 1 => on Switch to turn on/off advecting CLUBB moments: 0 => no, 1 => yes - -Switch to turn on/off parameterization for sub-grid scale convective organization for the ZM deep convective scheme based -on Mapes and Neale (2011): 0 => no, 1 => yes - - + PBL package: uw (University of Washington), hb (Holtslag and Boville), hbr - (Holtslag, Boville, and Rasch), clubb_sgs, spcam_sam1om, spcam_m2005, none. + (Holtslag, Boville, and Rasch), clubb_sgs, none. Radiative transfer calculation: @@ -305,23 +301,5 @@ that setting to allow for cross-compilation, and for instances where the $OSNAME value is too generic. For example, currently on both cray-xt and bluegene systems $OSNAME has the value "linux". - -Switch to turn on SPCAM version of CLUBB_SGS package: 0 => no, 1 => yes - - -SPCAM number of grid points in x - - -SPCAM number of grid points in y - - -SPCAM number of grid points in z - - -SPCAM horizontal grid spacing, m - - -SPCAM time step, s - diff --git a/bld/configure b/bld/configure index 11d66c55a7..138436315a 100755 --- a/bld/configure +++ b/bld/configure @@ -98,26 +98,18 @@ OPTIONS -pcols Set maximum number of columns in a chunk to . -pergro Switch enables building CAM for perturbation growth tests. -phys Physics option [cam4 | cam5 | cam6 | cam7 | - held_suarez | adiabatic | kessler | tj2016 | grayrad - spcam_sam1mom | spcam_m2005]. Default: cam6 + held_suarez | adiabatic | kessler | tj2016 | grayrad]. -prog_species Comma-separate list of prognostic mozart species packages. Currently available: DST,SSLT,SO4,GHG,OC,BC,CARBON16 -psubcols Maximum number of sub-columns in a run - set to 1 if not using sub-columns (default) -rad Specify the radiation package [rrtmg | rrtmgp | rrtmgp_gpu | camrt] -silhs Switch on SILHS. - -spcam_clubb_sgs Turn on the SPCAM version of CLUBB - -spcam_nx SPCAM x-grid. - defaults to 4 (note the CRM requires spcam_nx to be greater than or equal to 4) - -spcam_ny SPCAM y-grid. - defaults to 1 - -spcam_dx SPCAM horizontal grid spacing. - -spcam_dt SPCAM timestep. -unicon Switch to turn on the UNICON scheme. Default: off. -usr_mech_infile Path and file name of the user supplied chemistry mechanism file. -waccm_phys Switch enables the use of WACCM physics in any chemistry configuration. The user does not need to set this if one of the waccm chemistry options is chosen. -waccmx Build CAM/WACCM with WACCM upper Thermosphere/Ionosphere extended package - -zmconv_org Include parameterization for sub-grid scale convective organization for the ZM deep convective scheme based - on Mapes and Neale (2011) Options relevent to SCAM mode: @@ -254,7 +246,6 @@ GetOptions( "cosp_libdir=s" => \$opts{'cosp_libdir'}, "cppdefs=s" => \$opts{'cppdefs'}, "cpl=s" => \$opts{'cpl'}, - "spcam_clubb_sgs" => \$opts{'spcam_clubb_sgs'}, "debug" => \$opts{'debug'}, "dyn=s" => \$opts{'dyn'}, "edit_chem_mech" => \$opts{'edit_chem_mech'}, @@ -303,10 +294,6 @@ GetOptions( "silhs" => \$opts{'silhs'}, "s|silent" => \$opts{'silent'}, "smp!" => \$opts{'smp'}, - "spcam_nx=s" => \$opts{'spcam_nx'}, - "spcam_ny=s" => \$opts{'spcam_ny'}, - "spcam_dx=s" => \$opts{'spcam_dx'}, - "spcam_dt=s" => \$opts{'spcam_dt'}, "spmd!" => \$opts{'spmd'}, "target_os=s" => \$opts{'target_os'}, "unicon" => \$opts{'unicon'}, @@ -316,7 +303,6 @@ GetOptions( "version" => \$opts{'version'}, "waccm_phys" => \$opts{'waccm_phys'}, "waccmx" => \$opts{'waccmx'}, - "zmconv_org" => \$opts{'zmconv_org'}, ) or usage(); # Give usage message. @@ -567,10 +553,10 @@ if ($phys_pkg =~ m/^adiabatic$|^held_suarez$|^kessler$|^tj2016$|^grayrad$/) { my $chem_pkg = 'not_set'; # defaults based on physics package -if ($simple_phys or $phys_pkg =~ m/^cam[34]$/ or $phys_pkg eq 'spcam_sam1mom') { +if ($simple_phys or $phys_pkg =~ m/^cam[34]$/) { $chem_pkg = 'none'; } -elsif ($phys_pkg eq 'cam5' or $phys_pkg eq 'spcam_m2005') { +elsif ($phys_pkg eq 'cam5') { $chem_pkg = 'trop_mam3'; } elsif ($phys_pkg eq 'cam6') { @@ -601,7 +587,7 @@ if (defined $opts{'chem'}) { " -chem can only be set to 'none' or 'terminator'.\n"; } } - elsif ($phys_pkg =~ m/^cam4$|^spcam_sam1mom$/) { + elsif ($phys_pkg =~ m/cam4/) { # The modal aerosols are not valid with cam4 physics if ($chem_pkg =~ /_mam/) { die "configure ERROR: -phys=$phys_pkg -chem=$chem_pkg\n". @@ -758,46 +744,6 @@ my $co2_cycle = $cfg_ref->get('co2_cycle'); if ($co2_cycle and $print>=2) { print "co2_cycle option: ON$eol"; } -#----------------------------------------------------------------------------------------------- -# Superparameterization mode (SPCAM) -# -# These values all default to 1 unless specified by the user during configure - -if ($phys_pkg eq 'spcam_sam1mom' or $phys_pkg eq 'spcam_m2005') { - - if ($smp eq 'ON') { - die "ERROR: SPCAM may not be used with threading $eol"; - } - - if ($print>=2) {print "Configure CAM for SPCAM (superparameterization) mode: $phys_pkg.$eol"; } - - if (defined $opts{'spcam_nx'}) { - $cfg_ref->set('spcam_nx', $opts{'spcam_nx'}); - my $spcam_nx = $cfg_ref->get('spcam_nx'); - if ($spcam_nx < 4) { - die "configure ERROR: spcam_nx must be greater than or equal to 4\n"; - } - if ($print>=2) {print "spcam_nx= $spcam_nx $eol"; } - } - if (defined $opts{'spcam_ny'}) { - $cfg_ref->set('spcam_ny', $opts{'spcam_ny'}); - my $spcam_ny = $cfg_ref->get('spcam_ny'); - if ($print>=2) {print "spcam_ny= $spcam_ny $eol"; } - } - if (defined $opts{'spcam_dx'}) { - $cfg_ref->set('spcam_dx', $opts{'spcam_dx'}); - my $spcam_dx = $cfg_ref->get('spcam_dx'); - if ($print>=2) {print "spcam_nx= $spcam_dx $eol"; } - } - if (defined $opts{'spcam_dt'}) { - $cfg_ref->set('spcam_dt', $opts{'spcam_dt'}); - my $spcam_dt = $cfg_ref->get('spcam_dt'); - if ($print>=2) {print "spcam_nt= $spcam_dt $eol"; } - } - -} - - #----------------------------------------------------------------------------------------------- # Micro-physics package @@ -815,12 +761,6 @@ elsif ($phys_pkg eq 'cam6') { elsif ($phys_pkg eq 'cam7') { $microphys_pkg = 'mg3'; } -elsif ($phys_pkg eq 'spcam_sam1mom') { - $microphys_pkg = 'spcam_sam1mom'; -} -elsif ($phys_pkg eq 'spcam_m2005') { - $microphys_pkg = 'spcam_m2005'; -} # Allow the user to override the default via the commandline. if (defined $opts{'microphys'}) { @@ -910,14 +850,6 @@ $cfg_ref->set('silhs', $silhs); if ($print>=2) { print "silhs: $silhs$eol"; } -#----------------------------------------------------------------------------------------------- -# SPCAM version of CLUBB -if (defined $opts{'spcam_clubb_sgs'}) { - $cfg_ref->set('spcam_clubb_sgs', $opts{'spcam_clubb_sgs'}); -} -my $spcam_clubb_sgs = $cfg_ref->get('spcam_clubb_sgs'); - - #----------------------------------------------------------------------------------------------- # Break apart CLUBB options into separate fields @@ -930,16 +862,6 @@ if (defined $opts{'clubb_opts'}) { my $clubb_do_adv = $cfg_ref->get('clubb_do_adv'); if ($print>=2) { print "clubb_do_adv: $clubb_do_adv$eol"; } -#----------------------------------------------------------------------------------------------- -# ZM convective organization - -if (defined $opts{'zmconv_org'}) { - $cfg_ref->set('zmconv_org', $opts{'zmconv_org'}); -} - -my $zmconv_org = $cfg_ref->get('zmconv_org'); -if ($print>=2) { print "zmconv_org: $zmconv_org$eol"; } - #----------------------------------------------------------------------------------------------- # Macro-physics package @@ -959,18 +881,12 @@ elsif ($phys_pkg =~ /cam6/) { $macrophys_pkg = 'park'; } } -elsif ($phys_pkg =~ /cam7/ and $clubb_sgs) { +elsif ($phys_pkg =~ /cam7/) { $macrophys_pkg = 'clubb_sgs'; } -elsif ($phys_pkg eq 'spcam_sam1mom') { - $macrophys_pkg = 'spcam_sam1mom'; -} -elsif ($phys_pkg eq 'spcam_m2005') { - $macrophys_pkg = 'spcam_m2005'; -} # user overrides -if ($clubb_sgs or $spcam_clubb_sgs) { +if ($clubb_sgs) { $macrophys_pkg = 'clubb_sgs'; } @@ -1002,15 +918,9 @@ elsif ($phys_pkg =~ /cam6/) { $pbl_pkg = 'uw'; } } -elsif ($phys_pkg =~ /cam7/ and $clubb_sgs) { +elsif ($phys_pkg =~ /cam7/) { $pbl_pkg = 'clubb_sgs'; } -elsif ($phys_pkg eq 'spcam_sam1mom') { - $pbl_pkg = 'spcam_sam1mom'; -} -elsif ($phys_pkg eq 'spcam_m2005') { - $pbl_pkg = 'spcam_m2005'; -} # Allow the user to override the default via the commandline. if ($clubb_sgs == 1) { @@ -1062,10 +972,10 @@ if ($unicon and $print>=2) { print "Using UNICON scheme.$eol"; } # Set default my $rad_pkg = 'none'; -if ($phys_pkg =~ m/cam4|spcam_sam1mom/) { +if ($phys_pkg =~ m/cam4/) { $rad_pkg = 'camrt'; } -elsif ($phys_pkg =~ m/cam5|cam6|spcam_m2005/) { +elsif ($phys_pkg =~ m/cam5|cam6/) { $rad_pkg = 'rrtmg'; } elsif ($phys_pkg =~ m/cam7/) { @@ -1120,31 +1030,6 @@ if ($cosp and ($phys_pkg ne 'cam5' and $phys_pkg ne 'cam6' and $phys_pkg ne 'cam if ($cosp and $print>=2) { print "COSP simulator enabled$eol"; } -#----------------------------------------------------------------------------------------------- -# Checks for SPCAM compatability - -if ($phys_pkg eq 'spcam_sam1mom') { - if ($rad_pkg ne 'camrt') { - die "configure ERROR: radiation package: $rad_pkg is not compatible\n". - " with sam1mom -- it should be camrt\n"; - } - if ($chem_pkg ne 'none') { - die "configure ERROR: chemistry package: $chem_pkg is not compatible\n". - " with sam1mom -- it should be none\n"; - } -} - -if ($phys_pkg eq 'spcam_m2005') { - if ($rad_pkg !~ m/rrtmg/) { - die "configure ERROR: radiation package: $rad_pkg is not compatible\n". - " with m2005 -- it should be rrtmg\n"; - } - if ($chem_pkg ne 'trop_mam3') { - die "configure ERROR: chemistry package: $chem_pkg is not compatible\n". - " with m2005 -- it should be trop_mam3\n"; - } -} - #----------------------------------------------------------------------------------------------- # offline unit driver if (defined $opts{'offline_drv'}) { @@ -1350,10 +1235,10 @@ elsif ($phys_pkg eq 'cam7') { elsif ($phys_pkg eq 'cam6') { $nlev = 32; } -elsif ($phys_pkg eq 'cam5' or $phys_pkg eq 'spcam_m2005') { +elsif ($phys_pkg eq 'cam5') { $nlev = 30; } -elsif ($phys_pkg eq 'cam4' or $phys_pkg eq 'spcam_sam1mom') { +elsif ($phys_pkg eq 'cam4') { $nlev = 26; } else { @@ -1378,10 +1263,6 @@ $cfg_ref->set('nlev', $nlev); if ($print>=2) { print "Number of vertical levels: $nlev$eol"; } -if ($phys_pkg eq 'spcam_sam1mom' or $phys_pkg eq 'spcam_m2005') { - $cfg_ref->set('spcam_nz', $nlev-2); -} - #------------------------------------------------------------------------------------------------ # chemistry preprocessor.... # -- avoid using the chem_preprocessor unless it's required @@ -1540,11 +1421,11 @@ else { unless ($simple_phys) { # Microphysics parameterization - if ($microphys_pkg eq 'rk' or $microphys_pkg eq 'spcam_sam1mom') { + if ($microphys_pkg eq 'rk') { $nadv += 2; if ($print>=2) { print "Advected constituents added by $microphys_pkg microphysics: 2$eol"; } } - elsif ($microphys_pkg =~ /^mg1/ or $microphys_pkg eq 'spcam_m2005') { + elsif ($microphys_pkg =~ /^mg1/) { $nadv += 4; if ($print>=2) { print "Advected constituents added by $microphys_pkg microphysics: 4$eol"; } } @@ -1557,11 +1438,6 @@ else { if ($print>=2) { print "Advected constituents added by $microphys_pkg microphysics: 10$eol"; } } - if ($zmconv_org == 1 ) { - $nadv += 1; - if ($print>=2) { print "Advected constituents added by $microphys_pkg microphysics: 8$eol"; } - } - if ($clubb_do_adv) { $nadv += 9; if ($print>=2) { print "Advected constituents added by $microphys_pkg microphysics: 8$eol"; } @@ -1849,28 +1725,6 @@ my $cfg_cppdefs = ' '; # Building for perturbation growth tests if ($pergro eq "ON") { $cfg_cppdefs .= " -DPERGRO"; } -# Building for superparameterization -my $spcam_clubb_sgs = $cfg_ref->get('spcam_clubb_sgs'); -my $spcam_nx = $cfg_ref->get('spcam_nx'); -my $spcam_ny = $cfg_ref->get('spcam_ny'); -my $spcam_nz = $cfg_ref->get('spcam_nz'); -my $spcam_dx = $cfg_ref->get('spcam_dx'); -my $spcam_dt = $cfg_ref->get('spcam_dt'); - -my $yes3Dval = 1; # default to 3D for spcam -if ($spcam_ny eq 1) {$yes3Dval = 0;} #Turn off if not using 3D - -if ($phys_pkg eq 'spcam_m2005' or $phys_pkg eq 'spcam_sam1mom') { - $cfg_cppdefs .= " -DSPCAM_NX=$spcam_nx -DSPCAM_NY=$spcam_ny -DSPCAM_NZ=$spcam_nz -DSPCAM_DX=$spcam_dx -DSPCAM_DT=$spcam_dt -DYES3DVAL=$yes3Dval -DCRM "; - if ( $spcam_clubb_sgs == 1 ) { - $cfg_cppdefs .= "-DSPCAM_CLUBB_SGS -DCLUBB_CRM -DCLUBB_REAL_TYPE=dp -DCLUBB_SAM"; ## -DNO_LAPACK_ISNAN"; - } -} - -if ($phys_pkg eq 'spcam_m2005') {$cfg_cppdefs .= " -DECPP -Dm2005";} - -if ($phys_pkg eq 'spcam_sam1mom') {$cfg_cppdefs .= " -Dsam1mom";} - # Configure CAM to produce IOP files for SCAM if ($camiop eq 'ON') { $cfg_cppdefs .= " -DBFB_CAM_SCAM_IOP"; } @@ -2289,29 +2143,6 @@ sub write_filepath print $fh "$camsrcdir/src/physics/pumas-frozen\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"; - - # add additional directories for sam6.10.4 - print $fh "$camsrcdir/src/physics/spcam/crm/ADV_MPDATA\n"; - if ($phys_pkg eq 'spcam_sam1mom') { - print $fh "$camsrcdir/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"; - } - if ( $spcam_clubb_sgs == 1 ) { - print $fh "$camsrcdir/src/physics/spcam/crm/CLUBB\n"; - print $fh "$camsrcdir/src/physics/spcam/crm/SGS_CLUBBkvhkvm\n" - } - else { - print $fh "$camsrcdir/src/physics/spcam/crm/SGS_TKE\n"; - } - } - # This directory contains much of the code for physics packages, # as well as the cam specific interface modules that may need to # be overridden by modules from directories that occur earlier @@ -2326,6 +2157,8 @@ sub write_filepath print $fh "$camsrcdir/src/atmos_phys/schemes/check_energy\n"; print $fh "$camsrcdir/src/atmos_phys/schemes/utilities\n"; + print $fh "$camsrcdir/src/atmos_phys/schemes/cloud_fraction\n"; + # Dynamics package and test utilities print $fh "$camsrcdir/src/dynamics/$dyn\n"; if($dyn eq 'se') { diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index f004d2cca2..b84e2b6cf2 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -296,7 +296,7 @@ atm/cam/topo/se/ne3pg3_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230209.nc atm/cam/topo/se/ne5pg3_nc3000_Co360_Fi001_MulG_PF_nullRR_Nsw064_20170516.nc atm/cam/topo/se/ne16pg3_nc3000_Co120_Fi001_PF_nullRR_Nsw084_20171012.nc -atm/cam/topo/se/ne30pg3_gmted2010_modis_bedmachine_nc3000_Laplace0100_noleak_20240117.nc +atm/cam/topo/se/ne30pg3_gmted2010_modis_bedmachine_nc3000_Laplace0100_noleak_20240720.nc atm/cam/topo/se/ne60pg3_nc3000_Co030_Fi001_PF_nullRR_Nsw021_20171012.nc atm/cam/topo/se/ne120pg3_nc3000_Co015_Fi001_PF_nullRR_Nsw010_20171014.nc atm/cam/topo/se/ne240pg3_nc3000_Co008_Fi001_PF_nullRR_Nsw005_20171015.nc @@ -316,8 +316,6 @@ 98288.0D0 98288.0D0 98288.0D0 - 98288.0D0 - 98288.0D0 atm/cam/topo/fv_0.9x1.25_nc3000_Nsw006_Nrs002_Co008_Fi001_ZR_c160505.nc @@ -773,6 +771,8 @@ 0.0625D0 +1.0D0 + 1.0D0 0.5D0 0.5D0 @@ -839,6 +839,11 @@ 0.002d0 0.1d0 0.01d0 + 1.0d0 + 65000.0d0 + 32500.0d0 + 1 + 15 @@ -1932,8 +1937,6 @@ NEU -MOZ -OFF @@ -2023,7 +2026,6 @@ .true. .false. .false. - .true. 0.075D0 0.100D0 @@ -2040,14 +2042,12 @@ .true. .true. .true. - .true. 0 1 1 1 - 1 0.01d0 0.001d0 @@ -2055,7 +2055,6 @@ .false. .true. - .true. .false. @@ -2096,7 +2095,7 @@ 0.1 0.5 4.2 - 4.25 + 4.5 0.0 1.0 0.1 @@ -2153,7 +2152,7 @@ .true. .false. .false. - .true. + .false. .true. .true. .true. @@ -2265,10 +2264,8 @@ RK MG MG -SPCAM_m2005 -SPCAM_sam1mom -MG -MG +MG +MG 1 0 @@ -2394,8 +2391,6 @@ rk park CLUBB_SGS -SPCAM_sam1mom -SPCAM_m2005 @@ -2443,59 +2438,57 @@ 0.37D0 0.35D0 -0.35D0 0.45D0 -0.45D0 0.45D0 0.35D0 -1.30D0 +2.30D0 0.30D0 -0.30D0 +2.30D0 0.45D0 -0.45D0 +2.30D0 0.45D0 -0.45D0 -0.45D0 +2.30D0 0.55D0 0.22D0 0.70D0 -1.30D0 +2.30D0 +2.30D0 0.8D0 -0.8D0 +2.30D0 0.8D0 -0.8D0 +2.30D0 0.8D0 -0.8D0 +2.30D0 0.8D0 -0.8D0 +2.30D0 0.8D0 -0.8D0 +2.30D0 0.8D0 -0.8D0 +2.30D0 0.8D0 -0.8D0 +2.30D0 0.8D0 -0.8D0 +2.30D0 0.8D0 -0.8D0 +2.30D0 0.8D0 -0.8D0 +2.30D0 0.70D0 -0.70D0 -0.13D0 +2.300D0 0.26D0 -0.26D0 +2.30D0 0.7D0 -0.7D0 +2.30D0 0.24D0 -0.24D0 +2.30D0 0.9D0 -0.9D0 +2.30D0 -Zender_2003 + Zender_2003 + Leung_2023 atm @@ -2504,9 +2497,8 @@ 1.62D0 0.90D0 1.00D0 -0.75D0 +1.50D0 1.10D0 -1.2D0 0.60D0 @@ -2521,9 +2513,6 @@ 0.4D0 1.0D0 -1.00D0 -1.00D0 - .false. .true. @@ -2586,16 +2575,12 @@ HB HBR CLUBB_SGS -SPCAM_m2005 -SPCAM_sam1mom ZM off UNICON NONE -SPCAM -SPCAM NONE UW @@ -2603,8 +2588,6 @@ Hack Hack CLUBB_SGS -SPCAM -SPCAM .true. @@ -2717,10 +2700,8 @@ 1.1D0 1.0D0 1.05D0 - 1.0D0 1.1D0 1.0D0 - 1.0D0 1.e-7 5.e-3 @@ -2830,9 +2811,6 @@ 5.0E-6 5.0E-6 - .false. - .true. - 5 1 1 @@ -2857,19 +2835,14 @@ 4 4 4 - 4 42 -42 42 -42 42 -42 42 42 42 42 42 -42 1 2 @@ -3054,8 +3027,6 @@ 'Q' 'Q','CLDLIQ','RAINQM' 'Q','CLDLIQ','CLDICE' -'Q','CLDLIQ','CLDICE' -'Q','CLDLIQ','CLDICE' 'Q','CLDLIQ','CLDICE' 'Q','CLDLIQ','CLDICE','RAINQM','SNOWQM' 'Q','CLDLIQ','CLDICE','RAINQM','SNOWQM','GRAUQM' diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 241cc4826a..38f643253d 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -1222,6 +1222,13 @@ Whether or not to enable gravity waves from PBL moving mountains source. Default: .false. + +Whether or not to enable gravity waves from residual (non-ridge) +orography +Default: set by build-namelist. + + Gravity wave spectrum dimension (wave numbers are from -pgwv to pgwv). @@ -1325,6 +1332,36 @@ Max efficiency associated with anisotropic OGW. Default: 1.0 + +Efficiency scaling factor associated with residual non-ridge topo +Default: set by build-namelist. + + + +Efficiency scaling factor for moving mountain source +Default: set by build-namelist. + + + +Global steering level (Pa) for moving mtns. If negative steering level, it will be provided by future code +Default: set by build-namelist. + + + +Global launch level (Pa) for moving mtns. If negative launch level, it will be provided by future code +Default: set by build-namelist. + + + +Integer code for movmtn source: 1=vorticity, 2=upwp +Default: set by build-namelist. + + Drag coefficient for obstacles in low-level flow. @@ -3156,13 +3193,6 @@ Tunable evaporation efficiency in ZM deep convection scheme. Default: set by build-namelist - -Include organization parameterization in ZM. This value is set to true automatically -if -zmconv_org is set in configure. -Default: .false., unless -zmconv_org set in configure - - The number of negative buoyancy regions that are allowed before the convection top and CAPE calculations are completed. @@ -3480,16 +3510,14 @@ Default: 10 group="phys_ctl_nl" valid_values="ZM,UNICON,off,CLUBB_SGS" > Type of deep convection scheme employed. 'ZM' for Zhang-McFarlane; 'off' for none; or 'UNICON' which doesn't distinquish shallow and deep. -Default: 'ZM' unless using 'UNICON', 'SPCAM' or 'pbl=none' +Default: 'ZM' unless using 'UNICON' or 'pbl=none' + group="phys_ctl_nl" valid_values="NONE,RK,MG" > Type of microphysics scheme employed. 'RK' for Rasch and Kristjansson (1998); 'MG' for Morrison and Gettelman (2008), Gettelman et al (2010) two moment scheme for CAM5 and CAM6 -SPCAM has two different microphysics schemes: SPCAM_m2005 (Morrison et al 2005), -SPCAM_sam1mom (Khairoutinov 2003) Default: set by build-namelist (depends on value set in configure). @@ -3509,14 +3537,12 @@ Default: set by build-namelist + group="phys_ctl_nl" valid_values="Hack,UW,CLUBB_SGS,UNICON" > Type of shallow convection scheme employed. 'Hack' for Hack shallow convection; 'UW' for original McCaa UW pbl scheme, modified by Sungsu Park; 'CLUBB_SGS' for CLUBB_SGS 'UNICON' which doesn't distinquish shallow and deep. - 'SPCAM_m2005' for SPCAM double moment - 'SPCAM_sam1mom' for SPCAM single moment Default: set by build-namelist (depends on {{ hilight }}eddy_scheme{{ closehilight }}). @@ -5239,7 +5265,7 @@ Default: 0 + group="phys_ctl_nl" valid_values="HB,diag_TKE,HBR,CLUBB_SGS" > Type of eddy scheme employed by the vertical diffusion package. 'HB' for Holtslag and Boville; 'diag_TKE' for diagnostic tke version of Grenier and Bretherton; 'HBR' for Rasch modified version of 'HB'. @@ -6058,7 +6084,7 @@ Wet deposition method used MOZ --> mozart scheme is used NEU --> J Neu's scheme is used OFF --> wet deposition is turned off -Default: NEU except for SPCAM runs +Default: NEU CAM cam6 physics: CAM cam5 physics: CAM cam4 physics: - CAM simplified and non-versioned physics : + CAM simplified and non-versioned physics : - - - - - F2000Nuopc - 2000_CAM40_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - - @@ -246,16 +237,6 @@ HIST_CAM60_SLND_SICE_DOCN%AQP3_SROF_SGLC_SWAV - - QSPCAMS - 2000_CAM%SPCAMS_SLND_SICE_DOCN%AQP3_SROF_SGLC_SWAV - - - - QPSPCAMM - 2000_CAM%SPCAMM_SLND_SICE_DOCN%AQP3_SROF_SGLC_SWAV - - QPC6 2000_CAM60_SLND_SICE_DOCN%AQP3_SROF_SGLC_SWAV @@ -332,16 +313,6 @@ 1850_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - - FSPCAMM - 2000_CAM%SPCAMM_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - - FSPCAMS - 2000_CAM%SPCAMS_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - FHIST_BDRD HIST_CAM60_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV_BGC%BDRD @@ -372,19 +343,6 @@ - - - - FSPCAMCLBS - 2000_CAM%SPCAMCLBS_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - - FSPCAMCLBM - 2000_CAM%SPCAMCLBM_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - @@ -759,76 +717,6 @@ - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - diff --git a/cime_config/config_pes.xml b/cime_config/config_pes.xml index f488c21b27..2650843bfe 100644 --- a/cime_config/config_pes.xml +++ b/cime_config/config_pes.xml @@ -2057,18 +2057,6 @@ - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - none diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 81256661b7..7b57d05162 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -350,26 +350,6 @@ - - - - - - - - - - - - - - - - - - - - @@ -2008,70 +1988,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/doc/ChangeLog b/doc/ChangeLog index 16489fbe43..bea6f244a5 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,8 +1,8 @@ =============================================================== -Tag name: +Tag name: cam6_4_068 Originator(s): eaton -Date: +Date: 19 February 2025 One-line Summary: remove Eulerian dycore; fix fire emissions Github PR URL: https://github.com/ESCOMP/CAM/pull/1215 @@ -23,7 +23,7 @@ List any changes to the defaults for the boundary datasets: Describe any substantial timing or memory changes: none -Code reviewed by: +Code reviewed by: cacraig List all files eliminated: @@ -176,6 +176,1143 @@ Summarize any changes to answers: BFB. Compset FCfireHIST has answer =============================================================== =============================================================== +Tag name: cam6_4_067 +Originator(s): eaton +Date: 15 February 2025 +One-line Summary: Remove SP-CAM +Github PR URL: https://github.com/ESCOMP/CAM/pull/1217 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + +Resolve #1171 - Remove SP-CAM from cam_development + +Describe any changes made to build system: +. remove spcam build options + +Describe any changes made to the namelist: +. remove spcam namelist options + +List any changes to the defaults for the boundary datasets: none + +Describe any substantial timing or memory changes: none + +Code reviewed by: cacraig + +List all files eliminated: +doc/ReleaseNotes +. This file hasn't been updated since cam5.4. Put this information + somewhere else. + +src/physics/cam/spcam_drivers.F90 +src/physics/spcam/* +src/physics/spcam/crm/* +src/physics/spcam/crm/ADV_MPDATA/* +src/physics/spcam/crm/CLUBB/* +src/physics/spcam/crm/MICRO_M2005/* +src/physics/spcam/crm/MICRO_SAM1MOM/* +src/physics/spcam/crm/SGS_CLUBBkvhkvm/* +src/physics/spcam/crm/SGS_TKE/* +src/physics/spcam/ecpp/* +. remove all SPCAM source and drivers + +List all files added and what they do: none + +List all existing files that have been modified, and describe the changes: + +bld/build-namelist +. remove dependencies on spcam + +bld/config_files/definition.xml +. remove 'phys' options spcam_sam1mom and spcam_m2005 +. remove 'microphys' options spcam_sam1mom and spcam_m2005 +. remove 'macrophys' options spcam_sam1mom and spcam_m2005 +. remove 'pbl' options spcam_sam1mom and spcam_m2005 +. remove parameters 'spcam_clubb_sgs', 'spcam_nx', 'spcam_ny', 'spcam_nz', + 'spcam_dx', 'spcam_dt' + +bld/configure +. remove -phys options spcam_sam1mom and spcam_m2005 +. remove commandline options -spcam_clubb_sgs, -spcam_nx, -spcam_ny, + -spcam_dx, -spcam_dt +. remove code paths for spcam: + src/physics/spcam/ + src/physics/spcam/crm/ + src/physics/spcam/crm/ADV_MPDATA/ + src/physics/spcam/crm/MICRO_SAM1MOM/ + src/physics/spcam/crm/MICRO_M2005/ + src/physics/spcam/crm/CLUBB/ + src/physics/spcam/crm/SGS_CLUBBkvhkvm/ + src/physics/spcam/crm/SGS_TKE/ + src/physics/spcam/ecpp/ + +bld/namelist_files/namelist_defaults_cam.xml +. remove dependencies on phys, microphys, macrophys, and pbl attributes + spcam_sam1mom and spcam_m2005 +. remove dependencies on spcam_clubb_sgs attribute + +bld/namelist_files/namelist_definition.xml +. remove SPCAM_sam1mom and SPCAM_m2005 as valid values for microp_scheme, + shallow_scheme, and eddy_scheme + +cime_config/config_component.xml +. remove physics options %SPCAMS, %SPCAMCLBS, %SPCAMM, %SPCAMCLBM + +cime_config/config_compsets.xml +. remove F2000Nuopc - not used +. remove QSPCAMS, QPSPCAMM, FSPCAMM, FSPCAMS +. remove FSPCAMCLBS, FSPCAMCLBM +. remove SPCAM settings for NTHRDS_[ATM,CPL,ESP,GLC,ICE,LND,OCN,ROF,WAV] + +cime_config/config_pes.xml +. remove settings for SPCAM* + +cime_config/testdefs/testlist_cam.xml +. remove tests for SPCAM* + +src/chemistry/modal_aero/aero_model.F90 +src/physics/cam/cloud_diagnostics.F90 +src/physics/cam/cloud_fraction.F90 +src/physics/cam/conv_water.F90 +src/physics/cam/convect_deep.F90 +src/physics/cam/convect_shallow.F90 +src/physics/cam/diffusion_solver.F90 +src/physics/cam/microp_driver.F90 +src/physics/cam/ndrop.F90 +src/physics/cam/phys_control.F90 +src/physics/cam/physpkg.F90 +src/physics/cam/pkg_cldoptics.F90 +src/physics/cam/vertical_diffusion.F90 +. remove dependecies on SPCAM_sam1mom and SPCAM_m2005 + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: +ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) +- pre-existing failures due to HEMCO not having reproducible results (issues #1018 and #856) + +SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) +SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) +- pre-existing failures due to build-namelist error requiring CLM/CTSM external update + +derecho/nvhpc/aux_cam: All PASS + +izumi/nag/aux_cam: All PASS + +izumi/gnu/aux_cam: All PASS + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers: BFB + +=============================================================== +=============================================================== + +Tag name: cam6_4_066 +Originator(s): fvitt +Date: 14 Feb 2025 +One-line Summary: Limit extraneous log file messages from aerosol wet deposition +Github PR URL: https://github.com/ESCOMP/CAM/pull/1228 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + + Ignore the insignificant negative values produced by aerosol wet deposition module. + Report the larger (possibly significant) negative values in the log file and abort + when DEBUG is TRUE. + Issue #1132 -- Extraneous output to cesm.log + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: cacraigucar + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M src/chemistry/aerosol/wetdep.F90 + - limit log messages as described above + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + FAIL ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s COMPARE_base_rest + FAIL SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d BASELINE /glade/campaign/cesm/community/amwg/cam_baselines/cam6_4_065_intel: DIFF + - pre-existing failures due to HEMCO not having reproducible results (issues #1018 and #856) + + FAIL SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie SETUP + FAIL SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s SETUP + - pre-existing failures due to build-namelist error requiring CLM/CTSM external update + +derecho/nvhpc/aux_cam: All PASS + +izumi/nag/aux_cam: All PASS + +izumi/gnu/aux_cam: + FAIL ERC_D_Ln9.f10_f10_mg37.QPSPCAMM.izumi_gnu.cam-outfrq3s + - pre-existing failure introduced in cam6_4_065 + +Summarize any changes to answers: Bit-for-bit unchanged + +=============================================================== +=============================================================== + +Tag name: cam6_4_065 +Originator(s): cacraig +Date: Feb 11, 2025 +One-line Summary: ZM CCPP'ization round 4 (completes CCPP conversion of ZM) + +Github PR URL: https://github.com/ESCOMP/CAM/pull/1218 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Convert ZM to CCPP and move into atmospheric_physics github repo: https://github.com/ESCOMP/CAM/issues/873 + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: + - Removed zmconv_org namelist as that partially implemented capability has been removed + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume, jimmielin + +List all files eliminated: N/A +D src/physics/cam/wv_sat_methods.F90 +D src/physics/cam/wv_saturation.F90 +D src/utils/error_messages.F90 +D src/utils/namelist_utils.F90 + - Moved to atmospheric_physics (and currently reside in the to_be_ccppized directory) + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M .gitmodules + - update atmospheric_physics to bring in ZM changes + +M bld/build-namelist +M bld/config_files/definition.xml +M bld/configure +M bld/namelist_files/namelist_defaults_cam.xml +M bld/namelist_files/namelist_definition.xml + - remove zmconv_org namelist + +M src/physics/cam/cloud_fraction.F90 + - moved cldfrc_fice to atmospheric_physics and ccppized + +M src/physics/cam/clubb_intr.F90 + - removed difzm declarations as no longer needed + +M src/physics/cam/convect_shallow.F90 +M src/physics/cam/macrop_driver.F90 +M src/physics/cam/physpkg.F90 +M src/physics/cam/rk_stratiform.F90 +M src/physics/cam/zm_conv_intr.F90 +M src/physics/cam7/physpkg.F90 +M src/physics/simple/physpkg.F90 + - various mods to get this to work with the routines that are ccppized + +M src/utils/cam_ccpp/ccpp_constituent_prop_mod.F90 + - Add routine: + ccp_set_standard_name to set constituent's standard name + ccp_is_dry to return whether species is dry + ccp_set_dry to set constituent's dry property based on what is passed in + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: all BFB, except: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) + - pre-existing failure due to HEMCO not having reproducible results (issues #1018 and #856) + + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) + - pre-existing failures due to build-namelist error requiring CLM/CTSM external update + +derecho/nvhpc/aux_cam: BFB + +izumi/nag/aux_cam: BFB + +izumi/gnu/aux_cam: + ERC_D_Ln9.f10_f10_mg37.QPSPCAMM.izumi_gnu.cam-outfrq3s (Overall: FAIL) details: + - New failure, but since SPCAM is being removed(PR 1217) will create this new pre-existing failure + +=============================================================== +=============================================================== + +Tag name: cam6_4_064 +Originator(s): sjsprecious, huebleruwm +Date: Feb 10, 2025 +One-line Summary: Fix broken GPU tests for CLUBB code +Github PR URL: https://github.com/ESCOMP/CAM/pull/1226 + +Purpose of changes (include the issue number and title text for each relevant +GitHub issue): + +This PR fixes the broken ERS tests due to the recent GPU changes of CLUBB code +(PR #1175). + +Note that this PR need a new ccs_config tag from ESMCI/ccs_config_cesm#204 to +complete this PR. + +Closes #1220 - GPU test fails restart comparison + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: + +M .gitmodules + - Update ccs_config submodule to ccs_config_cesm1.0.21 (needed for test fix) + +M src/physics/cam/clubb_intr.F90 + - Move variables from OpenACC create call to copy call to fix restart test. + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + +ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) +SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) + - pre-existing failure due to HEMCO not having reproducible results (issues #1018 and #856) + +SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) +SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) + - pre-existing failures due to build-namelist error requiring CLM/CTSM external update + +SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FHISTC_MTt1s.derecho_intel.cam-outfrq9s_Leung_dust (Overall: DIFF) + - Missed baseline update from previous CAM tag (cam6_4_063) + +derecho/nvhpc/aux_cam: + +ERS_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_gpu_default (Overall: DIFF) + - Expected change in baseline answers. + +izumi/nag/aux_cam: ALL PASS + +izumi/gnu/aux_cam: ALL PASS + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers, i.e., +- what code configurations: +- what platforms/compilers: +- nature of change (roundoff; larger than roundoff but same climate; new + climate): + +If bitwise differences were observed, how did you show they were no worse +than roundoff? + +If this tag changes climate describe the run(s) done to evaluate the new +climate in enough detail that it(they) could be reproduced, i.e., +- source tag (all code used must be in the repository): +- platform/compilers: +- configure commandline: +- build-namelist command (or complete namelist): +- MSS location of output: + +MSS location of control simulations used to validate new climate: + +URL for AMWG diagnostics output used to validate new climate: + +=============================================================== +=============================================================== + +Tag name: cam6_4_063 +Originator(s): cacraig, PeterHjortLauritzen +Date: Feb 9, 2025 +One-line Summary: Update namelist settings for beta06 +Github PR URL: https://github.com/ESCOMP/CAM/pull/1252 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Namelist changes for CAM7: https://github.com/ESCOMP/CAM/issues/1251 + - Need new dust-related namelist settings on by default: https://github.com/ESCOMP/CAM/1249 + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: + - Change namelist settings for seasalt_emis_scale, clubb_c8, dust_emis_method and dust_emis_fact + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: PeterHjortLauritzen, adamrher, ekluzek + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M bld/namelist_files/namelist_defaults_cam.xml + - Change namelist settings for seasalt_emis_scale, clubb_c8, dust_emis_method and dust_emis_fact + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) + - pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) + - pre-existing failures due to build-namelist error requiring CLM/CTSM external update + + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.QPLT.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.QPMT.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ld3.ne30pg3_ne30pg3_mg17.FHISTC_MTt4s.derecho_intel.cam-outfrq1d_aoa (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FHISTC_MTt1s.derecho_intel.cam-outfrq9s_Leung_dust (Overall: DIFF) details: + - All CAM7 runs will have answer changes (NLCOMP differences for these runs as well) + +derecho/nvhpc/aux_cam: + ERS_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_gpu_default (Overall: FAIL) + - pre-existing failure -- issue #1220 + +izumi/nag/aux_cam: All BFB + +izumi/gnu/aux_cam: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.FLTHIST.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPLT.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPMT.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + - All CAM7 runs will have answer changes (NLCOMP differences for these runs as well) + +=============================================================== + +=============================================================== + +Tag name: cam6_4_062 +Originator(s): juliob, cacraig, PeterHjortLauritzen +Date: Feb 7, 2025 +One-line Summary: Phase 2 of GW development +Github PR URL: https://github.com/ESCOMP/CAM/pull/1117 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Continuing development of gravity wave parameterization (//github.com/ESCOMP/CAM/issues/1115) + - Added vorticity calculation to SE dycore. Vorticity is passed to the gravity wave (GW) scheme in + model physics to provide a possible source for ‘moving mountain’ GW, i.e., low-phase speed GW forced + by atmospheric circulations. This provides another forcing option, in addition to boundary layer + momentum flux implemented earlier. Vorticity anomalies as sources for GW have been proposed by other + researchers in published papers. + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: + - Added the following namelist options + - use_gw_rdg_resid + - effgw_movmtn_pbl + - movmtn_source + - movmtn_psteer + - movmtn_plaunch + - effgw_rdg_resid + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume, PeterHjortLauritzen + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M bld/build-namelist +M bld/namelist_files/namelist_defaults_cam.xml +M bld/namelist_files/namelist_definition.xml + - added new GW namelist settings (see above) + +M src/dynamics/se/dp_coupling.F90 +M src/dynamics/se/dyn_comp.F90 +M src/dynamics/se/gravity_waves_sources.F90 +M src/physics/cam/gw_common.F90 +M src/physics/cam/gw_drag.F90 +M src/physics/cam/gw_movmtn.F90 +M src/physics/cam/gw_rdg.F90 + - See description listed above + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) + - pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) + - pre-existing failures due to build-namelist error requiring CLM/CTSM external update + + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.QPLT.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.QPMT.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ld3.ne30pg3_ne30pg3_mg17.FHISTC_MTt4s.derecho_intel.cam-outfrq1d_aoa (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FHISTC_MTt1s.derecho_intel.cam-outfrq9s_Leung_dust (Overall: DIFF) details: + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + - Answer changes expected for CAM7 runs + +derecho/nvhpc/aux_cam: + ERS_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_gpu_default (Overall: FAIL) + - pre-existing failure -- issue #1220 + +izumi/nag/aux_cam: All BFB + +izumi/gnu/aux_cam: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.FLTHIST.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPLT.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPMT.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + - Answer changes expected for CAM7 runs + +Summarize any changes to answers, i.e., +- what code configurations: All CAM7 +- what platforms/compilers: All +- nature of change (roundoff; larger than roundoff but same climate; new + climate): new climate when GW namelists are set + +If this tag changes climate describe the run(s) done to evaluate the new +climate in enough detail that it(they) could be reproduced, i.e., + - Simulations were made by Julio Bacmeister and were presented at AMWG + - Dave Lawrence presented results to the SCC at their January meeting + +=============================================================== + +=============================================================== + +Tag name: cam6_4_061 +Originator(s): liyptardis, PeterHjortLauritzen, cacraig +Date: Feb 6, 2025 + +One-line Summary: fix heating depth bug for gravity wave parameterization +Github PR URL: https://github.com/ESCOMP/CAM/pull/1232 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Gravity wave scheme fails to catch the right maximum latent heating rate and convective top from the ZM scheme. + This PR fixes that isuue. (Github issue #1229) + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume, liyptardis + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M src/physics/cam/gw_convect.F90 + - fix heating depth + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) + - pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) + - pre-existing failures due to build-namelist error requiring CLM/CTSM external update + + ERC_D_Ln9.f19_f19_mg17.QPX2000.derecho_intel.cam-outfrq3s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.QPLT.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.QPMT.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details: + ERP_Ld3.ne30pg3_ne30pg3_mg17.FHISTC_MTt4s.derecho_intel.cam-outfrq1d_aoa (Overall: DIFF) details: + ERP_Lh12.f19_f19_mg17.FW4madSD.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + SMS_D_Ln9.ne16_ne16_mg17.QPX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FHISTC_MTt1s.derecho_intel.cam-outfrq9s_Leung_dust (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + - Expect baseline differences + +derecho/nvhpc/aux_cam: + ERS_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_gpu_default (Overall: FAIL) + - pre-existing failure -- issue #1220 + +izumi/nag/aux_cam: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-carma_sea_salt (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_subcol (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QSPCAMS.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.mpasa480z32_mpasa480.FHS94.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9.ne16_ne16_mg17.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9.ne16pg3_ne16pg3_mg17.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-outfrq3s_ttrac (Overall: DIFF) details: + ERC_D_Ln9.T5_T5_mg37.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERI_D_Ln18.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_eoyttrac (Overall: DIFF) details: + ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: + ERI_D_Ln18.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq3s_bwic (Overall: DIFF) details: + ERI_D_Ln18.ne5pg3_ne5pg3_mg37.FADIAB.izumi_nag.cam-outfrq3s_bwic (Overall: DIFF) details: + ERP_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_clubbmf (Overall: DIFF) details: + ERS_Ln27.ne5pg3_ne5pg3_mg37.FKESSLER.izumi_nag.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq9s (Overall: DIFF) details: + PEM_D_Ln9.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) details: + SMS_D_Ld2.f45_f45_mg37.PC5.izumi_nag.cam-outfrq24h_port (Overall: DIFF) details: + SMS_D_Ln3.ne5pg3_ne5pg3_mg37.QPX2000.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + SMS_D_Ln6.ne5_ne5_mg37.QPWmaC4.izumi_nag.cam-outfrq3s_physgrid_tem (Overall: DIFF) details: + SMS_D_Ln7.T42_T42_mg17.QPSCAMC5.izumi_nag.cam-scmarm (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-rad_diag_mam (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_ba (Overall: DIFF) details: + SMS_D_Ln9_P1x1.ne5_ne5_mg37.FADIAB.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase (Overall: DIFF) details: + SUB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + TMC_D.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_eoyttrac (Overall: DIFF) details: + TMC_D.T5_T5_mg37.QPC5.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: + - Expect baseline differences + + +izumi/gnu/aux_cam: + ERC_D_Ln9.f10_f10_mg37.QPC4.izumi_gnu.cam-outfrq3s_diags (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.FLTHIST.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPLT.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPMT.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_P24x2.f45_f45_mg37.QPWmaC6.izumi_gnu.cam-outfrq9s_mee_fluxes (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPWmaC4.izumi_gnu.cam-outfrq9s_apmee (Overall: DIFF) details: + SMS_P48x1_D_Ln9.f19_f19_mg17.FW4madSD.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + - Expect baseline differences + +=============================================================== +=============================================================== + +Tag name: cam6_4_060 +Originator(s): klindsay, PeterHjortLauritzen, cacraig +Date: Feb 5, 2025 +One-line Summary: Preserve constant dry mixing ratios in gw and vertical diffusion code + +Github PR URL: Preserve constant dry mixing ratios in gw_drag and vertical diffusion code (https://github.com/ESCOMP/CAM/pull/1234) + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Keith Lindsay's modifications for preservation of dry constant mixing ratios. (Github issue #1233) + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: cacraig + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M src/physics/cam/gw_drag.F90 +M src/physics/cam/vertical_diffusion.F90 + - changes to preserve dry mixing ratios + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) + - pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) + - pre-existing failures due to build-namelist error requiring CLM/CTSM external update + + ERC_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9.f19_f19_mg17.QPMOZ.derecho_intel.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f19_f19_mg17.QPX2000.derecho_intel.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.ne16_ne16_mg17.QPC5HIST.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9_P64x2.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details: + ERP_Ld3.ne30pg3_ne30pg3_mg17.FHISTC_MTt4s.derecho_intel.cam-outfrq1d_aoa (Overall: DIFF) details: + ERP_Lh12.f19_f19_mg17.FW4madSD.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF) details: + SCT_D_Ln7.ne3_ne3_mg37.QPC5.derecho_intel.cam-scm_prep (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC5.derecho_intel.cam-scm_prep (Overall: DIFF) details: + SMS_D_Ld2.f19_f19_mg17.QPC5HIST.derecho_intel.cam-volc_usecase (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.QPC5M7.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne16_ne16_mg17.QPX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FHISTC_MTt1s.derecho_intel.cam-outfrq9s_Leung_dust (Overall: DIFF) details: + SMS_D_Ln9.T42_T42.FSCAMARM97.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: + SMS_Ln9.f19_f19.F2000climo.derecho_intel.cam-silhs (Overall: DIFF) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + - expect answer changes for most regression tests + +derecho/nvhpc/aux_cam: + ERS_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_gpu_default (Overall: FAIL) details: + - expect answer changes for most regression tests + +izumi/nag/aux_cam: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-carma_sea_salt (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_subcol (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-outfrq3s_ttrac (Overall: DIFF) details: + ERI_D_Ln18.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_eoyttrac (Overall: DIFF) details: + ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: + ERP_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_clubbmf (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) details: + SMS_D_Ln3.ne5pg3_ne5pg3_mg37.QPX2000.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + SMS_D_Ln6.ne5_ne5_mg37.QPWmaC4.izumi_nag.cam-outfrq3s_physgrid_tem (Overall: DIFF) details: + SMS_D_Ln7.T42_T42_mg17.QPSCAMC5.izumi_nag.cam-scmarm (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-rad_diag_mam (Overall: DIFF) details: + SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase (Overall: DIFF) details: + SUB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + TMC_D.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_eoyttrac (Overall: DIFF) details: + TMC_D.T5_T5_mg37.QPC5.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: + - expect answer changes for most regression tests + +izumi/gnu/aux_cam: + ERC_D_Ln9.f10_f10_mg37.QPC4.izumi_gnu.cam-outfrq3s_diags (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_gnu.cam-outfrq3s_unicon (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPSPCAMM.izumi_gnu.cam-outfrq3s (Overall: DIFF) details: + ERP_D_Ln9.C48_C48_mg17.QPC6.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.FLTHIST.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne5_ne5_mg37.QPC5.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_P24x2.f45_f45_mg37.QPWmaC6.izumi_gnu.cam-outfrq9s_mee_fluxes (Overall: DIFF) details: + ERS_Ln9_P24x1.mpasa480_mpasa480.F2000climo.izumi_gnu.cam-outfrq9s_mpasa480 (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal3 (Overall: DIFF) details: + SCT_D_Ln7.ne3_ne3_mg37.QPC6.izumi_gnu.cam-scm_prep_c6 (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC6.izumi_gnu.cam-scm_prep_c6 (Overall: DIFF) details: + SMS_D_Ln3.f10_f10_mg37.QPMOZ.izumi_gnu.cam-outfrq3s_chemproc (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPWmaC4.izumi_gnu.cam-outfrq9s_apmee (Overall: DIFF) details: + SMS_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-outfrq3s_ttrac (Overall: DIFF) details: + SMS_P48x1_D_Ln9.f19_f19_mg17.FW4madSD.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + - expect answer changes for most regression tests + +=============================================================== +=============================================================== + +Tag name: cam6_4_059 +Originator(s): adamrher, PeterHjortLauritzen, cacraig +Date: Feb 4, 2025 +One-line Summary: cloud frac bug in nucleate_ice_cam.F90 +Github PR URL: issue 1212 bug fix (cloud frac ice+liquid): https://github.com/ESCOMP/CAM/pull/1230 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - ice cloud fraction not set correctly (set to ice+liquid but should only be ice). (Github issue #1212) + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: cacraig + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M src/physics/cam/nucleate_ice_cam.F90 + - Fix ice cloud fraction + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) + - pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) + - pre-existing failures due to build-namelist error requiring CLM/CTSM external update + + ERC_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9_P64x2.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details: + ERP_Ld3.ne30pg3_ne30pg3_mg17.FHISTC_MTt4s.derecho_intel.cam-outfrq1d_aoa (Overall: DIFF) details: + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) details: + SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FHISTC_MTt1s.derecho_intel.cam-outfrq9s_Leung_dust (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: + SMS_Ln9.f19_f19.F2000climo.derecho_intel.cam-silhs (Overall: DIFF) details: + SMS_Ln9.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: DIFF) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + - Changes expected due to bug fix + +derecho/nvhpc/aux_cam: + ERS_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_gpu_default (Overall: FAIL) details: + - Changes expected due to bug fix + +izumi/nag/aux_cam: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: + ERP_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_clubbmf (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_ba (Overall: DIFF) details: + SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase (Overall: DIFF) details: + - Changes expected due to bug fix + +izumi/gnu/aux_cam: + ERP_D_Ln9.C48_C48_mg17.QPC6.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.FLTHIST.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_P24x2.f45_f45_mg37.QPWmaC6.izumi_gnu.cam-outfrq9s_mee_fluxes (Overall: DIFF) details: + ERS_Ln9_P24x1.mpasa480_mpasa480.F2000climo.izumi_gnu.cam-outfrq9s_mpasa480 (Overall: DIFF) details: + SCT_D_Ln7.ne3_ne3_mg37.QPC6.izumi_gnu.cam-scm_prep_c6 (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC6.izumi_gnu.cam-scm_prep_c6 (Overall: DIFF) details: + - Changes expected due to bug fix + +=============================================================== +=============================================================== + +Tag name: cam6_4_058 +Originator(s): PeterHjortLauritzen, adamrher, bstephens82, jimmielin, nusbaume +Date: Jan 31 2025 +One-line Summary: Fix Exner bug in CLUBB interface and change CLUBB namelist +Github PR URL: https://github.com/ESCOMP/CAM/pull/1231 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + +The computation of the Exner function in the CLUBB interface code currently passes an incorrect version to the PBL utilities. +The PBL utilities expect the "Stull" definition of the Exner function rather than the traditional "atmospheric" Exner function. +(Github issue #1222) + +The CLUBB group has recommended a namelist change to address this issue. +(Github issue #1208) + +Snapshots of tphysbc/tphysac subroutine-level variables are always in the "after" state for both tapes +(Github issue #1241) + +Describe any changes made to build system: none + +Describe any changes made to the namelist: + +M bld/namelist_files/namelist_defaults_cam.xml + - Turn off 'clubb_l_min_wp2_from_corr_wx' option in CLUBB + +List any changes to the defaults for the boundary datasets: none + +Describe any substantial timing or memory changes: not evaluated + +Code reviewed by: cacraigucar + +List all files eliminated: none + +List all files added and what they do: none + +List all existing files that have been modified, and describe the changes: + +M src/physics/cam/cam_snapshot.F90 + - Switch to correct tape for tphysac/tphysbc snapshot + +M src/physics/cam/clubb_intr.F90 + - Replace CLUBB exner with "Stull" Exner, which is what is actually expected. + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +NLCOMP and baseline failures for all applications using CLUBB. + +derecho/intel/aux_cam: + +ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) +SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) + - pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + +SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) +SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) + - pre-existing failures due to build-namelist error requiring CLM/CTSM external update + +derecho/nvhpc/aux_cam: + +ERS_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_gpu_default (Overall: FAIL) + - pre-existing failure -- issue #1220 + +izumi/nag/aux_cam: + +All non-CAM6/CAM7 tests pass (CAM6 and CAM7 differences expected) + +izumi/gnu/aux_cam: + +All non-CAM6/CAM7 tests pass (CAM6 and CAM7 differences expected) + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers, i.e., +- what code configurations: +- what platforms/compilers: +- nature of change (roundoff; larger than roundoff but same climate; new + climate): + +If bitwise differences were observed, how did you show they were no worse +than roundoff? + +If this tag changes climate describe the run(s) done to evaluate the new +climate in enough detail that it(they) could be reproduced, i.e., +- source tag (all code used must be in the repository): +- platform/compilers: +- configure commandline: +- build-namelist command (or complete namelist): +- MSS location of output: + +MSS location of control simulations used to validate new climate: + +URL for AMWG diagnostics output used to validate new climate: + +=============================================================== +=============================================================== + +Tag name: cam6_4_057 +Originator(s): brianpm, eaton, nusbaume +Date: Jan 29 2025 +One-line Summary: Restore spectral scaling to RRTMGP +Github PR URL: https://github.com/ESCOMP/CAM/pull/1194 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + +resolve issue #1193 - Restore spectral scaling to RRTMGP + +Describe any changes made to build system: none + +Describe any changes made to the namelist: none + +List any changes to the defaults for the boundary datasets: none + +Describe any substantial timing or memory changes: not evaluated + +Code reviewed by: peverwhee + +List all files eliminated: none + +List all files added and what they do: + +src/physics/rrtmgp/rad_solar_var.F90 +. compute scale factors for solar irradiance based on input dataset + +List all existing files that have been modified, and describe the changes: + +bld/build-namelist +. change default setting of solar_htng_spctrl_scl to true for rrtmgp + +src/physics/rrtmgp/radconstants.F90 +. add module data band2gpt_sw and set using kdist_sw%get_band_lims_gpoint() + +src/physics/rrtmgp/radiation.F90 +. radiation_init + - add call to rad_solar_var_init +. radiation_tend + - replace code that scales the solar source based on internal RRTMGP + spectral distribution by a scaling based on distribution from the + solar_irrad_data_file. + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + +ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) +ERP_D_Ln9.ne30pg3_ne30pg3_mg17.QPLT.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) +ERP_D_Ln9.ne30pg3_ne30pg3_mg17.QPMT.derecho_intel.cam-outfrq9s (Overall: DIFF) +ERP_Ld3.ne30pg3_ne30pg3_mg17.FHISTC_MTt4s.derecho_intel.cam-outfrq1d_aoa (Overall: DIFF) +SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) +SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FHISTC_MTt1s.derecho_intel.cam-outfrq9s_Leung_dust (Overall: DIFF) +SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) + - expected NLCOMP (solar_htng_spctrl_scl) and baseline answer changes due to restored RRTMGP spectral scaling. + + +ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) +SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) + - pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + +SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: FAIL) +SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) + - pre-existing failures due to build-namelist error requiring CLM/CTSM external update + +derecho/nvhpc/aux_cam: + +ERS_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_gpu_default (Overall: FAIL) + - pre-existing failure -- issue #1220 + +izumi/nag/aux_cam: ALL PASS + +izumi/gnu/aux_cam: + +ERP_D_Ln9.ne3pg3_ne3pg3_mg37.FLTHIST.izumi_gnu.cam-outfrq9s (Overall: DIFF) +ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPLT.izumi_gnu.cam-outfrq9s (Overall: DIFF) +ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPMT.izumi_gnu.cam-outfrq9s (Overall: DIFF) +SMS_Ld5.f09_f09_mg17.PC6.izumi_gnu.cam-cam6_port_f09_rrtmgp (Overall: DIFF) + - expected NLCOMP (solar_htng_spctrl_scl) and baseline answer changes due to restored RRTMGP spectral scaling. + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers, i.e., +- what code configurations: +- what platforms/compilers: +- nature of change (roundoff; larger than roundoff but same climate; new + climate): + +If bitwise differences were observed, how did you show they were no worse +than roundoff? + +If this tag changes climate describe the run(s) done to evaluate the new +climate in enough detail that it(they) could be reproduced, i.e., +- source tag (all code used must be in the repository): +- platform/compilers: +- configure commandline: +- build-namelist command (or complete namelist): +- MSS location of output: + +MSS location of control simulations used to validate new climate: + +URL for AMWG diagnostics output used to validate new climate: + +=============================================================== +=============================================================== + Tag name: cam6_4_056 Originator(s): fvitt Date: 16 Jan 2025 diff --git a/doc/ReleaseNotes b/doc/ReleaseNotes deleted file mode 100644 index c8ababd26a..0000000000 --- a/doc/ReleaseNotes +++ /dev/null @@ -1,300 +0,0 @@ -------------------------------------------------- -New features in CAM-5.4 -------------------------------------------------- - -## CAM-SE -* Update SE dycore tuning parameters (XXEaton) - - Change time stepping method to RK5 (Kinnmark & Gray Runga-Kutta 5 - stage; 3rd order accurate in time) - - Set the namelists variables as recommended for RK5 in: - http://www.cgd.ucar.edu/cms/pel/software/cam-se-dt-table.pdf - - Add "tstep_type" namelist option for SE dycore - - Turn on the FV energy fixer. - - Remove the variable "energy_fixer" from the cam namelist. - - Reformulated total energy as applied in physics_update and the energy fixers for CAM-FV and CAM-SE dycores. - -## CAM-FV -* Vertical remapping is now applied to temperature instead of energy. This - primarily affects WACCM by reducing numerical artifacts near the model top. - - Reformulated total energy as applied in physics_update and the energy fixers for CAM-FV and CAM-SE dycores. - -## CARMA -* Add six new CARMA models: - - cirrus_dust - - meteor_impact - - mixed_sulfate - - pmc_sulfate - - tholin - - test_tracers2 - -* Further development of CARMA-CAM integration, including: - - New sulfate model features. - - "Fractal" code for soot. - - Port to the NAG compiler. - -## CLUBB -* Update the version of CLUBB used -* Add features to the interface (all options, controlled by namelist switches) - - rain evaportation-turbulence feedback - - advection of CLUBB's moments - - cloud top radiational cooling parameterization - - explicit diffusion on CLUBBs prognostic temperature and total water - - provide support for CLUBB/microphysics sub-stepping - -## CHEMISTRY - -* Added ability to use wild fire emissions produced by CLM4.5 - -* Added option for external forcing of H2O from CH4 oxidation when running - low-top CAM5 without chemistry. CH4 oxidation is an important source of - H2O in the stratosphere. - -* Reaction constants updated to JPL10 - -* Added functionality to provide rate groupings (summations) diagnostics - -* Corrections to aerosol surface area - -* NEU wet deposition changes - . set TICE to 263 - . disable wet deposition poleward of 60 degrees and pressures < 200 mbar - . correction Henry's Law parameters used for SO2 deposition (in seq_drydep_mod) - . correction in units of NEU wet deposition diagnostics - -* Chemistry preprocessor updates: - . enthalpies for chemical potential heating now specified in mechanism files - . added ability to put comments at the end of reactions in mechanism file following '#' or '!' - . bug fixes for species names longer than 8 characters (up to 16 characters) - - -## COSP - . Update from COSP1.3 (version used for CMIP5) to COSP1.4 (version endorsed for CMIP6) - - includes code optimizations, new CALIPSO cloud phase diagnostics, new timing variables - - retains radiatively active snow in all simulators (merged from CESM version of COSP1.3) - - fixes bug affecting convective ice input into COSP - -## AEROSOLS - -* Added 4-mode modal aerosol model (MAM4) - -* Enhancements to emission specifications (surface and elevated): - . ability to specify emissions from multiple input files for any given species - . optional global attribute 'input_method' (set to: 'SERIAL', 'CYCLICAL', - or 'INTERP_MISSING_MONTHS') in the emissions input file which overrides the - corresponding *type namelist option on a file-by-file basis - . optional multiplier proceeding the emissions filepath, e.g.: - 'NAME -> 0.5*/path.../filename.nc' - -* Prognostic Modal Aerosols: Provide the capability to prognose modal aerosols in the stratosphere. This - gives CAM5 and WACCM5 the ability to simulate aerosols in the stratosphere - which originate from volcanic eruptions. To this end, accumulation to coarse - mode exchange is allowed and the widths and edges of the modes are modified - -* Added options to use different then default values for solubility factors for - BULK aerosols - -## DUST - -* Defaults changed for soil_erod and dust_emis_fact. - . All grids except the 0.9x1.25 FV and a few low resolution grid now use - the soid_erod dataset generated for the 1.9x2.5 FV grid. - . The value of dust_emis_fact has been changed for FV 1/2 and 1/4 degree - grids to 0.45 based on tuning done at PNNL. The value for FV 1 degree - was not changed since that will require retuning the production configuration. - -* Tuned following Albani et al., 2014 to best match observations - -* New soil erodibility file from Albani which specifically improves the dust in the Middle East - -## Radiation - -* New optical properties with less absorbing optics for MAM3 and MAM4 (use aeronet dust optics and dust in the aitken mode 2) - -* Added option to calculate solar insolation using the mean of cosz in a radiation time step. When this option is turned on, - it eliminates the spurious zonal oscillation of daily insolation caused by discrete time sampling. - -## Microphysics - -* New microphysics scheme: MG version 2 adds prognostic precipitation and has - a cleaner implementation compared to the original MG scheme. - -* It is now possible to control both the number of microphysics substeps per - physics time step, and joint macrophysics/microphysics substepping, via the - namelist. - -* Add pre-existing ice option to nucleate_ice code. - -* Add option for Hoose heterogeneous freezing parameterization. - -* Add option to specify/parameterize precipitation fraction - -* Add option to use a different dehydration threshold (rhmin) for in the polar stratosphere. - -* New switch to use alternative autoconversion scheme in MG2 (following Seifert and Behang 2001): when active this - uses a different autoconversion and accretion scheme for liquid in MG2 - -* Add Song and Zhang 2012 version of MG 2-moment microphysics in ZM convective scheme as an option - -## Macrophysics - -* Add option for a ice supersaturation closure (supported in both CAM5 and CAM-CLUBB) - -## Deep convection - -* Minor improvements to the ZM scheme improve robustness for some inputs - (e.g. unusually high temperatures). - -* Add option for convective organization in ZM (based on Mapes and Neale 2010) - -## Sub-columns -* Modifications to pbuf and history to support sub-columns - -* Introduced sub-column interface and utlities routines - -* Microphysics now has the ability to be run on grid(usual) or subcolumns - -## Gravity waves - -* New AMIP configuration with a high vertical resolution uses spectral - gravity waves in the low top model. - -* A long-wavelength inertial gravity wave spectrum has been added, and - frontogenesis can now trigger waves in this spectrum. - -* Gravity waves can be triggered from shallow, as well as deep, convection. - -* The entire gravity wave scheme has been audited to correct conservation - issues, internal inconsistencies, and problems with hard-coded parameters. - This should result in more accurate and less noisy output. - -* WACCM's gravity wave functionality can now be enabled in non-WACCM runs, - and can be enabled/disabled at run time via the namelist. - -* Most gravity wave parameters that were previously hard-coded are now - set by the namelist instead. - -* Added "tau_0_ubc" option, to enforce an upper boundary condition of tau = 0 - in the gravity wave parameterization. - -## WACCM - -* WACCM5 with prognostic modal aerosols in the stratosphere - -* Reaction constants updated to JPL10 - -* Background ionization from star light added to WACCM - -* New specification of stratospheric aerosols (volcanic) - -* New treatment of stratospheric aerosol chemistry - -* Corrections to age-of-air tracers - -* Bug fixes and usability improvements for SC-WACCM and WACCM5 that were - also added between CESM 1.2.1 and CESM 1.2.2. - -* Include SC-WACCM5 which has prognostic modal aerosols - -* WACCM-X now has an option to turn on the extended ionosphere including - calculation of electron and ion temperatur and ion transport ambipolar - diffusion - -## SCAM - -## SPCAM -* Super-parameterized CAM (SPCAM) implements a 2D cloud resolving model (the - System for Atmospheric Modeling SAM, version 6.8.2) in CAM. When it is turned on, - it replaces CAM's parameterization for moist convection and large-scale condensation - with this alternate model. - -* The SPCAM package allows CLUBB to be used or not. It is important to note that there is - a SPCAM-specific version of CLUBB within the CRM package and it is not the same CLUBB being - used by CAM - -## AQUAPLANET -* CESM-aquaplanet is now supported out-of-the-box via prescribed-SST (QPCx) and - slab-ocean (QSCx) compsets (where x is CAM version). - - -------------------------------------------------- -CODE CLEANUP AND REFACTORING -------------------------------------------------- - -* CARMA and the MG microphysics interface now use micro_mg_utils to get - size distribution parameters for cloud droplets, ice, and precipitation. - Previously this was done with duplicated code. - -* The chemistry-aerosol model interface was refactored to provide a more - extendable framework. This will ease incorporation of other aerosol - models (e.g., a sectional aerosol model) - -* The SE dycore now uses Pa instead of hPa, which is consistent with CAM's - physics. - -* The CAM and WACCM gravity wave modules have been merged together, and the - result was extensively refactored. The CAM interface (gw_drag.F90) has been - separated from a new set of modules that constitute a portable layer, and - the routines for the wave sources, wave propagation, and effective diffusion - have been separated from each other as well. - -* Removed the WACCM_PHYS preprocessor macro, and brought WACCM physics modules - up to date with current CAM conventions: - - - qbo, radheat, and iondrag have their own namelists. If WACCM is off, we - compile in stubs rather than using the WACCM_PHYS macro. - - Molecular diffusion is turned on/off at run time based on the namelist and - the extent of the vertical grid. - - Each type of gravity wave source is turned on/off via the namelist. - - WACCM-specific fields set by the dycore are now communicated via the physics - buffer rather than the physics_state object, and are only set if needed. - -* Remove restriction that radiation diagnostic calculations reuse the water - uptake and wet radius values calculated for the climate affecting modes. - These quantities are now recomputed for the diagnostic modes. - -* satellite history output was refactored to improve run-time performance - -- find nearest neighbor operation was parallelized - -* The vertical diffusion code was refactored to use new tridiagonal matrix - types, which represent operators in the diffusion equation. - -------------------------------------------------- -CAM INFRASTRUCTURE CHANGES -------------------------------------------------- - -* Improve the microp_aero driver by removing code that belonged in a CAM - specific interface for the nucleate_ice parameterization and adding the - missing CAM interface layer (nucleate_ice_cam). - -* Add two new functions to the rad_constituents interfaces to make it - easier to access the mode and specie indices for specific modes and - specie types. - -* Type descriptions in namelist_definitions.xml can now include variables - as dimensions. For instance, both "integer(n)" and "integer(2)" can be - used for a 1-D integer array. - -* The rad_climate and rad_diag_* arrays can now be set to a larger size - using the new "-max_n_rad_cnst" configure option. - -* Turning on CESM's DEBUG mode now also turns on state_debug_checks. - -* The Lahey compiler is no longer supported because it doesn't support Fortran - 2003 features. - -* Added a new namelist variable, history_aero_optics, to add modal aerosol - optics diagnostics to the default history fields. The existing - history_aerosol variable turns on diagnostics related to the aerosol - production and removal tendencies. - -* Preliminary implementation of further flags to control default history - outputs, including: - - history_waccm - - history_waccmx - - history_chemistry - - history_carma - - history_clubb - -* CAM history changes: - . increased number of fields in fincls from 750 to 1000 - . can have up to 10 simultaneous history files (or streams) diff --git a/src/atmos_phys b/src/atmos_phys index c3de8468f7..89b628646b 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit c3de8468f7b245a939448f4ca6d3ef386584e92d +Subproject commit 89b628646b1506f36b35e67038552f09fb0662e6 diff --git a/src/chemistry/aerosol/wetdep.F90 b/src/chemistry/aerosol/wetdep.F90 index b63ebec338..a1f80d9deb 100644 --- a/src/chemistry/aerosol/wetdep.F90 +++ b/src/chemistry/aerosol/wetdep.F90 @@ -1,9 +1,9 @@ module wetdep -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- ! ! Wet deposition routines for both aerosols and gas phase constituents. -! +! !----------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 @@ -44,23 +44,23 @@ module wetdep real(r8) :: totcond(pcols, pver) ! total condensate real(r8) :: cldv(pcols,pver) ! cloudy volume undergoing wet chem and scavenging real(r8) :: cldvcu(pcols,pver) ! Convective precipitation area at the top interface of current layer - real(r8) :: cldvst(pcols,pver) ! Stratiform precipitation area at the top interface of current layer + real(r8) :: cldvst(pcols,pver) ! Stratiform precipitation area at the top interface of current layer end type wetdep_inputs_t integer :: cld_idx = 0 -integer :: qme_idx = 0 -integer :: prain_idx = 0 -integer :: bergso_idx = 0 -integer :: nevapr_idx = 0 - -integer :: icwmrdp_idx = 0 -integer :: icwmrsh_idx = 0 -integer :: rprddp_idx = 0 -integer :: rprdsh_idx = 0 -integer :: sh_frac_idx = 0 -integer :: dp_frac_idx = 0 -integer :: nevapr_shcu_idx = 0 -integer :: nevapr_dpcu_idx = 0 +integer :: qme_idx = 0 +integer :: prain_idx = 0 +integer :: bergso_idx = 0 +integer :: nevapr_idx = 0 + +integer :: icwmrdp_idx = 0 +integer :: icwmrsh_idx = 0 +integer :: rprddp_idx = 0 +integer :: rprdsh_idx = 0 +integer :: sh_frac_idx = 0 +integer :: dp_frac_idx = 0 +integer :: nevapr_shcu_idx = 0 +integer :: nevapr_dpcu_idx = 0 integer :: ixcldice, ixcldliq !============================================================================== @@ -75,20 +75,20 @@ subroutine wetdep_init() integer :: ierr - cld_idx = pbuf_get_index('CLD') - qme_idx = pbuf_get_index('QME') - prain_idx = pbuf_get_index('PRAIN') - bergso_idx = pbuf_get_index('BERGSO', errcode=ierr ) - nevapr_idx = pbuf_get_index('NEVAPR') + cld_idx = pbuf_get_index('CLD') + qme_idx = pbuf_get_index('QME') + prain_idx = pbuf_get_index('PRAIN') + bergso_idx = pbuf_get_index('BERGSO', errcode=ierr ) + nevapr_idx = pbuf_get_index('NEVAPR') - icwmrdp_idx = pbuf_get_index('ICWMRDP') - rprddp_idx = pbuf_get_index('RPRDDP') - icwmrsh_idx = pbuf_get_index('ICWMRSH') - rprdsh_idx = pbuf_get_index('RPRDSH') + icwmrdp_idx = pbuf_get_index('ICWMRDP') + rprddp_idx = pbuf_get_index('RPRDDP') + icwmrsh_idx = pbuf_get_index('ICWMRSH') + rprdsh_idx = pbuf_get_index('RPRDSH') sh_frac_idx = pbuf_get_index('SH_FRAC' ) - dp_frac_idx = pbuf_get_index('DP_FRAC') - nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') - nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') + dp_frac_idx = pbuf_get_index('DP_FRAC') + nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') + nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') call cnst_get_ind('CLDICE', ixcldice) call cnst_get_ind('CLDLIQ', ixcldliq) @@ -177,22 +177,22 @@ subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & prain, cldv, cldvcu, cldvst, rain, & ncol) - ! ------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------------ ! Estimate the cloudy volume which is occupied by rain or cloud water as ! the max between the local cloud amount or the ! sum above of (cloud*positive precip production) sum total precip from above ! ---------------------------------- x ------------------------ ! sum above of (positive precip ) sum positive precip from above ! Author: P. Rasch - ! Sungsu Park. Mar.2010 + ! Sungsu Park. Mar.2010 ! ------------------------------------------------------------------------------------ ! Input arguments: real(r8), intent(in) :: t(pcols,pver) ! temperature (K) real(r8), intent(in) :: pmid(pcols,pver) ! pressure at layer midpoints real(r8), intent(in) :: pdel(pcols,pver) ! pressure difference across layers - real(r8), intent(in) :: cmfdqr(pcols,pver) ! dq/dt due to convective rainout - real(r8), intent(in) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation ( >= 0 ) + real(r8), intent(in) :: cmfdqr(pcols,pver) ! dq/dt due to convective rainout + real(r8), intent(in) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation ( >= 0 ) real(r8), intent(in) :: cldt(pcols,pver) ! total cloud fraction real(r8), intent(in) :: cldcu(pcols,pver) ! Cumulus cloud fraction real(r8), intent(in) :: cldst(pcols,pver) ! Stratus cloud fraction @@ -202,7 +202,7 @@ subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & integer, intent(in) :: ncol ! Output arguments: - real(r8), intent(out) :: cldv(pcols,pver) ! fraction occupied by rain or cloud water + real(r8), intent(out) :: cldv(pcols,pver) ! fraction occupied by rain or cloud water real(r8), intent(out) :: cldvcu(pcols,pver) ! Convective precipitation volume real(r8), intent(out) :: cldvst(pcols,pver) ! Stratiform precipitation volume real(r8), intent(out) :: rain(pcols,pver) ! mixing ratio of rain (kg/kg) @@ -299,10 +299,10 @@ subroutine wetdepa_v2( & convproc_do_aer, rcscavt, rsscavt, & sol_facti_in, sol_factic_in, convproc_do_evaprain_atonce_in, bergso_in ) - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ! scavenging code for very soluble aerosols - ! + ! !----------------------------------------------------------------------- real(r8), intent(in) ::& @@ -314,7 +314,7 @@ subroutine wetdepa_v2( & cmfdqr(pcols,pver), &! rate of production of convective precip evapc(pcols,pver), &! Evaporation rate of convective precipitation conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount + cwat(pcols,pver), &! cloud water amount precs(pcols,pver), &! rate of production of stratiform precip conds(pcols,pver), &! rate of production of condensate evaps(pcols,pver), &! rate of evaporation of precip @@ -334,7 +334,7 @@ subroutine wetdepa_v2( & integer, intent(in) :: ncol real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend + scavt(pcols,pver), &! scavenging tend iscavt(pcols,pver), &! incloud scavenging tends fracis(pcols,pver) ! fraction of species not scavenged @@ -344,13 +344,13 @@ subroutine wetdepa_v2( & ! Setting is_strat_cloudborne=.false. is being used to indicate that the tracers are the ! interstitial modal aerosols. In this case the optional qqcw (the cloud borne mixing ratio ! corresponding to the interstitial aerosol) must be provided, as well as the optional f_act_conv. - logical, intent(in), optional :: is_strat_cloudborne + logical, intent(in), optional :: is_strat_cloudborne real(r8), intent(in), optional :: qqcw(pcols,pver) real(r8), intent(in), optional :: f_act_conv(pcols,pver) real(r8), intent(in), optional :: sol_facti_in(pcols,pver) ! solubility factor (frac of aerosol scavenged in cloud) real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - + real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform @@ -447,7 +447,7 @@ subroutine wetdepa_v2( & ! the assumption is that within the cloud that ! all the tracer is in the cloud water ! - ! for both convective and stratiform clouds, + ! for both convective and stratiform clouds, ! the fraction of cloud water converted to precip defines ! the amount of tracer which is pulled out. @@ -465,11 +465,11 @@ subroutine wetdepa_v2( & rdeltat = 1.0_r8/deltat ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above + ! calculate the fraction of strat precip from above ! which evaporates within this layer fracev(i) = evaps(i,k)*pdog(i) & /max(1.e-12_r8,precabs(i)) - + ! If resuspending aerosol only when all the rain has totally ! evaporated then zero out any aerosol tendency for partial ! evaporation. @@ -486,7 +486,7 @@ subroutine wetdepa_v2( & ! ****************** Convection *************************** ! - ! set odds proportional to fraction of the grid box that is swept by the + ! set odds proportional to fraction of the grid box that is swept by the ! precipitation =precabc/rhoh20*(area of sphere projected on plane ! /volume of sphere)*deltat ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, @@ -579,7 +579,7 @@ subroutine wetdepa_v2( & fracp(i) = precs(i,k)*deltat / & max( 1.e-12_r8, cwat(i,k) + precs(i,k)*deltat ) fracp(i) = max( 0._r8, min( 1._r8, fracp(i) ) ) - + ! assume the corresponding amnt of tracer is removed st_scav_ic(i) = sol_facti(i,k)*clds(i)*fracp(i)*tracer(i,k)*rdeltat @@ -606,7 +606,7 @@ subroutine wetdepa_v2( & endif srct(i) = (srcc(i)+srcs(i))*omsm - + ! fraction that is not removed within the cloud ! (assumed to be interstitial, and subject to convective transport) fracp(i) = deltat*srct(i)/max(cldvst(i,k)*tracer(i,k),1.e-36_r8) ! amount removed @@ -628,7 +628,7 @@ subroutine wetdepa_v2( & if (present(bsscavt)) bsscavt(i,k) = -(srcs(i) * (1-fins(i))) * omsm + & fracev(i)*scavab(i)*rpdog(i) else - bcscavt(i,k) = -(srcc(i) * (1-finc(i))) * omsm + bcscavt(i,k) = -(srcc(i) * (1-finc(i))) * omsm rcscavt(i,k) = fracev_cu(i)*scavabc(i)*rpdog(i) bsscavt(i,k) = -(srcs(i) * (1-fins(i))) * omsm @@ -645,22 +645,22 @@ subroutine wetdepa_v2( & end do ! End of i = 1, ncol +#ifdef DEBUG + ! only check in debug mode which aborts when larger negative values are found found = .false. do i = 1,ncol - if ( dblchek(i) < 0._r8 ) then + ! catch the larger negative values, ignore insignificant small negaive values + if (dblchek(i) < -1.e-10_r8) then found = .true. - exit - end if + write(iulog,*) ' wetdapa_v2: negative value ', i, k, tracer(i,k), & + dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) + endif end do - if ( found ) then - do i = 1,ncol - if (dblchek(i) < 0._r8) then - write(iulog,*) ' wetdapa: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) - endif - end do - endif + if (found) then + call endrun('wetdapa_v2: negative values found') + end if +#endif end do ! End of k = 1, pver @@ -680,10 +680,10 @@ subroutine wetdepa_v1( t, p, q, pdel, & sol_facti_in, sol_factbi_in, sol_factii_in, & sol_factic_in, sol_factiic_in ) - !----------------------------------------------------------------------- - ! Purpose: + !----------------------------------------------------------------------- + ! Purpose: ! scavenging code for very soluble aerosols - ! + ! ! Author: P. Rasch ! Modified by T. Bond 3/2003 to track different removals !----------------------------------------------------------------------- @@ -699,7 +699,7 @@ subroutine wetdepa_v1( t, p, q, pdel, & cldc(pcols,pver), &! convective cloud fraction cmfdqr(pcols,pver), &! rate of production of convective precip conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount + cwat(pcols,pver), &! cloud water amount precs(pcols,pver), &! rate of production of stratiform precip conds(pcols,pver), &! rate of production of condensate evaps(pcols,pver), &! rate of evaporation of precip @@ -718,11 +718,11 @@ subroutine wetdepa_v1( t, p, q, pdel, & real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds real(r8), intent(in), optional :: sol_factiic_in ! sol_factii_in for convective clouds real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - + integer, intent(in) :: ncol real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend + scavt(pcols,pver), &! scavenging tend iscavt(pcols,pver), &! incloud scavenging tends fracis(pcols,pver) ! fraction of species not scavenged @@ -738,8 +738,8 @@ subroutine wetdepa_v1( t, p, q, pdel, & real(r8) adjfac ! factor stolen from cmfmca real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount + real(r8) cwatc ! local convective total water amount + real(r8) cwats ! local stratiform total water amount real(r8) cwatp ! local water amount falling from above precip real(r8) fracev(pcols) ! fraction of precip from above that is evaporating real(r8) fracp ! fraction of cloud water converted to precip @@ -779,7 +779,7 @@ subroutine wetdepa_v1( t, p, q, pdel, & real(r8) sol_factii, sol_factbi ! in cloud and below cloud fraction of aerosol scavenged by ice real(r8) sol_factic(pcols,pver) ! sol_facti for convective clouds real(r8) sol_factiic ! sol_factii for convective clouds - ! sol_factic & solfact_iic added for MODAL_AERO. + ! sol_factic & solfact_iic added for MODAL_AERO. ! For stratiform cloud, cloudborne aerosol is treated explicitly, ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. ! For convective cloud, cloudborne aerosol is not treated explicitly, @@ -809,7 +809,7 @@ subroutine wetdepa_v1( t, p, q, pdel, & ! the assumption is that within the cloud that ! all the tracer is in the cloud water ! - ! for both convective and stratiform clouds, + ! for both convective and stratiform clouds, ! the fraction of cloud water converted to precip defines ! the amount of tracer which is pulled out. ! @@ -833,7 +833,7 @@ subroutine wetdepa_v1( t, p, q, pdel, & pdog = pdel(i,k)/gravit ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above + ! calculate the fraction of strat precip from above ! which evaporates within this layer fracev(i) = evaps(i,k)*pdel(i,k)/gravit & /max(1.e-12_r8,precabs(i)) @@ -844,7 +844,7 @@ subroutine wetdepa_v1( t, p, q, pdel, & ! ****************** Convection *************************** ! now do the convective scavenging - ! set odds proportional to fraction of the grid box that is swept by the + ! set odds proportional to fraction of the grid box that is swept by the ! precipitation =precabc/rhoh20*(area of sphere projected on plane ! /volume of sphere)*deltat ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, @@ -860,7 +860,7 @@ subroutine wetdepa_v1( t, p, q, pdel, & ! srcs1 = cldt(i,k)*odds*tracer(i,k)*(1.-weight) & ! srcs1 = cldv(i,k)*odds*tracer(i,k)*(1.-weight) & !srcs1 = cldc(i,k)*odds*tracer(i,k)*(1.-weight) & - ! /deltat + ! /deltat ! fraction of convective cloud water converted to rain fracp = cmfdqr(i,k)*deltat/max(1.e-8_r8,conicw(i,k)) @@ -905,7 +905,7 @@ subroutine wetdepa_v1( t, p, q, pdel, & ! fracp = 0. ! for debug ! assume the corresponding amnt of tracer is removed - !++mcb -- remove cldc; change cldt to cldv + !++mcb -- remove cldc; change cldt to cldv ! srcs1 = (cldt(i,k)-cldc(i,k))*fracp*tracer(i,k)/deltat ! srcs1 = cldv(i,k)*fracp*tracer(i,k)/deltat & ! srcs1 = cldt(i,k)*fracp*tracer(i,k)/deltat ! all condensate @@ -938,7 +938,7 @@ subroutine wetdepa_v1( t, p, q, pdel, & endif srct(i) = (srcc+srcs)*omsm - + ! fraction that is not removed within the cloud ! (assumed to be interstitial, and subject to convective transport) fracp = deltat*srct(i)/max(cldmabs(i)*tracer(i,k),1.e-36_r8) ! amount removed @@ -966,22 +966,22 @@ subroutine wetdepa_v1( t, p, q, pdel, & end do +#ifdef DEBUG + ! only check in debug mode which aborts when larger negative values are found found = .false. do i = 1,ncol - if ( dblchek(i) < 0._r8 ) then + ! catch the larger negative values, ignore insignificant small negaive values + if (dblchek(i) < -1.e-10_r8) then found = .true. - exit - end if + write(iulog,*) ' wetdapa_v1: negative value ', i, k, tracer(i,k), & + dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) + endif end do - if ( found ) then - do i = 1,ncol - if (dblchek(i) < 0._r8) then - write(iulog,*) ' wetdapa: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) - endif - end do - endif + if (found) then + call endrun('wetdapa_v1: negative values found') + end if +#endif end do @@ -998,10 +998,10 @@ subroutine wetdepg( t, p, q, pdel, & solconst, scavt, iscavt, cldv, icwmr1, & icwmr2, fracis, ncol ) - !----------------------------------------------------------------------- - ! Purpose: + !----------------------------------------------------------------------- + ! Purpose: ! scavenging of gas phase constituents by henry's law - ! + ! ! Author: P. Rasch !----------------------------------------------------------------------- @@ -1014,12 +1014,12 @@ subroutine wetdepg( t, p, q, pdel, & cldc(pcols,pver), &! convective cloud fraction cmfdqr(pcols,pver), &! rate of production of convective precip rain (pcols,pver), &! total rainwater mixing ratio - cwat(pcols,pver), &! cloud water amount + cwat(pcols,pver), &! cloud water amount precs(pcols,pver), &! rate of production of stratiform precip evaps(pcols,pver), &! rate of evaporation of precip ! Sungsu evapc(pcols,pver), &! Rate of evaporation of convective precipitation -! Sungsu +! Sungsu cldv(pcols,pver), &! estimate of local volume occupied by clouds icwmr1 (pcols,pver), &! in cloud water mixing ration for zhang scheme icwmr2 (pcols,pver), &! in cloud water mixing ration for hack scheme @@ -1033,7 +1033,7 @@ subroutine wetdepg( t, p, q, pdel, & solconst(pcols,pver) ! Henry's law coefficient real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend + scavt(pcols,pver), &! scavenging tend iscavt(pcols,pver), &! incloud scavenging tends fracis(pcols, pver) ! fraction of constituent that is insoluble @@ -1044,12 +1044,12 @@ subroutine wetdepg( t, p, q, pdel, & real(r8) adjfac ! factor stolen from cmfmca real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatl ! local cloud liq water amount + real(r8) cwatc ! local convective total water amount + real(r8) cwats ! local stratiform total water amount + real(r8) cwatl ! local cloud liq water amount real(r8) cwatp ! local water amount falling from above precip real(r8) cwatpl ! local water amount falling from above precip (liq) - real(r8) cwatt ! local sum of strat + conv total water amount + real(r8) cwatt ! local sum of strat + conv total water amount real(r8) cwatti ! cwatt/cldv = cloudy grid volume mixing ratio real(r8) fracev ! fraction of precip from above that is evaporating real(r8) fracp ! fraction of cloud water converted to precip @@ -1105,17 +1105,17 @@ subroutine wetdepg( t, p, q, pdel, & ! partitioning coefs for gas and aqueous phase ! take as a cloud water amount, the sum of the stratiform amount - ! plus the convective rain water amount + ! plus the convective rain water amount ! convective amnt is just the local precip rate from the hack scheme ! since there is no storage of water, this ignores that falling from above ! cwatc = cmfdqr(i,k)*deltat/adjfac !++mcb -- test cwatc cwatc = (icwmr1(i,k) + icwmr2(i,k)) * (1._r8-weight) - !--mcb + !--mcb ! strat cloud water amount and also ignore the part falling from above - cwats = cwat(i,k) + cwats = cwat(i,k) ! cloud water as liq !++mcb -- add cwatc later (in cwatti) @@ -1127,7 +1127,7 @@ subroutine wetdepg( t, p, q, pdel, & ! total suspended condensate as liquid cwatt = cwatl + rain(i,k) - ! incloud version + ! incloud version !++mcb -- add cwatc here cwatti = cwatt/max(cldv(i,k), 0.00001_r8) + cwatc @@ -1143,14 +1143,14 @@ subroutine wetdepg( t, p, q, pdel, & part = patm*gafrac*tracer(i,k)*molwta/molwt ! use henrys law to give moles tracer /liter of water - ! in this volume + ! in this volume ! then convert to kg tracer /liter of water (kg tracer / kg water) mplb = solconst(i,k)*part*molwt/1000._r8 pdog = pdel(i,k)/gravit - ! this part of precip will be carried downward but at a new molarity of mpl + ! this part of precip will be carried downward but at a new molarity of mpl precic = pdog*(precs(i,k) + cmfdqr(i,k)) ! we cant take out more than entered, plus that available in the cloud @@ -1203,7 +1203,7 @@ subroutine wetdepg( t, p, q, pdel, & !--mcb ! now update the amount leaving the layer - scavbl = scavab(i) - scavt(i,k)*pdog + scavbl = scavab(i) - scavt(i,k)*pdog ! in cloud amount is that formed locally over the total flux out bottom fins = scavin/(scavin + scavbc + 1.e-36_r8) @@ -1212,11 +1212,11 @@ subroutine wetdepg( t, p, q, pdel, & scavab(i) = scavbl precab(i) = max(precxx + precic,1.e-36_r8) - - + + end do end do - + end subroutine wetdepg !############################################################################## diff --git a/src/chemistry/modal_aero/aero_model.F90 b/src/chemistry/modal_aero/aero_model.F90 index 056b998a36..d75730c2ff 100644 --- a/src/chemistry/modal_aero/aero_model.F90 +++ b/src/chemistry/modal_aero/aero_model.F90 @@ -1006,7 +1006,6 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ real(r8), pointer :: fldcw(:,:) real(r8), pointer :: sulfeq(:,:,:) - logical :: is_spcam_m2005 ! ! ... initialize nh3 ! @@ -1014,7 +1013,6 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ nh3_beg = vmr(1:ncol,:,nh3_ndx) end if ! - is_spcam_m2005 = cam_physpkg_is('spcam_m2005') call pbuf_get_field(pbuf, dgnum_idx, dgnum) call pbuf_get_field(pbuf, dgnumwet_idx, dgnumwet ) @@ -1046,14 +1044,13 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ ! call qqcw2vmr( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) - if (.not. is_spcam_m2005) then ! regular CAM - dvmrdt(:ncol,:,:) = vmr(:ncol,:,:) - dvmrcwdt(:ncol,:,:) = vmrcw(:ncol,:,:) + dvmrdt(:ncol,:,:) = vmr(:ncol,:,:) + dvmrcwdt(:ncol,:,:) = vmrcw(:ncol,:,:) ! aqueous chemistry ... - if( has_sox ) then - call setsox( & + if( has_sox ) then + call setsox( & ncol, & lchnk, & loffset, & @@ -1076,21 +1073,21 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ aqso4_o3 & ) - do n = 1, ntot_amode - l = lptr_so4_cw_amode(n) - if (l > 0) then - call outfld( trim(cnst_name_cw(l))//'AQSO4', aqso4(:ncol,n), ncol, lchnk) - call outfld( trim(cnst_name_cw(l))//'AQH2SO4', aqh2so4(:ncol,n), ncol, lchnk) - end if - end do + do n = 1, ntot_amode + l = lptr_so4_cw_amode(n) + if (l > 0) then + call outfld( trim(cnst_name_cw(l))//'AQSO4', aqso4(:ncol,n), ncol, lchnk) + call outfld( trim(cnst_name_cw(l))//'AQH2SO4', aqh2so4(:ncol,n), ncol, lchnk) + end if + end do - 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 ) + 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 ) - endif + endif -! Tendency due to aqueous chemistry + ! Tendency due to aqueous chemistry dvmrdt = (vmr - dvmrdt) / delt dvmrcwdt = (vmrcw - dvmrcwdt) / delt do m = 1, gas_pcnst @@ -1102,15 +1099,6 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ call outfld( name, wrk(:ncol), ncol, lchnk ) 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 - ! do gas-aerosol exchange (h2so4, msa, nh3 condensation) if (ndx_h2so4 > 0) then diff --git a/src/dynamics/se/dp_coupling.F90 b/src/dynamics/se/dp_coupling.F90 index 919b7f3510..41e24f18f0 100644 --- a/src/dynamics/se/dp_coupling.F90 +++ b/src/dynamics/se/dp_coupling.F90 @@ -49,9 +49,9 @@ subroutine d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) ! Note that all pressures and tracer mixing ratios coming from the dycore are based on ! dry air mass. - use gravity_waves_sources, only: gws_src_fnct - use dyn_comp, only: frontgf_idx, frontga_idx - use phys_control, only: use_gw_front, use_gw_front_igw + use gravity_waves_sources, only: gws_src_fnct,gws_src_vort + use dyn_comp, only: frontgf_idx, frontga_idx, vort4gw_idx + use phys_control, only: use_gw_front, use_gw_front_igw, use_gw_movmtn_pbl use hycoef, only: hyai, ps0 use fvm_mapping, only: dyn2phys_vector, dyn2phys_all_vars use se_dyn_time_mod, only: timelevel_qdp @@ -84,9 +84,16 @@ subroutine d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) real (kind=r8), allocatable :: frontga(:,:,:) ! function (frontgf) and angle (frontga) real (kind=r8), allocatable :: frontgf_phys(:,:,:) real (kind=r8), allocatable :: frontga_phys(:,:,:) + + ! Vorticity + real (kind=r8), allocatable :: vort4gw(:,:,:) ! temp arrays to hold vorticity + real (kind=r8), allocatable :: vort4gw_phys(:,:,:) + + ! Pointers to pbuf real (kind=r8), pointer :: pbuf_frontgf(:,:) real (kind=r8), pointer :: pbuf_frontga(:,:) + real (kind=r8), pointer :: pbuf_vort4gw(:,:) integer :: ncols, ierr integer :: col_ind, blk_ind(1), m @@ -110,6 +117,9 @@ subroutine d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) nullify(pbuf_chnk) nullify(pbuf_frontgf) nullify(pbuf_frontga) + nullify(pbuf_vort4gw) + + if (fv_nphys > 0) then nphys = fv_nphys @@ -136,11 +146,18 @@ subroutine d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) allocate(frontga(nphys_pts,pver,nelemd), stat=ierr) if (ierr /= 0) call endrun("dp_coupling: Allocate of frontga failed.") end if + if (use_gw_movmtn_pbl) then + allocate(vort4gw(nphys_pts,pver,nelemd), stat=ierr) + if (ierr /= 0) call endrun("dp_coupling: Allocate of vort4gw failed.") + end if if (iam < par%nprocs) then - if (use_gw_front .or. use_gw_front_igw) then + if (use_gw_front .or. use_gw_front_igw ) then call gws_src_fnct(elem, tl_f, tl_qdp_np0, frontgf, frontga, nphys) end if + if (use_gw_movmtn_pbl ) then + call gws_src_vort(elem, tl_f, tl_qdp_np0, vort4gw, nphys) + end if if (fv_nphys > 0) then call test_mapping_overwrite_dyn_state(elem,dyn_out%fvm) @@ -205,6 +222,9 @@ subroutine d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) frontgf(:,:,:) = 0._r8 frontga(:,:,:) = 0._r8 end if + if (use_gw_movmtn_pbl) then + vort4gw(:,:,:) = 0._r8 + end if endif ! iam < par%nprocs @@ -223,6 +243,9 @@ subroutine d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) allocate(frontgf_phys(pcols, pver, begchunk:endchunk)) allocate(frontga_phys(pcols, pver, begchunk:endchunk)) end if + if (use_gw_movmtn_pbl) then + allocate(vort4gw_phys(pcols, pver, begchunk:endchunk)) + end if !$omp parallel do num_threads(max_num_threads) private (col_ind, lchnk, icol, ie, blk_ind, ilyr, m) do col_ind = 1, phys_columns_on_task call get_dyn_col_p(col_ind, ie, blk_ind) @@ -240,6 +263,9 @@ subroutine d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) frontgf_phys(icol, ilyr, lchnk) = frontgf(blk_ind(1), ilyr, ie) frontga_phys(icol, ilyr, lchnk) = frontga(blk_ind(1), ilyr, ie) end if + if (use_gw_movmtn_pbl) then + vort4gw_phys(icol, ilyr, lchnk) = vort4gw(blk_ind(1), ilyr, ie) + end if end do do m = 1, pcnst @@ -265,6 +291,20 @@ subroutine d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) deallocate(frontgf_phys) deallocate(frontga_phys) end if + if (use_gw_movmtn_pbl) then + !$omp parallel do num_threads(max_num_threads) private (lchnk, ncols, icol, ilyr, pbuf_chnk, pbuf_vort4gw) + do lchnk = begchunk, endchunk + ncols = get_ncols_p(lchnk) + pbuf_chnk => pbuf_get_chunk(pbuf2d, lchnk) + call pbuf_get_field(pbuf_chnk, vort4gw_idx, pbuf_vort4gw) + do icol = 1, ncols + do ilyr = 1, pver + pbuf_vort4gw(icol, ilyr) = vort4gw_phys(icol, ilyr, lchnk) + end do + end do + end do + deallocate(vort4gw_phys) + end if call t_stopf('dpcopy') diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index 586ee06b1f..37aab5931a 100644 --- a/src/dynamics/se/dyn_comp.F90 +++ b/src/dynamics/se/dyn_comp.F90 @@ -10,7 +10,7 @@ module dyn_comp cnst_is_a_water_species use cam_control_mod, only: initial_run use cam_initfiles, only: initial_file_get_id, topo_file_get_id, pertlim -use phys_control, only: use_gw_front, use_gw_front_igw +use phys_control, only: use_gw_front, use_gw_front_igw, use_gw_movmtn_pbl use dyn_grid, only: ini_grid_name, timelevel, hvcoord, edgebuf, & ini_grid_hdim_name @@ -79,6 +79,7 @@ module dyn_comp ! Frontogenesis indices integer, public :: frontgf_idx = -1 integer, public :: frontga_idx = -1 +integer, public :: vort4gw_idx = -1 interface read_dyn_var module procedure read_dyn_field_2d @@ -572,6 +573,10 @@ subroutine dyn_register() call pbuf_add_field("FRONTGA", "global", dtype_r8, (/pcols,pver/), & frontga_idx) end if + if (use_gw_movmtn_pbl) then + call pbuf_add_field("VORT4GW", "global", dtype_r8, (/pcols,pver/), & + vort4gw_idx) + end if end subroutine dyn_register @@ -875,8 +880,7 @@ subroutine dyn_init(dyn_in, dyn_out) call get_loop_ranges(hybrid, ibeg=nets, iend=nete) call prim_init2(elem, fvm, hybrid, nets, nete, TimeLevel, hvcoord) !$OMP END PARALLEL - - if (use_gw_front .or. use_gw_front_igw) call gws_init(elem) + if (use_gw_front .or. use_gw_front_igw .or. use_gw_movmtn_pbl) call gws_init(elem) end if ! iam < par%nprocs call addfld ('nu_kmvis', (/ 'lev' /), 'A', '', 'Molecular viscosity Laplacian coefficient' , gridname='GLL') diff --git a/src/dynamics/se/gravity_waves_sources.F90 b/src/dynamics/se/gravity_waves_sources.F90 index a929dfeaf1..abdbaf1315 100644 --- a/src/dynamics/se/gravity_waves_sources.F90 +++ b/src/dynamics/se/gravity_waves_sources.F90 @@ -16,10 +16,12 @@ module gravity_waves_sources !! for use by WACCM (via dp_coupling) public :: gws_src_fnct + public :: gws_src_vort public :: gws_init private :: compute_frontogenesis + private :: compute_vorticity_4gw - type (EdgeBuffer_t) :: edge3 + type (EdgeBuffer_t) :: edge3,edge1 type (derivative_t) :: deriv real(r8) :: psurf_ref @@ -40,42 +42,52 @@ subroutine gws_init(elem) ! Set up variables similar to dyn_comp and prim_driver_mod initializations call initEdgeBuffer(par, edge3, elem, 3*nlev,nthreads=1) + call initEdgeBuffer(par, edge1, elem, nlev,nthreads=1) psurf_ref = hypi(plev+1) end subroutine gws_init - subroutine gws_src_fnct(elem, tl, tlq, frontgf, frontga,nphys) + subroutine gws_src_fnct(elem, tl, tlq, frontgf, frontga, nphys) use derivative_mod, only : derivinit - use dimensions_mod, only : npsq, nelemd + use dimensions_mod, only : nelemd use dof_mod, only : UniquePoints use hybrid_mod, only : config_thread_region, get_loop_ranges use parallel_mod, only : par use ppgrid, only : pver use thread_mod, only : horz_num_threads use dimensions_mod, only : fv_nphys + use cam_abortutils, only : handle_allocate_error + implicit none type (element_t), intent(inout), dimension(:) :: elem integer, intent(in) :: tl, nphys, tlq real (kind=r8), intent(out) :: frontgf(nphys*nphys,pver,nelemd) real (kind=r8), intent(out) :: frontga(nphys*nphys,pver,nelemd) + ! Local variables type (hybrid_t) :: hybrid - integer :: nets, nete, ithr, ncols, ie + integer :: nets, nete, ithr, ncols, ie, ierr real(kind=r8), allocatable :: frontgf_thr(:,:,:,:) real(kind=r8), allocatable :: frontga_thr(:,:,:,:) + ! This does not need to be a thread private data-structure call derivinit(deriv) !!$OMP PARALLEL NUM_THREADS(horz_num_threads), DEFAULT(SHARED), PRIVATE(nets,nete,hybrid,ie,ncols,frontgf_thr,frontga_thr) -! hybrid = config_thread_region(par,'horizontal') hybrid = config_thread_region(par,'serial') call get_loop_ranges(hybrid,ibeg=nets,iend=nete) - allocate(frontgf_thr(nphys,nphys,nlev,nets:nete)) - allocate(frontga_thr(nphys,nphys,nlev,nets:nete)) + allocate(frontgf_thr(nphys,nphys,nlev,nets:nete), stat=ierr) + call handle_allocate_error(ierr, 'gws_src_fnct', 'frontgf_thr') + + allocate(frontga_thr(nphys,nphys,nlev,nets:nete), stat=ierr) + call handle_allocate_error(ierr, 'gws_src_fnct', 'frontga_thr') + + call compute_frontogenesis(frontgf_thr,frontga_thr,tl,tlq,elem,deriv,hybrid,nets,nete,nphys) + if (fv_nphys>0) then do ie=nets,nete frontgf(:,:,ie) = RESHAPE(frontgf_thr(:,:,:,ie),(/nphys*nphys,nlev/)) @@ -90,10 +102,137 @@ subroutine gws_src_fnct(elem, tl, tlq, frontgf, frontga,nphys) end if deallocate(frontga_thr) deallocate(frontgf_thr) + !!$OMP END PARALLEL end subroutine gws_src_fnct + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine gws_src_vort(elem, tl, tlq, vort4gw, nphys) + use derivative_mod, only : derivinit + use dimensions_mod, only : nelemd + use dof_mod, only : UniquePoints + use hybrid_mod, only : config_thread_region, get_loop_ranges + use parallel_mod, only : par + use ppgrid, only : pver + use thread_mod, only : horz_num_threads + use dimensions_mod, only : fv_nphys + use cam_abortutils, only : handle_allocate_error + + implicit none + type (element_t), intent(in), dimension(:) :: elem + integer, intent(in) :: tl, nphys, tlq + + ! + real (kind=r8), intent(out) :: vort4gw(nphys*nphys,pver,nelemd) + + ! Local variables + type (hybrid_t) :: hybrid + integer :: nets, nete, ithr, ncols, ie, ierr + + ! + real(kind=r8), allocatable :: vort4gw_thr(:,:,:,:) + + ! This does not need to be a thread private data-structure + call derivinit(deriv) + !!$OMP PARALLEL NUM_THREADS(horz_num_threads), DEFAULT(SHARED), PRIVATE(nets,nete,hybrid,ie,ncols,vort4gw_thr) + hybrid = config_thread_region(par,'serial') + call get_loop_ranges(hybrid,ibeg=nets,iend=nete) + + allocate(vort4gw_thr(nphys,nphys,nlev,nets:nete), stat=ierr) + call handle_allocate_error(ierr, 'gws_src_vort', 'vort4gw_thr') + + call compute_vorticity_4gw(vort4gw_thr,tl,tlq,elem,deriv,hybrid,nets,nete,nphys) + + if (fv_nphys>0) then + do ie=nets,nete + vort4gw(:,:,ie) = RESHAPE(vort4gw_thr(:,:,:,ie),(/nphys*nphys,nlev/)) + end do + else + do ie=nets,nete + ncols = elem(ie)%idxP%NumUniquePts + call UniquePoints(elem(ie)%idxP, nlev, vort4gw_thr(:,:,:,ie), vort4gw(1:ncols,:,ie)) + end do + end if + deallocate(vort4gw_thr) + + !!$OMP END PARALLEL + + end subroutine gws_src_vort + + subroutine compute_vorticity_4gw(vort4gw,tl,tlq,elem,ederiv,hybrid,nets,nete,nphys) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! compute vorticity for use in gw params + ! F = ( curl ) [U,V] + ! + ! Original by Peter Lauritzen, Julio Bacmeister*, Dec 2024 + ! Patterned on 'compute_frontogenesis' + ! + ! * corresponding/blame-able + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + use derivative_mod, only: vorticity_sphere + use edge_mod, only: edgevpack, edgevunpack + use bndry_mod, only: bndry_exchange + use dimensions_mod, only: fv_nphys + use fvm_mapping, only: dyn2phys + + type(hybrid_t), intent(in) :: hybrid + type(element_t), intent(in) :: elem(:) + type(derivative_t), intent(in) :: ederiv + integer, intent(in) :: nets,nete,nphys + integer, intent(in) :: tl,tlq + real(r8), intent(out) :: vort4gw(nphys,nphys,nlev,nets:nete) + + ! local + real(r8) :: area_inv(fv_nphys,fv_nphys), tmp(np,np) + real(r8) :: vort_gll(np,np,nlev,nets:nete) + integer :: k,kptr,i,j,ie,component,h,nq,m_cnst,n0 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! First calculate vorticity on GLL grid + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! set timelevel=1 fro velocities + n0=tl + do ie=nets,nete + do k=1,nlev + call vorticity_sphere(elem(ie)%state%v(:,:,:,k,n0),ederiv,elem(ie),vort_gll(:,:,k,ie)) + end do + do k=1,nlev + vort_gll(:,:,k,ie) = vort_gll(:,:,k,ie)*elem(ie)%spheremp(:,:) + end do + ! pack + call edgeVpack(edge1, vort_gll(:,:,:,ie),nlev,0,ie) + enddo + call bndry_exchange(hybrid,edge1,location='compute_vorticity_4gw') + do ie=nets,nete + call edgeVunpack(edge1, vort_gll(:,:,:,ie),nlev,0,ie) + ! apply inverse mass matrix, + do k=1,nlev + vort_gll(:,:,k,ie) = vort_gll(:,:,k,ie)*elem(ie)%rspheremp(:,:) + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Now regrid from GLL to PhysGrid if necessary + ! otherwise just return vorticity on GLL grid + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (fv_nphys>0) then + tmp = 1.0_r8 + area_inv = dyn2phys(tmp,elem(ie)%metdet) + area_inv = 1.0_r8/area_inv + do k=1,nlev + vort4gw(:,:,k,ie) = dyn2phys( vort_gll(:,:,k,ie) , elem(ie)%metdet , area_inv ) + end do + else + do k=1,nlev + vort4gw(:,:,k,ie) = vort_gll(:,:,k,ie) + end do + end if + enddo + + + end subroutine compute_vorticity_4gw + + subroutine compute_frontogenesis(frontgf,frontga,tl,tlq,elem,ederiv,hybrid,nets,nete,nphys) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! compute frontogenesis function F diff --git a/src/physics/cam/cam_snapshot.F90 b/src/physics/cam/cam_snapshot.F90 index 7e7d83e9ef..da79aeb517 100644 --- a/src/physics/cam/cam_snapshot.F90 +++ b/src/physics/cam/cam_snapshot.F90 @@ -115,18 +115,53 @@ subroutine cam_snapshot_all_outfld_tphysbc(file_num, state, tend, cam_in, cam_ou lchnk = state%lchnk + call cam_history_snapshot_activate('tphysbc_flx_heat', file_num) call outfld('tphysbc_flx_heat', flx_heat, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_flx_heat') + + call cam_history_snapshot_activate('tphysbc_cmfmc', file_num) call outfld('tphysbc_cmfmc', cmfmc, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_cmfmc') + + call cam_history_snapshot_activate('tphysbc_cmfcme', file_num) call outfld('tphysbc_cmfcme', cmfcme, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_cmfcme') + + call cam_history_snapshot_activate('tphysbc_zdu', file_num) call outfld('tphysbc_zdu', zdu, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_zdu') + + call cam_history_snapshot_activate('tphysbc_rliq', file_num) call outfld('tphysbc_rliq', rliq, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_rliq') + + call cam_history_snapshot_activate('tphysbc_rice', file_num) call outfld('tphysbc_rice', rice, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_rice') + + call cam_history_snapshot_activate('tphysbc_dlf', file_num) call outfld('tphysbc_dlf', dlf, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_dlf') + + call cam_history_snapshot_activate('tphysbc_dlf2', file_num) call outfld('tphysbc_dlf2', dlf2, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_dlf2') + + call cam_history_snapshot_activate('tphysbc_rliq2', file_num) call outfld('tphysbc_rliq2', rliq2, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_rliq2') + + call cam_history_snapshot_activate('tphysbc_det_s', file_num) call outfld('tphysbc_det_s', det_s, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_det_s') + + call cam_history_snapshot_activate('tphysbc_det_ice', file_num) call outfld('tphysbc_det_ice', det_ice, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_det_ice') + + call cam_history_snapshot_activate('tphysbc_net_flx', file_num) call outfld('tphysbc_net_flx', net_flx, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysbc_net_flx') call cam_snapshot_all_outfld(file_num, state, tend, cam_in, cam_out, pbuf) @@ -163,10 +198,22 @@ subroutine cam_snapshot_all_outfld_tphysac(file_num, state, tend, cam_in, cam_ou lchnk = state%lchnk + call cam_history_snapshot_activate('tphysac_fh2o', file_num) call outfld('tphysac_fh2o', fh2o, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysac_fh2o') + + call cam_history_snapshot_activate('tphysac_surfric', file_num) call outfld('tphysac_surfric', surfric, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysac_surfric') + + call cam_history_snapshot_activate('tphysac_obklen', file_num) call outfld('tphysac_obklen', obklen, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysac_obklen') + + call cam_history_snapshot_activate('tphysac_flx_heat', file_num) call outfld('tphysac_flx_heat', flx_heat, pcols, lchnk) + call cam_history_snapshot_deactivate('tphysac_flx_heat') + call cam_snapshot_all_outfld(file_num, state, tend, cam_in, cam_out, pbuf) diff --git a/src/physics/cam/cloud_diagnostics.F90 b/src/physics/cam/cloud_diagnostics.F90 index bd0f9b8e9d..0aea0afbaf 100644 --- a/src/physics/cam/cloud_diagnostics.F90 +++ b/src/physics/cam/cloud_diagnostics.F90 @@ -30,7 +30,7 @@ module cloud_diagnostics integer :: dei_idx, mu_idx, lambda_idx, iciwp_idx, iclwp_idx, cld_idx ! index into pbuf for cloud fields integer :: ixcldice, ixcldliq, rei_idx, rel_idx - logical :: do_cld_diag, mg_clouds, rk_clouds, camrt_rad, spcam_m2005_clouds, spcam_sam1mom_clouds + logical :: do_cld_diag, camrt_rad logical :: one_mom_clouds, two_mom_clouds integer :: cicewp_idx = -1 @@ -45,8 +45,6 @@ module cloud_diagnostics ! Index fields for precipitation efficiency. integer :: acpr_idx, acgcme_idx, acnum_idx - logical :: use_spcam - contains !=============================================================================== @@ -59,12 +57,8 @@ subroutine cloud_diagnostics_register call phys_getopts(radiation_scheme_out=rad_pkg,microp_scheme_out=microp_pgk) camrt_rad = rad_pkg .eq. 'camrt' - rk_clouds = microp_pgk == 'RK' - mg_clouds = microp_pgk == 'MG' - spcam_m2005_clouds = microp_pgk == 'SPCAM_m2005' - spcam_sam1mom_clouds = microp_pgk == 'SPCAM_sam1mom' - one_mom_clouds = (rk_clouds .or. spcam_sam1mom_clouds) - two_mom_clouds = (mg_clouds .or. spcam_m2005_clouds) + one_mom_clouds = microp_pgk == 'RK' + two_mom_clouds = microp_pgk == 'MG' if (one_mom_clouds) then call pbuf_add_field('CLDEMIS','physpkg', dtype_r8,(/pcols,pver/), cldemis_idx) @@ -110,8 +104,6 @@ subroutine cloud_diagnostics_init(pbuf2d) ! grid box total cloud ice water mixing ratio (kg/kg) gb_totcldicemr_idx = pbuf_get_index('GB_TOTCLDICEMR') - call phys_getopts(use_spcam_out=use_spcam) - if (two_mom_clouds) then ! initialize to zero @@ -152,10 +144,10 @@ subroutine cloud_diagnostics_init(pbuf2d) if (.not.do_cld_diag) return - if (rk_clouds) then + if (one_mom_clouds) then wpunits = 'gram/m2' sampling_seq='rad_lwsw' - else if (two_mom_clouds .or. spcam_sam1mom_clouds) then + else if (two_mom_clouds) then wpunits = 'kg/m2' sampling_seq='' end if @@ -206,7 +198,7 @@ subroutine cloud_diagnostics_init(pbuf2d) call add_default ('TGCLDLWP', 1, ' ') call add_default ('TGCLDIWP', 1, ' ') call add_default ('TGCLDCWP', 1, ' ') - if(rk_clouds) then + if(one_mom_clouds) then if (camrt_rad) then call add_default ('EMIS', 1, ' ') else @@ -452,12 +444,10 @@ subroutine cloud_diagnostics_calc(state, pbuf) ! Determine parameters for maximum/random overlap call cldovrlap(lchnk, ncol, state%pint, cld, nmxrgn, pmxrgn) - if(.not. use_spcam) then ! in spcam, these diagnostics are calcluated in crm_physics.F90 -! Cloud cover diagnostics (done in radiation_tend for camrt) + ! Cloud cover diagnostics (done in radiation_tend for camrt) if (.not.camrt_rad) then call cloud_cover_diags_out(lchnk, ncol, cld, state%pmid, nmxrgn, pmxrgn ) endif - end if tgicewp(:ncol) = 0._r8 tgliqwp(:ncol) = 0._r8 @@ -503,15 +493,12 @@ subroutine cloud_diagnostics_calc(state, pbuf) endif - if (.not. use_spcam) then - ! for spcam, these are diagnostics in crm_physics.F90 - call outfld('GCLDLWP' ,gwp , pcols,lchnk) - call outfld('TGCLDCWP',tgwp , pcols,lchnk) - call outfld('TGCLDLWP',tgliqwp, pcols,lchnk) - call outfld('TGCLDIWP',tgicewp, pcols,lchnk) - call outfld('ICLDTWP' ,cwp , pcols,lchnk) - call outfld('ICLDIWP' ,cicewp , pcols,lchnk) - endif + call outfld('GCLDLWP' ,gwp , pcols,lchnk) + call outfld('TGCLDCWP',tgwp , pcols,lchnk) + call outfld('TGCLDLWP',tgliqwp, pcols,lchnk) + call outfld('TGCLDIWP',tgicewp, pcols,lchnk) + call outfld('ICLDTWP' ,cwp , pcols,lchnk) + call outfld('ICLDIWP' ,cicewp , pcols,lchnk) ! Compute total preciptable water in column (in mm) tpw(:ncol) = 0.0_r8 diff --git a/src/physics/cam/cloud_fraction.F90 b/src/physics/cam/cloud_fraction.F90 index 3285862fae..7b3297b67d 100644 --- a/src/physics/cam/cloud_fraction.F90 +++ b/src/physics/cam/cloud_fraction.F90 @@ -5,7 +5,7 @@ module cloud_fraction use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols, pver, pverp - use ref_pres, only: pref_mid + use ref_pres, only: pref_mid use spmd_utils, only: masterproc use cam_logfile, only: iulog use cam_abortutils, only: endrun @@ -22,7 +22,6 @@ module cloud_fraction cldfrc_init, &! Inititialization of cloud_fraction run-time parameters cldfrc_getparams, &! public access of tuning parameters cldfrc, &! Computation of cloud fraction - cldfrc_fice, &! Calculate fraction of condensate in ice phase (radiation partitioning) dp1, &! parameter for deep convection cloud fraction needed in clubb_intr dp2 ! parameter for deep convection cloud fraction needed in clubb_intr @@ -32,9 +31,9 @@ module cloud_fraction ! Top level integer :: top_lev = 1 - ! Physics buffer indices - integer :: sh_frac_idx = 0 - integer :: dp_frac_idx = 0 + ! Physics buffer indices + integer :: sh_frac_idx = 0 + integer :: dp_frac_idx = 0 ! Namelist variables logical :: cldfrc_freeze_dry ! switch for Vavrus correction @@ -154,8 +153,8 @@ subroutine cldfrc_register !----------------------------------------------------------------------- - call pbuf_add_field('SH_FRAC', 'physpkg', dtype_r8, (/pcols,pver/), sh_frac_idx) - call pbuf_add_field('DP_FRAC', 'physpkg', dtype_r8, (/pcols,pver/), dp_frac_idx) + call pbuf_add_field('SH_FRAC', 'physpkg', dtype_r8, (/pcols,pver/), sh_frac_idx) + call pbuf_add_field('DP_FRAC', 'physpkg', dtype_r8, (/pcols,pver/), dp_frac_idx) end subroutine cldfrc_register @@ -205,20 +204,19 @@ subroutine cldfrc_init macrop_scheme_out = macrop_scheme ) ! Limit CAM5 cloud physics to below top cloud level. - if ( .not. (macrop_scheme == "rk" .or. macrop_scheme == "SPCAM_sam1mom")) top_lev = trop_cloud_top_lev + if ( .not. macrop_scheme == "rk") top_lev = trop_cloud_top_lev ! Turn off inversion_cld if any UW PBL scheme is being used - if ( (eddy_scheme .eq. 'diag_TKE' ) .or. (shallow_scheme .eq. 'UW' ) .or.& - (shallow_scheme .eq. 'SPCAM_m2005') ) then + if ( eddy_scheme .eq. 'diag_TKE' .or. shallow_scheme .eq. 'UW' ) then inversion_cld_off = .true. else inversion_cld_off = .false. endif - if ( masterproc ) then + if ( masterproc ) then write(iulog,*)'tuning parameters cldfrc_init: inversion_cld_off',inversion_cld_off write(iulog,*)'tuning parameters cldfrc_init: dp1',dp1,'dp2',dp2,'sh1',sh1,'sh2',sh2 - if (shallow_scheme .ne. 'UW' .or. shallow_scheme .eq. 'SPCAM_m2005' ) then + if (shallow_scheme .ne. 'UW') then write(iulog,*)'tuning parameters cldfrc_init: rhminl',rhminl,'rhminl_adj_land',rhminl_adj_land, & 'rhminh',rhminh,'premit',premit,'premib',premib write(iulog,*)'tuning parameters cldfrc_init: iceopt',iceopt,'icecrit',icecrit @@ -249,38 +247,38 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & cmfmc ,cmfmc2 ,landfrac,snowh ,concld ,cldst , & ts ,sst ,ps ,zdu ,ocnfrac ,& rhu00 ,cldice ,icecldf ,liqcldf ,relhum ,dindex ) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Compute cloud fraction - ! - ! - ! Method: + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Compute cloud fraction + ! + ! + ! Method: ! This calculate cloud fraction using a relative humidity threshold - ! The threshold depends upon pressure, and upon the presence or absence - ! of convection as defined by a reasonably large vertical mass flux + ! The threshold depends upon pressure, and upon the presence or absence + ! of convection as defined by a reasonably large vertical mass flux ! entering that layer from below. - ! + ! ! Author: Many. Last modified by Jim McCaa - ! + ! !----------------------------------------------------------------------- use cam_history, only: outfld use physconst, only: cappa, gravit, rair, tmelt use wv_saturation, only: qsat, qsat_water, svp_ice_vect use phys_grid, only: get_rlat_all_p, get_rlon_all_p - + !RBN - Need this to write shallow,deep fraction to phys buffer. !PJR - we should probably make seperate modules for determining convective ! clouds and make this one just responsible for relative humidity clouds - + use physics_buffer, only: physics_buffer_desc, pbuf_get_field ! Arguments integer, intent(in) :: lchnk ! chunk identifier integer, intent(in) :: ncol ! number of atmospheric columns integer, intent(in) :: dindex ! 0 or 1 to perturb rh - + type(physics_buffer_desc), pointer :: pbuf(:) real(r8), intent(in) :: pmid(pcols,pver) ! midpoint pressures real(r8), intent(in) :: temp(pcols,pver) ! temperature @@ -307,7 +305,7 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & real(r8), intent(out) :: clc(pcols) ! column convective cloud amount real(r8), intent(out) :: cldst(pcols,pver) ! cloud fraction real(r8), intent(out) :: rhu00(pcols,pver) ! RH threshold for cloud - real(r8), intent(out) :: relhum(pcols,pver) ! RH + real(r8), intent(out) :: relhum(pcols,pver) ! RH real(r8), intent(out) :: icecldf(pcols,pver) ! ice cloud fraction real(r8), intent(out) :: liqcldf(pcols,pver) ! liquid cloud fraction (combined into cloud) @@ -376,7 +374,7 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & ! The idea is that the RH limits for condensation are strict only for ! water saturation ! - ! Ice clouds are formed by explicit parameterization of ice nucleation. + ! Ice clouds are formed by explicit parameterization of ice nucleation. ! Closure for ice cloud fraction is done on available cloud ice, such that ! the in-cloud ice content matches an empirical fit ! thus, icecldf = min(cldice/icicval,1) where icicval = f(temp,cldice,numice) @@ -385,17 +383,17 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & ! No dA/dt term for ice? ! ! There are three co-existing cloud types: convective, inversion related low-level - ! stratocumulus, and layered cloud (based on relative humidity). Layered and - ! stratocumulus clouds do not compete with convective cloud for which one creates - ! the most cloud. They contribute collectively to the total grid-box average cloud - ! amount. This is reflected in the way in which the total cloud amount is evaluated + ! stratocumulus, and layered cloud (based on relative humidity). Layered and + ! stratocumulus clouds do not compete with convective cloud for which one creates + ! the most cloud. They contribute collectively to the total grid-box average cloud + ! amount. This is reflected in the way in which the total cloud amount is evaluated ! (a sum as opposed to a logical "or" operation) ! !================================================================================== ! set defaults for rhu00 rhu00(:,:) = 2.0_r8 ! define rh perturbation in order to estimate rhdfda - rhpert = 0.01_r8 + rhpert = 0.01_r8 !set Wang and Sassen IWC paramters a=26.87_r8 @@ -460,7 +458,7 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & ! ! Estimate of local convective cloud cover based on convective mass flux - ! Modify local large-scale relative humidity to account for presence of + ! Modify local large-scale relative humidity to account for presence of ! convective cloud when evaluating relative humidity based layered cloud amount ! concld(:ncol,top_lev:pver) = 0.0_r8 @@ -468,7 +466,7 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & ! cloud mass flux in SI units of kg/m2/s; should produce typical numbers of 20% ! shallow and deep convective cloudiness are evaluated separately (since processes ! are evaluated separately) and summed - ! + ! #ifndef PERGRO do k=top_lev,pver do i=1,ncol @@ -488,7 +486,7 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & ! ****** Compute layer cloudiness ****** ! !==================================================================== - ! Begin the evaluation of layered cloud amount based on (modified) RH + ! Begin the evaluation of layered cloud amount based on (modified) RH !==================================================================== ! numkcld = pver @@ -517,7 +515,7 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & ! SJV: decrease cloud amount if very low water vapor content ! (thus very cold): "freeze dry" if (cldfrc_freeze_dry) then - rhcloud(i,k) = rhcloud(i,k)*max(0.15_r8,min(1.0_r8,q(i,k)/0.0030_r8)) + rhcloud(i,k) = rhcloud(i,k)*max(0.15_r8,min(1.0_r8,q(i,k)/0.0030_r8)) endif else if ( pmid(i,k).lt.premit ) then @@ -537,7 +535,7 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & ! linear rh threshold transition between thresholds for low & high cloud ! rhwght = (premib-(max(pmid(i,k),premit)))/(premib-premit) - + if (land(i) .and. (snowh(i) <= 0.000001_r8)) then rhlim = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) else @@ -591,7 +589,7 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & !--------ICE CLOUD OPTION 3--------Wood & Field 2000 (JAS) ! eq 6: cloud fraction = 1 - exp (-K * qc/qsati) - + icecldf(i,k)=1._r8 - exp(-Kc*cldice(i,k)/(qs(i,k)*(esi(i,k)/esl(i,k)))) icecldf(i,k)=max(0._r8,min(icecldf(i,k),1._r8)) else @@ -634,7 +632,7 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & cloud(i,k) = rhcloud(i,k) end if end do - end do + end do ! ! Add in the marine strat ! MARINE STRATUS SHOULD BE A SPECIAL CASE OF LAYERED CLOUD @@ -644,20 +642,20 @@ subroutine cldfrc(lchnk ,ncol , pbuf, & !=================================================================================== ! ! SOME OBSERVATIONS ABOUT THE FOLLOWING SECTION OF CODE (missed in earlier look) - ! K700 IS SET AS A CONSTANT BASED ON HYBRID COORDINATE: IT DOES NOT DEPEND ON - ! LOCAL PRESSURE; THERE IS NO PRESSURE RAMP => LOOKS LEVEL DEPENDENT AND + ! K700 IS SET AS A CONSTANT BASED ON HYBRID COORDINATE: IT DOES NOT DEPEND ON + ! LOCAL PRESSURE; THERE IS NO PRESSURE RAMP => LOOKS LEVEL DEPENDENT AND ! DISCONTINUOUS IN SPACE (I.E., STRATUS WILL END SUDDENLY WITH NO TRANSITION) ! ! IT APPEARS THAT STRAT IS EVALUATED ACCORDING TO KLEIN AND HARTMANN; HOWEVER, ! THE ACTUAL STRATUS AMOUNT (CLDST) APPEARS TO DEPEND DIRECTLY ON THE RH BELOW - ! THE STRONGEST PART OF THE LOW LEVEL INVERSION. + ! THE STRONGEST PART OF THE LOW LEVEL INVERSION. !PJR answers: 1) the rh limitation is a physical/mathematical limitation ! cant have more cloud than there is RH ! allowed the cloud to exist two layers below the inversion ! because the numerics frequently make 50% relative humidity ! in level below the inversion which would allow no cloud ! 2) since the cloud is only allowed over ocean, it should - ! be very insensitive to surface pressure (except due to + ! be very insensitive to surface pressure (except due to ! spectral ringing, which also causes so many other problems ! I didnt worry about it. ! @@ -738,77 +736,4 @@ end subroutine cldfrc !================================================================================================ - subroutine cldfrc_fice(ncol, t, fice, fsnow) -! -! Compute the fraction of the total cloud water which is in ice phase. -! The fraction depends on temperature only. -! This is the form that was used for radiation, the code came from cldefr originally -! -! Author: B. A. Boville Sept 10, 2002 -! modified: PJR 3/13/03 (added fsnow to ascribe snow production for convection ) -!----------------------------------------------------------------------- - use physconst, only: tmelt - -! Arguments - integer, intent(in) :: ncol ! number of active columns - real(r8), intent(in) :: t(:,:) ! temperature - - real(r8), intent(out) :: fice(:,:) ! Fractional ice content within cloud - real(r8), intent(out) :: fsnow(:,:) ! Fractional snow content for convection - -! Local variables - real(r8) :: tmax_fice ! max temperature for cloud ice formation - real(r8) :: tmin_fice ! min temperature for cloud ice formation - real(r8) :: tmax_fsnow ! max temperature for transition to convective snow - real(r8) :: tmin_fsnow ! min temperature for transition to convective snow - - integer :: i,k ! loop indexes - -!----------------------------------------------------------------------- - - tmax_fice = tmelt - 10._r8 ! max temperature for cloud ice formation - tmin_fice = tmax_fice - 30._r8 ! min temperature for cloud ice formation - tmax_fsnow = tmelt ! max temperature for transition to convective snow - tmin_fsnow = tmelt - 5._r8 ! min temperature for transition to convective snow - - fice(:,:top_lev-1) = 0._r8 - fsnow(:,:top_lev-1) = 0._r8 - -! Define fractional amount of cloud that is ice - do k=top_lev,pver - do i=1,ncol - -! If warmer than tmax then water phase - if (t(i,k) > tmax_fice) then - fice(i,k) = 0.0_r8 - -! If colder than tmin then ice phase - else if (t(i,k) < tmin_fice) then - fice(i,k) = 1.0_r8 - -! Otherwise mixed phase, with ice fraction decreasing linearly from tmin to tmax - else - fice(i,k) =(tmax_fice - t(i,k)) / (tmax_fice - tmin_fice) - end if - -! snow fraction partitioning - -! If warmer than tmax then water phase - if (t(i,k) > tmax_fsnow) then - fsnow(i,k) = 0.0_r8 - -! If colder than tmin then ice phase - else if (t(i,k) < tmin_fsnow) then - fsnow(i,k) = 1.0_r8 - -! Otherwise mixed phase, with ice fraction decreasing linearly from tmin to tmax - else - fsnow(i,k) =(tmax_fsnow - t(i,k)) / (tmax_fsnow - tmin_fsnow) - end if - - end do - end do - - end subroutine cldfrc_fice - end module cloud_fraction diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index a9f25f0256..9bbed56277 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -478,7 +478,6 @@ module clubb_intr 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. @@ -2525,7 +2524,6 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! 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. @@ -2869,10 +2867,14 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & !$acc rrho, prer_evap, rtp2_mc_zt, thlp2_mc_zt, wprtp_mc_zt, wpthlp_mc_zt, rtpthlp_mc_zt ) & !$acc copy( um, vm, upwp, vpwp, wpthvp, wp2thvp, rtpthvp, thlpthvp, up2, vp2, up3, vp3, & !$acc wp2, wp3, rtp2, thlp2, rtp3, thlp3, thlm, rtm, rvm, wprtp, wpthlp, rtpthlp, & + !$acc pdf_zm_w_1, pdf_zm_w_2, pdf_zm_varnce_w_1, pdf_zm_varnce_w_2, pdf_zm_mixt_frac, & !$acc cloud_frac, wp2rtp, wp2thlp, uprcp, vprcp, rc_coef, wp4, wpup2, wpvp2, & !$acc ttend_clubb_mc, upwp_clubb_gw_mc, vpwp_clubb_gw_mc, thlp2_clubb_gw_mc, wpthlp_clubb_gw_mc, & !$acc ttend_clubb, upwp_clubb_gw, vpwp_clubb_gw, thlp2_clubb_gw, wpthlp_clubb_gw, & - !$acc wp2up2, wp2vp2, ice_supersat_frac ) & + !$acc wp2up2, wp2vp2, ice_supersat_frac, & + !$acc pdf_params_zm_chnk(lchnk)%w_1, pdf_params_zm_chnk(lchnk)%w_2, & + !$acc pdf_params_zm_chnk(lchnk)%varnce_w_1, pdf_params_zm_chnk(lchnk)%varnce_w_2, & + !$acc pdf_params_zm_chnk(lchnk)%mixt_frac ) & !$acc copyout( temp2d, temp2dp, rtp2_zt_out, thl2_zt_out, wp2_zt_out, pdfp_rtp2, wm_zt_out, inv_exner_clubb, & !$acc rcm, wprcp, rcm_in_layer, cloud_cover, zt_out, zi_out, khzm, qclvar, thv, dz_g, & !$acc clubbtop, se_dis, eleak, clubb_s, wpthvp_clubb, wprcp_clubb ) & @@ -2893,7 +2895,6 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & !$acc radf, wpthlp_sfc, clubb_params, sfc_elevation, wprtp_sfc, upwp_sfc, vpwp_sfc, & !$acc rtm_ref, thlm_ref, um_ref, vm_ref, ug, vg, p_in_Pa, exner, um_pert_inout, & !$acc inv_exner_clubb_surf, thlprcp_out, zi_g, zt_g, qrl_clubb, & - !$acc pdf_zm_w_1, pdf_zm_w_2, pdf_zm_varnce_w_1, pdf_zm_varnce_w_2, pdf_zm_mixt_frac, & !$acc pdf_params_chnk(lchnk)%w_1, pdf_params_chnk(lchnk)%w_2, & !$acc pdf_params_chnk(lchnk)%varnce_w_1, pdf_params_chnk(lchnk)%varnce_w_2, & !$acc pdf_params_chnk(lchnk)%rt_1, pdf_params_chnk(lchnk)%rt_2, & @@ -2917,8 +2918,6 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & !$acc pdf_params_chnk(lchnk)%cloud_frac_1, pdf_params_chnk(lchnk)%cloud_frac_2, & !$acc pdf_params_chnk(lchnk)%mixt_frac, pdf_params_chnk(lchnk)%ice_supersat_frac_1, & !$acc pdf_params_chnk(lchnk)%ice_supersat_frac_2, & - !$acc pdf_params_zm_chnk(lchnk)%w_1, pdf_params_zm_chnk(lchnk)%w_2, & - !$acc pdf_params_zm_chnk(lchnk)%varnce_w_1, pdf_params_zm_chnk(lchnk)%varnce_w_2, & !$acc pdf_params_zm_chnk(lchnk)%rt_1, pdf_params_zm_chnk(lchnk)%rt_2, & !$acc pdf_params_zm_chnk(lchnk)%varnce_rt_1, pdf_params_zm_chnk(lchnk)%varnce_rt_2, & !$acc pdf_params_zm_chnk(lchnk)%thl_1, pdf_params_zm_chnk(lchnk)%thl_2, & @@ -2938,8 +2937,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & !$acc pdf_params_zm_chnk(lchnk)%corr_chi_eta_2, pdf_params_zm_chnk(lchnk)%rsatl_1, & !$acc pdf_params_zm_chnk(lchnk)%rsatl_2, pdf_params_zm_chnk(lchnk)%rc_1, pdf_params_zm_chnk(lchnk)%rc_2, & !$acc pdf_params_zm_chnk(lchnk)%cloud_frac_1, pdf_params_zm_chnk(lchnk)%cloud_frac_2, & - !$acc pdf_params_zm_chnk(lchnk)%mixt_frac, pdf_params_zm_chnk(lchnk)%ice_supersat_frac_1, & - !$acc pdf_params_zm_chnk(lchnk)%ice_supersat_frac_2 ) + !$acc pdf_params_zm_chnk(lchnk)%ice_supersat_frac_1, pdf_params_zm_chnk(lchnk)%ice_supersat_frac_2 ) !$acc data if( sclr_dim > 0 ) & !$acc create( wpsclrp_sfc, sclrm_forcing, sclrm, wpsclrp, sclrp2, sclrp3, sclrprtp, sclrpthlp, sclrpthvp_inout) & @@ -4700,8 +4698,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! --------------------------------------------------------------------------------- ! do i=1,ncol do k=1,pver - !use local exner since state%exner is not a proper exner - th(i,k) = state1%t(i,k)*inv_exner_clubb(i,k) + !subroutine pblind expects "Stull" definition of Exner + th(i,k) = state1%t(i,k)*state1%exner(i,k) !thv should have condensate loading to be consistent with earlier def's in this module thv(i,k) = th(i,k)*(1.0_r8+zvir*state1%q(i,k,ixq) - state1%q(i,k,ixcldliq)) enddo diff --git a/src/physics/cam/conv_water.F90 b/src/physics/cam/conv_water.F90 index d848895366..fb054c87b1 100644 --- a/src/physics/cam/conv_water.F90 +++ b/src/physics/cam/conv_water.F90 @@ -334,7 +334,7 @@ subroutine conv_water_4rad(state, pbuf) ! Select radiation constants (effective radii) for emissivity averaging. - if( microp_scheme == 'RK' .or. microp_scheme == 'SPCAM_sam1mom') then + if( microp_scheme == 'RK') then kabsi = 0.005_r8 + 1._r8/rei(i,k) else kabsi = 0.005_r8 + 1._r8/min(max(13._r8,rei(i,k)),130._r8) diff --git a/src/physics/cam/convect_deep.F90 b/src/physics/cam/convect_deep.F90 index ebba3ba9fa..2262d8f25c 100644 --- a/src/physics/cam/convect_deep.F90 +++ b/src/physics/cam/convect_deep.F90 @@ -140,9 +140,6 @@ subroutine convect_deep_init(pref_edge) call zm_conv_init(pref_edge) case('UNICON') if (masterproc) write(iulog,*)'convect_deep: deep convection done by UNICON' - case('SPCAM') - if (masterproc) write(iulog,*)'convect_deep: deep convection done by SPCAM' - return case default if (masterproc) write(iulog,*)'WARNING: convect_deep: no deep convection scheme. May fail.' end select diff --git a/src/physics/cam/convect_shallow.F90 b/src/physics/cam/convect_shallow.F90 index 902187eb24..9edd28c696 100644 --- a/src/physics/cam/convect_shallow.F90 +++ b/src/physics/cam/convect_shallow.F90 @@ -14,10 +14,12 @@ module convect_shallow use physconst, only : cpair, zvir use ppgrid, only : pver, pcols, pverp use zm_conv_evap, only : zm_conv_evap_run - use zm_conv_intr, only : zmconv_ke, zmconv_ke_lnd, zmconv_org + use zm_conv_intr, only : zmconv_ke, zmconv_ke_lnd use cam_history, only : outfld, addfld, horiz_only use cam_logfile, only : iulog use phys_control, only : phys_getopts + use cloud_fraction_fice, only: cloud_fraction_fice_run + use ref_pres, only: trop_cloud_top_lev implicit none private @@ -88,9 +90,6 @@ subroutine convect_shallow_register call phys_getopts( shallow_scheme_out = shallow_scheme, microp_scheme_out = microp_scheme) - ! SPCAM registers its own fields - if (shallow_scheme == 'SPCAM') return - call pbuf_add_field('ICWMRSH', 'physpkg' ,dtype_r8,(/pcols,pver/), icwmrsh_idx ) call pbuf_add_field('RPRDSH', 'physpkg' ,dtype_r8,(/pcols,pver/), rprdsh_idx ) call pbuf_add_field('RPRDTOT', 'physpkg' ,dtype_r8,(/pcols,pver/), rprdtot_idx ) @@ -165,9 +164,6 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) integer k character(len=16) :: eddy_scheme - ! SPCAM does its own convection - if (shallow_scheme == 'SPCAM') return - ! ------------------------------------------------- ! ! Variables for detailed abalysis of UW-ShCu scheme ! ! ------------------------------------------------- ! @@ -473,10 +469,21 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & real(r8), pointer, dimension(:,:) :: cmfmc2 ! (pcols,pverp) Updraft mass flux by shallow convection [ kg/s/m2 ] real(r8), pointer, dimension(:,:) :: sh_e_ed_ratio ! (pcols,pver) fer/(fer+fdr) from uwschu + real(r8), dimension(pcols,pver) :: fsnow_conv + real(r8), dimension(pcols,pver) :: fice + logical :: lq(pcnst) type(unicon_out_t) :: unicon_out + character(len=40) :: scheme_name + character(len=16) :: macrop_scheme + character(len=512):: errmsg + integer :: errflg + integer :: top_lev + + + ! ----------------------- ! ! Main Computation Begins ! ! ----------------------- ! @@ -872,16 +879,25 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & tend_s_snwprd(:,:) = 0._r8 tend_s_snwevmlt(:,:) = 0._r8 snow(:) = 0._r8 + fice(:,:) = 0._r8 + fsnow_conv(:,:) = 0._r8 !REMOVECAM_END + top_lev = 1 + call phys_getopts (macrop_scheme_out = macrop_scheme) + if ( .not. (macrop_scheme == "rk" .or. macrop_scheme == "SPCAM_sam1mom")) top_lev = trop_cloud_top_lev + + call cloud_fraction_fice_run(ncol, state1%t(1:ncol,:), tmelt, top_lev, pver, fice(1:ncol,:), fsnow_conv(1:ncol,:)) + call zm_conv_evap_run(state1%ncol, pver, pverp, & gravit, latice, latvap, tmelt, & - cpair, zmconv_ke, zmconv_ke_lnd, zmconv_org, & + cpair, zmconv_ke, zmconv_ke_lnd, & state1%t(:ncol,:),state1%pmid(:ncol,:),state1%pdel(:ncol,:),state1%q(:ncol,:pver,1), & landfracdum(:ncol), & ptend_loc%s(:ncol,:), tend_s_snwprd(:ncol,:), tend_s_snwevmlt(:ncol,:), ptend_loc%q(:ncol,:pver,1), & rprdsh(:ncol,:), cld(:ncol,:), ztodt, & - precc(:ncol), snow(:ncol), ntprprd(:ncol,:), ntsnprd(:ncol,:), flxprec(:ncol,:), flxsnow(:ncol,:) ) + precc(:ncol), snow(:ncol), ntprprd(:ncol,:), ntsnprd(:ncol,:), fsnow_conv(:ncol,:), flxprec(:ncol,:), flxsnow(:ncol,:),& + scheme_name, errmsg, errflg) ! ---------------------------------------------- ! ! record history variables from zm_conv_evap_run ! diff --git a/src/physics/cam/diffusion_solver.F90 b/src/physics/cam/diffusion_solver.F90 index 94fc4bc395..2a715596ea 100644 --- a/src/physics/cam/diffusion_solver.F90 +++ b/src/physics/cam/diffusion_solver.F90 @@ -368,8 +368,6 @@ end function vd_lu_qdecomp ! Combined molecular and eddy diffusion. real(r8) :: kv_total(pcols,pver+1) - logical :: use_spcam - !-------------------------------- ! Variables needed for WACCM-X !-------------------------------- @@ -389,8 +387,6 @@ end function vd_lu_qdecomp ! Main Computation Begins ! ! ----------------------- ! - call phys_getopts(use_spcam_out = use_spcam) - errstring = '' if( ( diffuse(fieldlist,'u') .or. diffuse(fieldlist,'v') ) .and. .not. diffuse(fieldlist,'s') ) then errstring = 'diffusion_solver.compute_vdiff: must diffuse s if diffusing u or v' @@ -719,16 +715,14 @@ end function vd_lu_qdecomp ! moist static energy,not the dry static energy. if( diffuse(fieldlist,'s') ) then - if (.not. use_spcam) then ! Add counter-gradient to input static energy profiles + do k = 1, pver + dse(:ncol,k) = dse(:ncol,k) + ztodt * p%rdel(:,k) * gravit * & + ( rhoi(:ncol,k+1) * kvh(:ncol,k+1) * cgh(:ncol,k+1) & + - rhoi(:ncol,k ) * kvh(:ncol,k ) * cgh(:ncol,k ) ) + end do - do k = 1, pver - dse(:ncol,k) = dse(:ncol,k) + ztodt * p%rdel(:,k) * gravit * & - ( rhoi(:ncol,k+1) * kvh(:ncol,k+1) * cgh(:ncol,k+1) & - - rhoi(:ncol,k ) * kvh(:ncol,k ) * cgh(:ncol,k ) ) - end do - endif ! Add the explicit surface fluxes to the lowest layer dse(:ncol,pver) = dse(:ncol,pver) + tmp1(:ncol) * shflx(:ncol) @@ -746,12 +740,10 @@ end function vd_lu_qdecomp ! Boundary layer thickness of "0._r8" signifies that the boundary ! condition is defined directly on the top interface. - if (.not. use_spcam) then - dse(:ncol,:) = fin_vol_solve(ztodt, p, dse(:ncol,:), ncol, pver, & - coef_q_diff=kvh(:ncol,:)*dpidz_sq, & - upper_bndry=interface_boundary, & - l_cond=BoundaryData(dse_top(:ncol))) - endif + dse(:ncol,:) = fin_vol_solve(ztodt, p, dse(:ncol,:), ncol, pver, & + coef_q_diff=kvh(:ncol,:)*dpidz_sq, & + upper_bndry=interface_boundary, & + l_cond=BoundaryData(dse_top(:ncol))) ! Calculate flux at top interface @@ -764,11 +756,9 @@ end function vd_lu_qdecomp ttemp = ttemp0 ! upper boundary is zero flux for extended model - if (.not. use_spcam) then - ttemp = fin_vol_solve(ztodt, p, ttemp, ncol, pver, & - coef_q_diff=kvt(:ncol,:)*dpidz_sq, & - coef_q_weight=cpairv(:ncol,:)) - end if + ttemp = fin_vol_solve(ztodt, p, ttemp, ncol, pver, & + coef_q_diff=kvt(:ncol,:)*dpidz_sq, & + coef_q_weight=cpairv(:ncol,:)) !------------------------------------- @@ -789,12 +779,10 @@ end function vd_lu_qdecomp ! Boundary layer thickness of "0._r8" signifies that the boundary ! condition is defined directly on the top interface. - if (.not. use_spcam) then - dse(:ncol,:) = fin_vol_solve(ztodt, p, dse(:ncol,:), ncol, pver, & - coef_q_diff=kv_total(:ncol,:)*dpidz_sq, & - upper_bndry=interface_boundary, & - l_cond=BoundaryData(dse_top(:ncol))) - end if + dse(:ncol,:) = fin_vol_solve(ztodt, p, dse(:ncol,:), ncol, pver, & + coef_q_diff=kv_total(:ncol,:)*dpidz_sq, & + upper_bndry=interface_boundary, & + l_cond=BoundaryData(dse_top(:ncol))) ! Calculate flux at top interface @@ -826,27 +814,25 @@ end function vd_lu_qdecomp do m = 1, ncnst if( diffuse(fieldlist,'q',m) ) then - if (.not. use_spcam) then - ! Add the nonlocal transport terms to constituents in the PBL. - ! Check for neg q's in each constituent and put the original vertical - ! profile back if a neg value is found. A neg value implies that the - ! quasi-equilibrium conditions assumed for the countergradient term are - ! strongly violated. + ! Add the nonlocal transport terms to constituents in the PBL. + ! Check for neg q's in each constituent and put the original vertical + ! profile back if a neg value is found. A neg value implies that the + ! quasi-equilibrium conditions assumed for the countergradient term are + ! strongly violated. - qtm(:ncol,:pver) = q(:ncol,:pver,m) + qtm(:ncol,:pver) = q(:ncol,:pver,m) - do k = 1, pver - q(:ncol,k,m) = q(:ncol,k,m) + & - ztodt * p%rdel(:,k) * gravit * ( cflx(:ncol,m) * rrho(:ncol) ) * & - ( rhoi(:ncol,k+1) * kvh(:ncol,k+1) * cgs(:ncol,k+1) & - - rhoi(:ncol,k ) * kvh(:ncol,k ) * cgs(:ncol,k ) ) - end do - lqtst(:ncol) = all(q(:ncol,1:pver,m) >= qmincg(m), 2) - do k = 1, pver - q(:ncol,k,m) = merge( q(:ncol,k,m), qtm(:ncol,k), lqtst(:ncol) ) - end do - endif + do k = 1, pver + q(:ncol,k,m) = q(:ncol,k,m) + & + ztodt * p%rdel(:,k) * gravit * ( cflx(:ncol,m) * rrho(:ncol) ) * & + ( rhoi(:ncol,k+1) * kvh(:ncol,k+1) * cgs(:ncol,k+1) & + - rhoi(:ncol,k ) * kvh(:ncol,k ) * cgs(:ncol,k ) ) + end do + lqtst(:ncol) = all(q(:ncol,1:pver,m) >= qmincg(m), 2) + do k = 1, pver + q(:ncol,k,m) = merge( q(:ncol,k,m), qtm(:ncol,k), lqtst(:ncol) ) + end do ! Add the explicit surface fluxes to the lowest layer @@ -894,9 +880,7 @@ end function vd_lu_qdecomp endif end if - if (.not. use_spcam) then - call no_molec_decomp%left_div(q(:ncol,:,m)) - end if + call no_molec_decomp%left_div(q(:ncol,:,m)) end if diff --git a/src/physics/cam/gw_common.F90 b/src/physics/cam/gw_common.F90 index 04014c8c97..a9897cb140 100644 --- a/src/physics/cam/gw_common.F90 +++ b/src/physics/cam/gw_common.F90 @@ -132,7 +132,9 @@ function new_GWBand(ngwv, dc, fcrit2, wavelength) result(band) ! Simple assignments. band%ngwv = ngwv band%dc = dc - band%fcrit2 = fcrit2 + + ! For now just ensure fcrit is always set to 1 + band%fcrit2 = 1.0_r8 ! fcrit2 ! Uniform phase speed reference grid. allocate(band%cref(-ngwv:ngwv)) @@ -147,7 +149,7 @@ end function new_GWBand !========================================================================== subroutine gw_common_init(pver_in, & - tau_0_ubc_in, ktop_in, gravit_in, rair_in, alpha_in, & + tau_0_ubc_in, ktop_in, gravit_in, rair_in, alpha_in, & prndl_in, qbo_hdepth_scaling_in, errstring) integer, intent(in) :: pver_in @@ -356,8 +358,8 @@ subroutine gw_drag_prof(ncol, band, p, src_level, tend_level, dt, & real(r8), intent(in), optional :: & kwvrdg(ncol) - ! Factor for saturation calculation. Here backwards - ! compatibility. I believe it should be 1.0 (jtb). + ! Factor for saturation calculation. Here backwards + ! compatibility. I believe it should be 1.0 (jtb). ! Looks like it has been 2.0 for a while in CAM. real(r8), intent(in), optional :: & satfac_in @@ -425,7 +427,7 @@ subroutine gw_drag_prof(ncol, band, p, src_level, tend_level, dt, & lapply_effgw = .TRUE. endif - + ! Lowest levels that loops need to iterate over. kbot_tend = maxval(tend_level) kbot_src = maxval(src_level) @@ -457,9 +459,9 @@ subroutine gw_drag_prof(ncol, band, p, src_level, tend_level, dt, & !------------------------------------------------------------------------ ! Loop from bottom to top to get stress profiles. - ! do k = kbot_src-1, ktop, -1 !++jtb I think this is right - do k = kbot_src, ktop, -1 !++ but this is in model now - + ! do k = kbot_src-1, ktop, -1 !++jtb I think this is right + do k = kbot_src, ktop, -1 !++ but this is in model now + ! Determine the diffusivity for each column. d = dback + kvtt(:,k) @@ -552,8 +554,8 @@ subroutine gw_drag_prof(ncol, band, p, src_level, tend_level, dt, & ! Write out pre-adjustment tau profile for diagnostc purposes. ! Current implementation only makes sense for orographic waves. - ! Fix later. - if (PRESENT(tau_diag)) then + ! Fix later. + if (PRESENT(tau_diag)) then tau_diag(:,:) = tau(:,0,:) end if @@ -592,11 +594,11 @@ subroutine gw_drag_prof(ncol, band, p, src_level, tend_level, dt, & ubtl = min(ubtl, umcfac * abs(c(:,l)-ubm(:,k)) / dt) if (.not. lapply_effgw) ubtl = min(ubtl, tndmax) - + where (k <= tend_level) ! Save tendency for each wave (for later computation of kzz). - ! sign function returns magnitude of ubtl with sign of c-ubm + ! sign function returns magnitude of ubtl with sign of c-ubm ! Renders ubt/ubm check for mountain waves unecessary gwut(:,k,l) = sign(ubtl, c(:,l)-ubm(:,k)) ubt(:,k) = ubt(:,k) + gwut(:,k,l) @@ -620,7 +622,7 @@ subroutine gw_drag_prof(ncol, band, p, src_level, tend_level, dt, & else ubt_lim_ratio = 1._r8 end if - + do l = -band%ngwv, band%ngwv gwut(:,k,l) = ubt_lim_ratio*gwut(:,k,l) ! Redetermine the effective stress on the interface below from the @@ -634,11 +636,11 @@ subroutine gw_drag_prof(ncol, band, p, src_level, tend_level, dt, & !-------------------------------------------------- where( abs(gwut(:,k,l)) < 1.e-15_r8 ) gwut(:,k,l) = 0._r8 - endwhere + endwhere where (k <= tend_level) - tau(:,l,k+1) = tau(:,l,k) + & - abs(gwut(:,k,l)) * p%del(:,k) / gravit + tau(:,l,k+1) = tau(:,l,k) + & + abs(gwut(:,k,l)) * p%del(:,k) / gravit end where end do @@ -866,7 +868,7 @@ subroutine momentum_fixer(tend_level, p, um_flux, vm_flux, utgw, vtgw) vtgw(:,k) = vtgw(:,k) + dv end where end do - + end subroutine momentum_fixer !========================================================================== diff --git a/src/physics/cam/gw_convect.F90 b/src/physics/cam/gw_convect.F90 index 09ca64a016..311865b499 100644 --- a/src/physics/cam/gw_convect.F90 +++ b/src/physics/cam/gw_convect.F90 @@ -161,7 +161,7 @@ subroutine gw_beres_src(ncol, band, desc, u, v, & do k = pver, 1, -1 do i = 1, ncol if (boti(i) == 0) then - ! Detect if we are outside the maximum range (where z = 20 km). + ! Detect if we are outside the top of range (where z = 20 km). if (zm(i,k) >= 20000._r8) then boti(i) = k topi(i) = k @@ -169,17 +169,20 @@ subroutine gw_beres_src(ncol, band, desc, u, v, & ! First spot where heating rate is positive. if (netdt(i,k) > 0.0_r8) boti(i) = k end if - else if (topi(i) == 0) then - ! Detect if we are outside the maximum range (z = 20 km). - if (zm(i,k) >= 20000._r8) then - topi(i) = k - else - ! First spot where heating rate is no longer positive. - if (.not. (netdt(i,k) > 0.0_r8)) topi(i) = k - end if end if end do - ! When all done, exit. + ! When all done, exit + if (all(boti /= 0)) exit + end do + + do k = 1, pver + do i = 1, ncol + if (topi(i) == 0) then + ! First spot where heating rate is positive. + if ((netdt(i,k) > 0.0_r8) .AND. (zm(i,k) <= 20000._r8)) topi(i) = k-1 + end if + end do + ! When all done, exit if (all(topi /= 0)) exit end do @@ -283,7 +286,7 @@ subroutine gw_beres_src(ncol, band, desc, u, v, & ! Adjust for critical level filtering. tau0(Umini(i):Umaxi(i)) = 0.0_r8 - + tau(i,:,topi(i)+1) = tau0 end if ! heating depth above min and not at the pole diff --git a/src/physics/cam/gw_drag.F90 b/src/physics/cam/gw_drag.F90 index 798ad63059..6f2b66f886 100644 --- a/src/physics/cam/gw_drag.F90 +++ b/src/physics/cam/gw_drag.F90 @@ -109,6 +109,18 @@ module gw_drag real(r8) :: effgw_beres_dp = unset_r8 ! Beres (shallow convection). real(r8) :: effgw_beres_sh = unset_r8 + ! PBL moving mtn + real(r8) :: effgw_movmtn_pbl = unset_r8 + integer :: movmtn_source = -1 + integer :: movmtn_ksteer = -1 + integer :: movmtn_klaunch = -1 + real(r8) :: movmtn_psteer = unset_r8 + real(r8) :: movmtn_plaunch = unset_r8 + + ! Parameters controlling isotropic residual + ! orographic GW. + logical :: use_gw_rdg_resid = .false. + real(r8) :: effgw_rdg_resid = unset_r8 ! Horzontal wavelengths [m]. real(r8), parameter :: wavelength_mid = 1.e5_r8 @@ -155,6 +167,9 @@ module gw_drag integer :: ttend_sh_idx = -1 integer :: frontgf_idx = -1 integer :: frontga_idx = -1 + + integer :: vort4gw_idx = -1 + integer :: sgh_idx = -1 ! From CLUBB @@ -168,7 +183,9 @@ module gw_drag integer, parameter :: prdg = 16 real(r8), allocatable, dimension(:,:), target :: & - rdg_gbxar + rdg_gbxar, & + rdg_isovar, & + rdg_isowgt ! Meso Beta real(r8), allocatable, dimension(:,:,:), target :: & @@ -245,7 +262,10 @@ subroutine gw_drag_readnl(nlfile) rdg_gamma_cd_llb, trpd_leewv_rdg_gamma, bnd_rdggm, & gw_oro_south_fac, gw_limit_tau_without_eff, & gw_lndscl_sgh, gw_prndl, gw_apply_tndmax, gw_qbo_hdepth_scaling, & - gw_top_taper, front_gaussian_width, alpha_gw_movmtn + gw_top_taper, front_gaussian_width, alpha_gw_movmtn, use_gw_rdg_resid, & + effgw_rdg_resid, effgw_movmtn_pbl, movmtn_source, movmtn_psteer, & + movmtn_plaunch + !---------------------------------------------------------------------- if (use_simple_phys) return @@ -351,6 +371,20 @@ subroutine gw_drag_readnl(nlfile) call mpi_bcast(alpha_gw_movmtn, 1, mpi_real8, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: alpha_gw_movmtn") + call mpi_bcast(effgw_movmtn_pbl, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: effgw_movmtn_pbl") + call mpi_bcast(movmtn_source, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: movmtn_source") + call mpi_bcast(movmtn_psteer, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: movmtn_psteer") + call mpi_bcast(movmtn_plaunch, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: movmtn_plaunch") + + call mpi_bcast(use_gw_rdg_resid, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_gw_rdg_resid") + call mpi_bcast(effgw_rdg_resid, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: effgw_rdg_resid") + ! Check if pgwv was set. call shr_assert(pgwv >= 0, & @@ -636,6 +670,8 @@ subroutine gw_init() ! Get beta ridge data allocate( & rdg_gbxar(pcols,begchunk:endchunk), & + rdg_isovar(pcols,begchunk:endchunk), & + rdg_isowgt(pcols,begchunk:endchunk), & rdg_hwdth(pcols,prdg,begchunk:endchunk), & rdg_clngt(pcols,prdg,begchunk:endchunk), & rdg_mxdis(pcols,prdg,begchunk:endchunk), & @@ -647,6 +683,18 @@ subroutine gw_init() if (.not. found) call endrun(sub//': ERROR: GBXAR not found on topo file') rdg_gbxar = rdg_gbxar * (rearth/1000._r8)*(rearth/1000._r8) ! transform to km^2 + call infld('ISOVAR', fh_topo, dim1name, dim2name, 1, pcols, & + begchunk, endchunk, rdg_isovar, found, gridname='physgrid') +! if (.not. found) call endrun(sub//': ERROR: ISOVAR not found on topo file') + ! ++jtb - Temporary fix until topo files contain this variable + if (.not. found) rdg_isovar(:,:) = 0._r8 + + call infld('ISOWGT', fh_topo, dim1name, dim2name, 1, pcols, & + begchunk, endchunk, rdg_isowgt, found, gridname='physgrid') +! if (.not. found) call endrun(sub//': ERROR: ISOWGT not found on topo file') + ! ++jtb - Temporary fix until topo files contain this variable + if (.not. found) rdg_isowgt(:,:) = 0._r8 + call infld('HWDTH', fh_topo, dim1name, 'nrdg', dim2name, 1, pcols, & 1, prdg, begchunk, endchunk, rdg_hwdth, found, gridname='physgrid') if (.not. found) call endrun(sub//': ERROR: HWDTH not found on topo file') @@ -722,15 +770,39 @@ subroutine gw_init() call addfld('ZMGW', (/ 'lev' /) , 'A' ,'m' , & 'midlayer geopotential heights in GW code ' ) + + call addfld('NIEGW', (/ 'ilev' /) , 'I' ,'1/s' , & + 'interface BV freq in GW code ' ) + call addfld('NMEGW', (/ 'lev' /) , 'I' ,'1/s' , & + 'midlayer BV freq in GW code ' ) + call addfld('RHOIEGW', (/ 'ilev' /) , 'I' ,'kg/m^3' , & + 'interface density in GW code ' ) + call addfld('PINTEGW', (/ 'ilev' /) , 'I' ,'Pa' , & + 'interface air pressure in GW code ' ) + call addfld('TAUM1_DIAG' , (/ 'ilev' /) , 'I' ,'N m-2' , & 'Ridge based momentum flux profile') call addfld('TAU1RDGBETAM' , (/ 'ilev' /) , 'I' ,'N m-2' , & 'Ridge based momentum flux profile') - call addfld('UBM1BETA', (/ 'lev' /) , 'A' ,'s-1' , & + call addfld('UBM1BETA', (/ 'lev' /) , 'A' ,'m s-1' , & 'On-ridge wind profile ' ) - call addfld('UBT1RDGBETA' , (/ 'lev' /) , 'I' ,'m s-1' , & + call addfld('UBT1RDGBETA' , (/ 'lev' /) , 'I' ,'m s-2' , & 'On-ridge wind tendency from ridge 1 ') + call addfld('TAURESIDBETAM' , (/ 'ilev' /) , 'I' ,'N m-2' , & + 'Ridge based momentum flux profile') + call addfld('UBMRESIDBETA', (/ 'lev' /) , 'I' ,'m s-1' , & + 'On-ridge wind profile ' ) + call addfld('UBIRESIDBETA', (/ 'ilev' /) , 'I' ,'m s-1' , & + 'On-ridge wind profile (interface) ' ) + call addfld('SRC_LEVEL_RESIDBETA', horiz_only , 'I' ,'1' , & + 'src level index for ridge residual ' ) + call addfld('TAUORO_RESID', horiz_only , 'I' ,'N m-2' , & + 'Surface momentum flux from ridge residual ' ) + call addfld('TAUDIAG_RESID' , (/ 'ilev' /) , 'I' ,'N m-2' , & + 'Ridge based momentum flux profile') + + do i = 1, 6 write(cn, '(i1)') i call addfld('TAU'//cn//'RDGBETAY' , (/ 'ilev' /), 'I', 'N m-2', & @@ -751,6 +823,12 @@ subroutine gw_init() 'Ridge based momentum flux profile') call register_vector_field('TAUARDGBETAX','TAUARDGBETAY') + call addfld('TAURESIDBETAY' , (/ 'ilev' /) , 'I' ,'N m-2' , & + 'Ridge based momentum flux profile') + call addfld('TAURESIDBETAX' , (/ 'ilev' /) , 'I' ,'N m-2' , & + 'Ridge based momentum flux profile') + call register_vector_field('TAURESIDBETAX','TAURESIDBETAY') + if (history_waccm) then call add_default('TAUARDGBETAX', 1, ' ') call add_default('TAUARDGBETAY ', 1, ' ') @@ -883,6 +961,29 @@ subroutine gw_init() end if + if (use_gw_movmtn_pbl) then + do k = 1, pver + ! Find steering level + if ( (pref_edge(k+1) >= movmtn_psteer).and.(pref_edge(k) < movmtn_psteer) ) then + movmtn_ksteer = k + end if + end do + do k = 1, pver + ! Find launch level + if ( (pref_edge(k+1) >= movmtn_plaunch).and.(pref_edge(k) < movmtn_plaunch ) ) then + movmtn_klaunch = k + end if + end do + + end if + if (use_gw_movmtn_pbl) then + + vort4gw_idx = pbuf_get_index('VORT4GW') + + call addfld ('VORT4GW', (/ 'lev' /), 'A', 's-1', & + 'Vorticity') + end if + if (use_gw_front) then call shr_assert(all(unset_r8 /= [ effgw_cm, taubgnd ]), & @@ -1451,7 +1552,7 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat) ! Interface for multiple gravity wave drag parameterization. !----------------------------------------------------------------------- - use physics_types, only: physics_state_copy, set_dry_to_wet + use physics_types, only: physics_state_copy use constituents, only: cnst_type use physics_buffer, only: physics_buffer_desc, pbuf_get_field use camsrfexch, only: cam_in_t @@ -1466,7 +1567,7 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat) use gw_front, only: gw_cm_src use gw_convect, only: gw_beres_src use gw_movmtn, only: gw_movmtn_src - + use dycore, only: dycore_is !------------------------------Arguments-------------------------------- type(physics_state), intent(in) :: state ! physics state structure type(physics_buffer_desc), pointer :: pbuf(:) ! Physics buffer @@ -1536,6 +1637,8 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat) ! Frontogenesis real(r8), pointer :: frontgf(:,:) real(r8), pointer :: frontga(:,:) + ! Vorticity source + real(r8), pointer :: vort4gw(:,:) ! Temperature change due to deep convection. real(r8), pointer :: ttend_dp(:,:) @@ -1568,6 +1671,12 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat) real(r8), pointer :: angll(:,:) ! anisotropy of ridges. real(r8), pointer :: anixy(:,:) + ! sqrt(residual variance) not repr by ridges (assumed isotropic). + real(r8), pointer :: isovar(:) + ! area fraction of res variance + real(r8), pointer :: isowgt(:) + + ! Gamma ridges ! width of ridges. @@ -1628,9 +1737,6 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat) ! Make local copy of input state. call physics_state_copy(state, state1) - ! constituents are all treated as wet mmr - call set_dry_to_wet(state1, convert_cnst_type='dry') - lchnk = state1%lchnk ncol = state1%ncol @@ -1718,13 +1824,14 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat) call pbuf_get_field(pbuf, wpthlp_clubb_gw_idx, wpthlp_clubb_gw) call pbuf_get_field(pbuf, upwp_clubb_gw_idx, upwp_clubb_gw) call pbuf_get_field(pbuf, vpwp_clubb_gw_idx, vpwp_clubb_gw) + call pbuf_get_field(pbuf, vort4gw_idx, vort4gw) xpwp_clubb(:ncol,:) = sqrt( upwp_clubb_gw(:ncol,:)**2 + vpwp_clubb_gw(:ncol,:)**2 ) - effgw = 1._r8 + effgw = effgw_movmtn_pbl call gw_movmtn_src(ncol, lchnk, band_movmtn , movmtn_desc, & - u, v, ttend_dp(:ncol,:), ttend_clubb(:ncol,:), xpwp_clubb(:ncol,:) , & - zm, alpha_gw_movmtn, src_level, tend_level, & + u, v, ttend_dp(:ncol,:), ttend_clubb(:ncol,:), xpwp_clubb(:ncol,:), vort4gw(:ncol,:), & + zm, alpha_gw_movmtn, movmtn_source, movmtn_ksteer, movmtn_klaunch, src_level, tend_level, & tau, ubm, ubi, xv, yv, & phase_speeds, hdepth) !------------------------------------------------------------- @@ -1782,6 +1889,7 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat) call outfld('WPTHLP_CLUBB_GW', wpthlp_clubb_gw, pcols, lchnk) call outfld('UPWP_CLUBB_GW', upwp_clubb_gw, pcols, lchnk) call outfld('VPWP_CLUBB_GW', vpwp_clubb_gw, pcols, lchnk) + call outfld ('VORT4GW', vort4gw, pcols, lchnk) !Deallocate variables that are no longer used: deallocate(tau, gwut, phase_speeds) @@ -2259,6 +2367,8 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat) mxdis => rdg_mxdis(:ncol,:,lchnk) angll => rdg_angll(:ncol,:,lchnk) anixy => rdg_anixy(:ncol,:,lchnk) + isovar => rdg_isovar(:ncol,lchnk) + isowgt => rdg_isowgt(:ncol,lchnk) where(mxdis < 0._r8) mxdis = 0._r8 @@ -2277,7 +2387,9 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat) u, v, t, p, piln, zm, zi, & nm, ni, rhoi, kvtt, q, dse, & effgw_rdg_beta, effgw_rdg_beta_max, & + effgw_rdg_resid, use_gw_rdg_resid, & hwdth, clngt, gbxar, mxdis, angll, anixy, & + isovar, isowgt, & rdg_beta_cd_llb, trpd_leewv_rdg_beta, & ptend, flx_heat) @@ -2307,7 +2419,9 @@ subroutine gw_tend(state, pbuf, dt, ptend, cam_in, flx_heat) u, v, t, p, piln, zm, zi, & nm, ni, rhoi, kvtt, q, dse, & effgw_rdg_gamma, effgw_rdg_gamma_max, & + effgw_rdg_resid, use_gw_rdg_resid, & hwdthg, clngtg, gbxar, mxdisg, angllg, anixyg, & + isovar, isowgt, & rdg_gamma_cd_llb, trpd_leewv_rdg_gamma, & ptend, flx_heat) @@ -2347,13 +2461,15 @@ subroutine gw_rdg_calc( & u, v, t, p, piln, zm, zi, & nm, ni, rhoi, kvtt, q, dse, & effgw_rdg, effgw_rdg_max, & + effgw_rdg_resid, luse_gw_rdg_resid, & hwdth, clngt, gbxar, & mxdis, angll, anixy, & + isovar, isowgt, & rdg_cd_llb, trpd_leewv, & ptend, flx_heat) use coords_1d, only: Coords1D - use gw_rdg, only: gw_rdg_src, gw_rdg_belowpeak, gw_rdg_break_trap, gw_rdg_do_vdiff + use gw_rdg, only: gw_rdg_src, gw_rdg_resid_src, gw_rdg_belowpeak, gw_rdg_break_trap, gw_rdg_do_vdiff use gw_common, only: gw_drag_prof, energy_change character(len=5), intent(in) :: type ! BETA or GAMMA @@ -2379,6 +2495,8 @@ subroutine gw_rdg_calc( & real(r8), intent(in) :: effgw_rdg ! Tendency efficiency. real(r8), intent(in) :: effgw_rdg_max + real(r8), intent(in) :: effgw_rdg_resid ! Tendency efficiency. + logical, intent(in) :: luse_gw_rdg_resid ! On-Off switch real(r8), intent(in) :: hwdth(ncol,prdg) ! width of ridges. real(r8), intent(in) :: clngt(ncol,prdg) ! length of ridges. real(r8), intent(in) :: gbxar(ncol) ! gridbox area @@ -2387,6 +2505,9 @@ subroutine gw_rdg_calc( & real(r8), intent(in) :: angll(ncol,prdg) ! orientation of ridges. real(r8), intent(in) :: anixy(ncol,prdg) ! Anisotropy parameter. + real(r8), intent(in) :: isovar(ncol) ! sqrt of residual variance + real(r8), intent(in) :: isowgt(ncol) ! area frac of residual variance + real(r8), intent(in) :: rdg_cd_llb ! Drag coefficient for low-level flow logical, intent(in) :: trpd_leewv @@ -2606,13 +2727,70 @@ subroutine gw_rdg_calc( & end do ! end of loop over multiple ridges + call outfld('TAUARDG'//trim(type)//'X', taurx, ncol, lchnk) + call outfld('TAUARDG'//trim(type)//'Y', taury, ncol, lchnk) + + if (luse_gw_rdg_resid) then + ! Add additional GW from residual variance. Assumed isotropic + kwvrdg = 0.001_r8 / ( 100._r8 ) + effgw = effgw_rdg_resid * isowgt + tauoro = 0._r8 + + call gw_rdg_resid_src(ncol, band_oro, p, & + u, v, t, isovar, kwvrdg, zi, nm, & + src_level, tend_level, tau, ubm, ubi, xv, yv, & + ubmsrc, usrc, vsrc, nsrc, rsrc, m2src, phase_speeds, tauoro ) + + call gw_drag_prof(ncol, band_oro, p, src_level, tend_level, dt, & + t, vramp, & + piln, rhoi, nm, ni, ubm, ubi, xv, yv, & + effgw, phase_speeds, kvtt, q, dse, tau, utgw, vtgw, & + ttgw, qtgw, egwdffi, gwut, dttdf, dttke, & + kwvrdg=kwvrdg, & + satfac_in = 1._r8, lapply_vdiff=gw_rdg_do_vdiff , tau_diag=tau_diag ) + + ! Add the tendencies from isotropic residual to the totals. + do k = 1, pver + ! diagnostics + utrdg(:,k) = utrdg(:,k) + utgw(:,k) + vtrdg(:,k) = vtrdg(:,k) + vtgw(:,k) + ttrdg(:,k) = ttrdg(:,k) + ttgw(:,k) + ! physics tendencies + ptend%u(:ncol,k) = ptend%u(:ncol,k) + utgw(:,k) + ptend%v(:ncol,k) = ptend%v(:ncol,k) + vtgw(:,k) + ptend%s(:ncol,k) = ptend%s(:ncol,k) + ttgw(:,k) + end do + + do m = 1, pcnst + do k = 1, pver + ptend%q(:ncol,k,m) = ptend%q(:ncol,k,m) + qtgw(:,k,m) + end do + end do + + do k = 1, pver+1 + taurx0(:,k) = tau(:,0,k)*xv + taury0(:,k) = tau(:,0,k)*yv + taurx(:,k) = taurx(:,k) + taurx0(:,k) + taury(:,k) = taury(:,k) + taury0(:,k) + end do + + call outfld('TAUDIAG_RESID', tau_diag, ncol, lchnk) + call outfld('TAUORO_RESID', tauoro , ncol, lchnk) + call outfld('TAURESID'//trim(type)//'M', tau(:,0,:), ncol, lchnk) + call outfld('TAURESID'//trim(type)//'X', taurx, ncol, lchnk) + call outfld('TAURESID'//trim(type)//'Y', taury, ncol, lchnk) + + call outfld('UBMRESID'//trim(type), ubm, ncol, lchnk) + call outfld('UBIRESID'//trim(type), ubi, ncol, lchnk) + call outfld('SRC_LEVEL_RESID'//trim(type), real(src_level, r8) , ncol, lchnk) + ! end of residual variance calc + end if + ! Calculate energy change for output to CAM's energy checker. call energy_change(dt, p, u, v, ptend%u(:ncol,:), & ptend%v(:ncol,:), ptend%s(:ncol,:), de) flx_heat(:ncol) = de - call outfld('TAUARDG'//trim(type)//'X', taurx, ncol, lchnk) - call outfld('TAUARDG'//trim(type)//'Y', taury, ncol, lchnk) if (trim(type) == 'BETA') then fname(1) = 'TAUGWX' diff --git a/src/physics/cam/gw_movmtn.F90 b/src/physics/cam/gw_movmtn.F90 index 0408928932..142b833eaa 100644 --- a/src/physics/cam/gw_movmtn.F90 +++ b/src/physics/cam/gw_movmtn.F90 @@ -2,7 +2,7 @@ module gw_movmtn ! ! This module parameterizes gravity waves generated by the obstacle effect produced by -! boundary layer turbulence for convection. +! internal circulations in the atmosphere. ! use gw_utils, only: r8 @@ -35,12 +35,13 @@ module gw_movmtn !========================================================================== subroutine gw_movmtn_src(ncol,lchnk, band, desc, u, v, & - netdt, netdt_shcu, xpwp_shcu, & - zm, alpha_gw_movmtn, src_level, tend_level, tau, ubm, ubi, xv, yv, & + netdt, netdt_shcu, xpwp_shcu, vorticity, & + zm, alpha_gw_movmtn, movmtn_source, ksteer_in, klaunch_in, & + src_level, tend_level, tau, ubm, ubi, xv, yv, & c, hdepth) !----------------------------------------------------------------------- ! Flexible driver for gravity wave source from obstacle effects produced -! by boundary layer turbulence or deep convection +! by internal circulations !----------------------------------------------------------------------- use gw_utils, only: get_unit_vector, dot_2d, midpoint_interp use gw_common, only: GWBand, pver, qbo_hdepth_scaling @@ -65,10 +66,16 @@ subroutine gw_movmtn_src(ncol,lchnk, band, desc, u, v, & real(r8), intent(in) :: netdt_shcu(:,:) ! Higher order flux from ShCu/PBL. real(r8), intent(in) :: xpwp_shcu(ncol,pver+1) + ! Relative vorticity + real(r8), intent(in) :: vorticity(ncol,pver) ! Midpoint altitudes. real(r8), intent(in) :: zm(ncol,pver) ! tunable parameter controlling proportion of PBL momentum flux emitted as GW real(r8), intent(in) :: alpha_gw_movmtn + ! code for source of gw: 1=vorticity, 2=upwp + integer, intent(in) :: movmtn_source + ! Steering level and launch level inputs + integer, intent(in) :: ksteer_in, klaunch_in ! Indices of top gravity wave source level and lowest level where wind ! tendencies are allowed. @@ -136,10 +143,12 @@ subroutine gw_movmtn_src(ncol,lchnk, band, desc, u, v, & ! Index for ground based phase speed bin real(r8) :: c0(ncol,-band%ngwv:band%ngwv) integer :: c_idx(ncol,-band%ngwv:band%ngwv) - ! Flux source from ShCu/PBL + ! GW Flux source real(r8) :: xpwp_src(ncol) ! Manual steering level set - integer :: Steer_k + integer :: Steer_k(ncol), Launch_k(ncol) + ! Set source (1=vorticity, 2=PBL mom fluxes) + integer :: source_type !---------------------------------------------------------------------- ! Initialize tau array @@ -149,22 +158,38 @@ subroutine gw_movmtn_src(ncol,lchnk, band, desc, u, v, & q0 = 0.0_r8 tau0 = 0.0_r8 - !---------------------------------------------------------------------- - ! Calculate flux source from ShCu/PBL - !---------------------------------------------------------------------- - xpwp_src = shcu_flux_src( xpwp_shcu, ncol, pver+1, alpha_gw_movmtn ) + source_type=movmtn_source + if ( source_type==1 ) then + !---------------------------------------------------------------------- + ! Calculate flux source from vorticity + !---------------------------------------------------------------------- + call vorticity_flux_src( vorticity, ncol, pver , alpha_gw_movmtn, xpwp_src, Steer_k, Launch_k ) + else if ( source_type==2 ) then + !---------------------------------------------------------------------- + ! Calculate flux source from ShCu/PBL and set Steering level + !---------------------------------------------------------------------- + call shcu_flux_src( xpwp_shcu, ncol, pver+1, alpha_gw_movmtn, xpwp_src, Steer_k, Launch_k ) + end if + + !------------------------------------------------- + ! Override steering and launch levels if inputs>0 + !------------------------------------------------- + if (klaunch_in > 0) then + Launch_k(:ncol) = klaunch_in + end if + if (ksteer_in > 0) then + Steer_k(:ncol) = ksteer_in + end if !------------------------------------------------------------------------ - ! Determine wind and unit vectors approximately at the source (steering level), then + ! Determine wind and unit vectors at the steering level) then ! project winds. !------------------------------------------------------------------------ - - ! Winds at 'steering level' - Steer_k = pver-1 - usteer = u(:,Steer_k) !k defined in line21 (at specified altitude) - vsteer = v(:,Steer_k) - steer_level = real(Steer_k,r8) - + do i=1,ncol + usteer(i) = u(i, Steer_k(i) ) + vsteer(i) = v(i, Steer_k(i) ) + steer_level(i) = real(Steer_k(i),r8) + end do ! all GW calculations on a plane, which in our case is the wind at source level -> ubi is wind in this plane ! Get the unit vector components and magnitude at the source level. call get_unit_vector(usteer, vsteer, xv_steer, yv_steer, umag_steer) @@ -209,7 +234,7 @@ subroutine gw_movmtn_src(ncol,lchnk, band, desc, u, v, & if (use_gw_movmtn_pbl) then boti=pver - topi=Steer_k-10 ! desc%k-5 + topi=Launch_k ! set in source subr else do k = pver, 1, -1 !start at surface do i = 1, ncol @@ -419,15 +444,19 @@ pure function index_of_nearest(x, grid) result(idx) end function index_of_nearest !!!!!!!!!!!!!!!!!!!!!!!!!!! -pure function shcu_flux_src (xpwp_shcu , ncol, pverx, alpha_gw_movmtn ) result(xpwp_src) +subroutine shcu_flux_src (xpwp_shcu , ncol, pverx, alpha_gw_movmtn, xpwp_src, steering_level, launch_level ) integer, intent(in) :: ncol,pverx real(r8), intent(in) :: xpwp_shcu (ncol,pverx) real(r8), intent(in) :: alpha_gw_movmtn - real(r8) :: xpwp_src(ncol) + real(r8), intent(out) :: xpwp_src(ncol) + integer, intent(out) :: steering_level(ncol), launch_level(ncol) integer :: k, nlayers + steering_level(:ncol) = (pverx-1) - 5 !++ tuning test 12/30/24 + launch_level(:ncol) = steering_level -10 !++ tuning test 01/05/25 + !----------------------------------- ! Simple average over layers. ! Probably can do better @@ -439,6 +468,35 @@ pure function shcu_flux_src (xpwp_shcu , ncol, pverx, alpha_gw_movmtn ) result(x end do xpwp_src(:) = alpha_gw_movmtn * xpwp_src(:)/(1.0_r8*nlayers) -end function shcu_flux_src +end subroutine shcu_flux_src + +!!!!!!!!!!!!!!!!!!!!!!!!!!! +subroutine vorticity_flux_src (vorticity , ncol, pverx, alpha_gw_movmtn, vort_src, steering_level, launch_level ) + integer, intent(in) :: ncol,pverx + real(r8), intent(in) :: vorticity (ncol,pverx) + real(r8), intent(in) :: alpha_gw_movmtn + + real(r8), intent(out) :: vort_src(ncol) + integer, intent(out) :: steering_level(ncol), launch_level(ncol) + + real(r8) :: scale_factor + integer :: k, nlayers + + steering_level(:ncol) = pverx - 20 + launch_level(:ncol) = steering_level -10 + + scale_factor = 1.e4 ! scales vorticity amp to u'w' in CLUBB + !----------------------------------- + ! Simple average over layers. + ! Probably can do better + !----------------------------------- + nlayers=10 + vort_src(:) =0._r8 + do k = 0, nlayers-1 + vort_src(:) = vort_src(:) + scale_factor * abs( vorticity(:,pverx-k) ) + end do + vort_src(:) = alpha_gw_movmtn * vort_src(:)/nlayers + +end subroutine vorticity_flux_src end module gw_movmtn diff --git a/src/physics/cam/gw_rdg.F90 b/src/physics/cam/gw_rdg.F90 index b5a2a2137f..4e91db565a 100644 --- a/src/physics/cam/gw_rdg.F90 +++ b/src/physics/cam/gw_rdg.F90 @@ -19,6 +19,7 @@ module gw_rdg ! Public interface public :: gw_rdg_readnl public :: gw_rdg_src +public :: gw_rdg_resid_src public :: gw_rdg_belowpeak public :: gw_rdg_break_trap public :: gw_rdg_do_vdiff @@ -51,7 +52,7 @@ module gw_rdg -! NOTE: Critical inverse Froude number Fr_c is +! NOTE: Critical inverse Froude number Fr_c is ! 1./(SQRT(2.)~0.707 in SM2000 ! (should be <= 1) real(r8), protected :: Fr_c @@ -92,10 +93,10 @@ subroutine gw_rdg_readnl(nlfile) logical :: gw_rdg_do_divstream, gw_rdg_do_smooth_regimes, gw_rdg_do_adjust_tauoro, & gw_rdg_do_backward_compat - + real(r8) :: gw_rdg_C_BetaMax_DS, gw_rdg_C_GammaMax, & gw_rdg_Frx0, gw_rdg_Frx1, gw_rdg_C_BetaMax_SM, gw_rdg_Fr_c, & - gw_rdg_orohmin, gw_rdg_orovmin, gw_rdg_orostratmin, gw_rdg_orom2min + gw_rdg_orohmin, gw_rdg_orovmin, gw_rdg_orostratmin, gw_rdg_orom2min namelist /gw_rdg_nl/ gw_rdg_do_divstream, gw_rdg_C_BetaMax_DS, gw_rdg_C_GammaMax, & gw_rdg_Frx0, gw_rdg_Frx1, gw_rdg_C_BetaMax_SM, gw_rdg_Fr_c, & @@ -119,7 +120,7 @@ subroutine gw_rdg_readnl(nlfile) call freeunit(unitn) ! Set the local variables - do_divstream = gw_rdg_do_divstream + do_divstream = gw_rdg_do_divstream C_BetaMax_DS = gw_rdg_C_BetaMax_DS C_GammaMax = gw_rdg_C_GammaMax Frx0 = gw_rdg_Frx0 @@ -175,9 +176,213 @@ subroutine gw_rdg_readnl(nlfile) end subroutine gw_rdg_readnl +!========================================================================== +subroutine gw_rdg_resid_src(ncol, band, p, & + u, v, t, mxdis, kwvrdg, zi, nm, & + src_level, tend_level, tau, ubm, ubi, xv, yv, & + ubmsrc, usrc, vsrc, nsrc, rsrc, m2src, c, tauoro ) + use gw_common, only: rair, GWBand + use gw_utils, only: dot_2d, midpoint_interp, get_unit_vector + !----------------------------------------------------------------------- + ! Orographic source for multiple gravity wave drag parameterization. + ! + ! The stress is returned for a single wave with c=0, over orography. + ! For points where the orographic variance is small (including ocean), + ! the returned stress is zero. + !------------------------------Arguments-------------------------------- + ! Column dimension. + integer, intent(in) :: ncol + + ! Band to emit orographic waves in. + ! Regardless, we will only ever emit into l = 0. + type(GWBand), intent(in) :: band + ! Pressure coordinates. + type(Coords1D), intent(in) :: p + + + ! Midpoint zonal/meridional winds. ( m s-1) + real(r8), intent(in) :: u(ncol,pver), v(ncol,pver) + ! Midpoint temperatures. (K) + real(r8), intent(in) :: t(ncol,pver) + ! Height estimate for ridge (m) [anisotropic orography]. + real(r8), intent(in) :: mxdis(ncol) + ! horiz wavenumber [anisotropic orography]. + real(r8), intent(in) :: kwvrdg(ncol) + ! Interface altitudes above ground (m). + real(r8), intent(in) :: zi(ncol,pver+1) + ! Midpoint Brunt-Vaisalla frequencies (s-1). + real(r8), intent(in) :: nm(ncol,pver) + + ! Indices of top gravity wave source level and lowest level where wind + ! tendencies are allowed. + integer, intent(out) :: src_level(ncol) + integer, intent(out) :: tend_level(ncol) + + ! Averages over source region. + real(r8), intent(out) :: nsrc(ncol) ! B-V frequency. + real(r8), intent(out) :: rsrc(ncol) ! Density. + real(r8), intent(out) :: usrc(ncol) ! Zonal wind. + real(r8), intent(out) :: vsrc(ncol) ! Meridional wind. + real(r8), intent(out) :: ubmsrc(ncol) ! On-obstacle wind. + ! normalized wavenumber + real(r8), intent(out) :: m2src(ncol) + + + ! Wave Reynolds stress. + real(r8), intent(out) :: tau(ncol,-band%ngwv:band%ngwv,pver+1) + ! Projection of wind at midpoints and interfaces. + real(r8), intent(out) :: ubm(ncol,pver), ubi(ncol,pver+1) + ! Unit vectors of source wind (zonal and meridional components). + real(r8), intent(out) :: xv(ncol), yv(ncol) + ! Phase speeds. + real(r8), intent(out) :: c(ncol,-band%ngwv:band%ngwv) + ! source level mom. flux + real(r8), intent(out) :: tauoro(ncol) + + !---------------------------Local Storage------------------------------- + ! Column and level indices. + integer :: i, k + + ! Surface streamline displacement height (2*sgh). + real(r8) :: hdsp(ncol) + + ! Difference in interface pressure across source region. + real(r8) :: dpsrc(ncol) + ! Thickness of downslope wind region. + real(r8) :: ddw(ncol) + ! Thickness of linear wave region. + real(r8) :: dwv(ncol) + ! Wind speed in source region. + real(r8) :: wmsrc(ncol) + + real(r8) :: ragl(ncol) + real(r8) :: Fcrit_res,sghmax + +!-------------------------------------------------------------------------- +! Check that ngwav is equal to zero, otherwise end the job +!-------------------------------------------------------------------------- + if (band%ngwv /= 0) call endrun(' gw_rdg_src :: ERROR - band%ngwv must be zero and it is not') + +!-------------------------------------------------------------------------- +! Average the basic state variables for the wave source over the depth of +! the orographic standard deviation. Here we assume that the appropiate +! values of wind, stability, etc. for determining the wave source are +! averages over the depth of the atmosphere penterated by the typical +! mountain. +! Reduces to the bottom midpoint values when mxdis=0, such as over ocean. +!-------------------------------------------------------------------------- + + Fcrit_res = 1.0_r8 + hdsp = mxdis ! no longer multipied by 2 + where(hdsp < 10._r8) + hdsp = 0._r8 + end where + + src_level = pver+1 + + tau(:,0,:) = 0.0_r8 + + ! Find depth of "source layer" for mountain waves + ! i.e., between ground and mountain top + do k = pver, 1, -1 + do i = 1, ncol + ! Need to have h >= z(k+1) here or code will bomb when h=0. + if ( (hdsp(i) >= zi(i,k+1)) .and. (hdsp(i) < zi(i,k)) ) then + src_level(i) = k + end if + end do + end do + + rsrc = 0._r8 + usrc = 0._r8 + vsrc = 0._r8 + nsrc = 0._r8 + do i = 1, ncol + do k = pver, src_level(i), -1 + rsrc(i) = rsrc(i) + p%mid(i,k) / (rair*t(i,k))* p%del(i,k) + usrc(i) = usrc(i) + u(i,k) * p%del(i,k) + vsrc(i) = vsrc(i) + v(i,k) * p%del(i,k) + nsrc(i) = nsrc(i) + nm(i,k)* p%del(i,k) + end do + end do + + + do i = 1, ncol + dpsrc(i) = p%ifc(i,pver+1) - p%ifc(i,src_level(i)) + end do + + rsrc = rsrc / dpsrc + usrc = usrc / dpsrc + vsrc = vsrc / dpsrc + nsrc = nsrc / dpsrc + + ! Get the unit vector components and magnitude at the surface. + call get_unit_vector(usrc, vsrc, xv, yv, wmsrc ) + + ubmsrc = wmsrc + + ! Project the local wind at midpoints onto the source wind. + do k = 1, pver + ubm(:,k) = dot_2d(u(:,k), v(:,k), xv, yv) + end do + + ! Compute the interface wind projection by averaging the midpoint winds. + ! Use the top level wind at the top interface. + ubi(:,1) = ubm(:,1) + + ubi(:,2:pver) = midpoint_interp(ubm) + + ! The minimum stratification allowing GW behavior + ! should really depend on horizontal scale since + ! + ! m^2 ~ (N/U)^2 - k^2 + ! + + m2src = ( (nsrc/(ubmsrc+0.01_r8))**2 - kwvrdg**2 ) /((nsrc/(ubmsrc+0.01_r8))**2) + + ! Compute the interface wind projection by averaging the midpoint winds. + ! Use the top level wind at the top interface. + ubi(:,1) = ubm(:,1) + ubi(:,2:pver) = midpoint_interp(ubm) + ubi(:,pver+1) = ubm(:,pver) + + + + ! Determine the orographic c=0 source term following McFarlane (1987). + ! (DOI: https://doi.org/10.1175/1520-0469(1987)044<1775:TEOOEG>2.0.CO;2) + ! Set the source top interface index to pver, if the orographic term is + ! zero. + do i = 1, ncol + if ( ( src_level(i) > 0 ) .and. ( m2src(i) > orom2min ) ) then + sghmax = Fcrit_res * (ubmsrc(i) / nsrc(i))**2 + tauoro(i) = 0.5_r8 * kwvrdg(i) * min(hdsp(i)**2, sghmax) * & + rsrc(i) * nsrc(i) * ubmsrc(i) + else + tauoro(i) = 0._r8 + end if + end do + + do i = 1, ncol + do k=src_level(i),pver+1 + tau(i,0,k) = tauoro(i) + end do + end do + + + ! Allow wind tendencies all the way to the model bottom. + tend_level = pver + + ! No spectrum; phase speed is just 0. + c = 0._r8 + +end subroutine gw_rdg_resid_src + + +!========================================================================== + subroutine gw_rdg_src(ncol, band, p, & u, v, t, mxdis, angxy, anixy, kwvrdg, iso, zi, nm, & - src_level, tend_level, bwv_level ,tlb_level , tau, ubm, ubi, xv, yv, & + src_level, tend_level, bwv_level ,tlb_level , tau, ubm, ubi, xv, yv, & ubmsrc, usrc, vsrc, nsrc, rsrc, m2src, tlb, bwv, Fr1, Fr2, Frx, c) use gw_common, only: rair, GWBand use gw_utils, only: dot_2d, midpoint_interp @@ -264,8 +469,8 @@ subroutine gw_rdg_src(ncol, band, p, & ! Wind speed in source region. real(r8) :: wmsrc(ncol) - real(r8) :: ragl(ncol) - + real(r8) :: ragl(ncol) + !-------------------------------------------------------------------------- ! Check that ngwav is equal to zero, otherwise end the job !-------------------------------------------------------------------------- @@ -293,13 +498,13 @@ subroutine gw_rdg_src(ncol, band, p, & do i = 1, ncol ! Need to have h >= z(k+1) here or code will bomb when h=0. if ( (hdsp(i) >= zi(i,k+1)) .and. (hdsp(i) < zi(i,k)) ) then - src_level(i) = k + src_level(i) = k end if end do end do rsrc = 0._r8 - usrc = 0._r8 + usrc = 0._r8 vsrc = 0._r8 nsrc = 0._r8 do i = 1, ncol @@ -329,7 +534,7 @@ subroutine gw_rdg_src(ncol, band, p, & ragl = angxy * pii/180._r8 - ! protect from wierd "bad" angles + ! protect from wierd "bad" angles ! that may occur if hdsp is zero where( hdsp <= orohmin ) ragl = 0._r8 @@ -341,7 +546,7 @@ subroutine gw_rdg_src(ncol, band, p, & ! Kluge in possible "isotropic" obstacle. where( ( iso == 1 ) .and. (wmsrc > orovmin) ) - xv = usrc/wmsrc + xv = usrc/wmsrc yv = vsrc/wmsrc end where @@ -357,7 +562,7 @@ subroutine gw_rdg_src(ncol, band, p, & ubm(:,k) = sign( ubmsrc*0._r8+1._r8 , ubmsrc ) * ubm(:,k) end do - ! Sean says just use 1._r8 as + ! Sean says just use 1._r8 as ! first argument xv = sign( ubmsrc*0._r8+1._r8 , ubmsrc ) * xv yv = sign( ubmsrc*0._r8+1._r8 , ubmsrc ) * yv @@ -366,7 +571,7 @@ subroutine gw_rdg_src(ncol, band, p, & ! against zero ubmsrc = abs(ubmsrc) ubmsrc = max( 0.01_r8 , ubmsrc ) - + ! The minimum stratification allowing GW behavior ! should really depend on horizontal scale since @@ -374,9 +579,9 @@ subroutine gw_rdg_src(ncol, band, p, & ! m^2 ~ (N/U)^2 - k^2 ! ! Should also think about parameterizing - ! trapped lee-waves. + ! trapped lee-waves. + - ! This needs to be made constistent with later ! treatment of nonhydrostatic effects. m2src = ( (nsrc/(ubmsrc+0.01_r8))**2 - kwvrdg**2 ) /((nsrc/(ubmsrc+0.01_r8))**2) @@ -387,9 +592,9 @@ subroutine gw_rdg_src(ncol, band, p, & ! will modified later if wave breaking or trapping are ! diagnosed ! - ! ^ + ! ^ ! | *** linear propagation *** - ! (H) -------- mountain top ------------- | *** or wave breaking **** + ! (H) -------- mountain top ------------- | *** or wave breaking **** ! | *** regimes ************* ! (BWV)------ bottom of linear waves ---- | ! : | @@ -397,7 +602,7 @@ subroutine gw_rdg_src(ncol, band, p, & ! : | ! (TLB)--- top of flow diversion layer--- ' ! : - ! **** flow diversion ***** + ! **** flow diversion ***** ! : !============================================ @@ -406,17 +611,17 @@ subroutine gw_rdg_src(ncol, band, p, & !-------------------------------------------- ! High-drag downslope wind regime exists ! between bottom of linear waves and top of - ! flow diversion. Linear waves can only + ! flow diversion. Linear waves can only ! attain vertical displacment of f1*U/N. So, ! bottom of linear waves is given by ! - ! BWV = H - Fr1*U/N + ! BWV = H - Fr1*U/N ! - ! Downslope wind layer begins at BWV and + ! Downslope wind layer begins at BWV and ! extends below it until some maximum high ! drag obstacle height Fr2*U/N is attained ! (where Fr2 >= f1). Below downslope wind - ! there is flow diversion, so top of + ! there is flow diversion, so top of ! diversion layer (TLB) is equivalent to ! bottom of downslope wind layer and is; ! @@ -431,27 +636,27 @@ subroutine gw_rdg_src(ncol, band, p, & if ( do_divstream ) then !------------------------------------------------ - ! Calculate Fr2(Frx) for DS2017 + ! Calculate Fr2(Frx) for DS2017 !------------------------------------------------ where(Frx <= Frx0) Fr2(:) = Fr1(:) + Fr1(:)* C_GammaMax * anixy(:) elsewhere((Frx > Frx0).and.(Frx <= Frx1) ) Fr2(:) = Fr1(:) + Fr1(:)* C_GammaMax * anixy(:) & - * (Frx1 - Frx(:))/(Frx1-Frx0) - elsewhere(Frx > Frx1) + * (Frx1 - Frx(:))/(Frx1-Frx0) + elsewhere(Frx > Frx1) Fr2(:)=Fr1(:) endwhere else - !------------------------------------------ + !------------------------------------------ ! Regime distinctions entirely carried by ! amplification of taudsw (next subr) !------------------------------------------ Fr2(:)=Fr1(:) - end if + end if - - where( m2src > orom2min ) + + where( m2src > orom2min ) ddw = Fr2 * ( abs(ubmsrc) )/nsrc elsewhere ddw = 0._r8 @@ -475,7 +680,7 @@ subroutine gw_rdg_src(ncol, band, p, & ! Find *BOTTOM* of linear wave layer (BWV) !where ( nsrc > orostratmin ) - where( m2src > orom2min ) + where( m2src > orom2min ) dwv = Fr1 * ( abs(ubmsrc) )/nsrc elsewhere dwv = -9.999e9_r8 ! if weak strat - no waves @@ -507,7 +712,7 @@ subroutine gw_rdg_src(ncol, band, p, & ! No spectrum; phase speed is just 0. c = 0._r8 - where( m2src < orom2min ) + where( m2src < orom2min ) tlb = mxdis tlb_level = src_level endwhere @@ -520,8 +725,8 @@ end subroutine gw_rdg_src subroutine gw_rdg_belowpeak(ncol, band, rdg_cd_llb, & t, mxdis, anixy, kwvrdg, zi, nm, ni, rhoi, & - src_level , tau, & - ubmsrc, nsrc, rsrc, m2src,tlb,bwv,Fr1,Fr2,Frx, & + src_level , tau, & + ubmsrc, nsrc, rsrc, m2src,tlb,bwv,Fr1,Fr2,Frx, & tauoro,taudsw, hdspwv,hdspdw ) use gw_common, only: GWBand @@ -604,16 +809,16 @@ subroutine gw_rdg_belowpeak(ncol, band, rdg_cd_llb, & end do do i = 1, ncol - if ( m2src(i) > orom2min ) then + if ( m2src(i) > orom2min ) then hdspwv(i) = min( mxdis(i) , Fr1(i) * ubsrcx(i) / nsrc(i) ) else hdspwv(i) = 0._r8 end if end do - + if (do_divstream) then do i = 1, ncol - if ( m2src(i) > orom2min ) then + if ( m2src(i) > orom2min ) then hdspdw(i) = min( mxdis(i) , Fr2(i) * ubsrcx(i) / nsrc(i) ) else hdspdw(i) = 0._r8 @@ -622,8 +827,8 @@ subroutine gw_rdg_belowpeak(ncol, band, rdg_cd_llb, & else do i = 1, ncol ! Needed only to mark where a DSW occurs - if ( m2src(i) > orom2min ) then - hdspdw(i) = mxdis(i) + if ( m2src(i) > orom2min ) then + hdspdw(i) = mxdis(i) else hdspdw(i) = 0._r8 end if @@ -637,14 +842,14 @@ subroutine gw_rdg_belowpeak(ncol, band, rdg_cd_llb, & ! Determine the orographic c=0 source term following McFarlane (1987). ! Set the source top interface index to pver, if the orographic term is ! zero. - ! + ! ! This formula is basically from ! ! tau(src) = rho * u' * w' - ! where + ! where ! u' ~ N*h' and w' ~ U*h'/b (b="breite") ! - ! and 1/b has been replaced with k (kwvrdg) + ! and 1/b has been replaced with k (kwvrdg) ! do i = 1, ncol if ( ( src_level(i) > 0 ) .and. ( m2src(i) > orom2min ) ) then @@ -680,7 +885,7 @@ subroutine gw_rdg_belowpeak(ncol, band, rdg_cd_llb, & ! Amplify DSW between Frx=1. and Frx=Frx1 do i = 1,ncol dswamp=0._r8 - BetaMax = C_BetaMax_DS * anixy(i) + BetaMax = C_BetaMax_DS * anixy(i) if ( (Frx(i)>1._r8).and.(Frx(i)<=Frx1)) then dswamp = (Frx(i)-1._r8)*(Frx1-Frx(i))/(0.25_r8*(Frx1-1._r8)**2) end if @@ -691,30 +896,30 @@ subroutine gw_rdg_belowpeak(ncol, band, rdg_cd_llb, & ! Scinocca&McFarlane !-------------------- do i = 1, ncol - BetaMax = C_BetaMax_SM * anixy(i) + BetaMax = C_BetaMax_SM * anixy(i) if ( (Frx(i) >=1._r8) .and. (Frx(i) < 1.5_r8) ) then dswamp = 2._r8 * BetaMax * (Frx(i) -1._r8) else if ( ( Frx(i) >= 1.5_r8 ) .and. (Frx(i) < 3._r8 ) ) then - dswamp = ( 1._r8 + BetaMax - (0.666_r8**2) ) * ( 0.666_r8*(3._r8 - Frx(i) ))**2 & + dswamp = ( 1._r8 + BetaMax - (0.666_r8**2) ) * ( 0.666_r8*(3._r8 - Frx(i) ))**2 & + ( 1._r8 / Frx(i) )**2 -1._r8 else - dswamp = 0._r8 + dswamp = 0._r8 end if if ( (Frx(i) >=1._r8) .and. (Frx(i) < 3._r8) ) then taudsw(i) = (1._r8 + dswamp )*taulin(i) - tauoro(i) else - taudsw(i) = 0._r8 + taudsw(i) = 0._r8 endif ! This code defines "taudsw" as SUM of freely-propagating ! DSW enhancement. Different than in SM2000 - taudsw(i) = taudsw(i) + tauoro(i) + taudsw(i) = taudsw(i) + tauoro(i) end do !---------------------------------------------------- end if - + do i = 1, ncol - if ( m2src(i) > orom2min ) then + if ( m2src(i) > orom2min ) then where ( ( zi(i,:) < mxdis(i) ) .and. ( zi(i,:) >= bwv(i) ) ) tau(i,0,:) = tauoro(i) else where ( ( zi(i,:) < bwv(i) ) .and. ( zi(i,:) >= tlb(i) ) ) @@ -728,7 +933,7 @@ subroutine gw_rdg_belowpeak(ncol, band, rdg_cd_llb, & tau(i,0,:) = taudsw(i) + & Coeff_LB(i) * kwvrdg(i) * rsrc(i) * 0.5_r8 * (ubsrcx(i)**2) * ( tlb(i) - zi(i,:) ) endwhere - + if (do_smooth_regimes) then ! This blocks accounts for case where both mxdis and tlb fall ! between adjacent edges @@ -739,7 +944,7 @@ subroutine gw_rdg_belowpeak(ncol, band, rdg_cd_llb, & tau(i,0,k) = tauoro(i) end if end do - end if + end if else !---------------------------------------------- ! This block allows low-level dynamics to occur @@ -758,11 +963,11 @@ subroutine gw_rdg_belowpeak(ncol, band, rdg_cd_llb, & k=src_level(i) if ( ni(i,k) > orostratmin ) then tausat = (Fr_c**2) * kwvrdg(i) * rhoi(i,k) * ubsrcx(i)**3 / & - (1._r8*ni(i,k)) + (1._r8*ni(i,k)) else tausat = 0._r8 - endif - tau(i,0,src_level(i)) = min( tauoro(i), tausat ) + endif + tau(i,0,src_level(i)) = min( tauoro(i), tausat ) end do @@ -770,18 +975,18 @@ subroutine gw_rdg_belowpeak(ncol, band, rdg_cd_llb, & ! Final clean-up. Do nothing if obstacle less than orohmin do i = 1, ncol if ( mxdis(i) < orohmin ) then - tau(i,0,:) = 0._r8 + tau(i,0,:) = 0._r8 tauoro(i) = 0._r8 taudsw(i) = 0._r8 - endif + endif end do - ! Disable vertical propagation if Scorer param is + ! Disable vertical propagation if Scorer param is ! too small. do i = 1, ncol if ( m2src(i) <= orom2min ) then src_level(i)=1 - endif + endif end do @@ -790,10 +995,10 @@ end subroutine gw_rdg_belowpeak !========================================================================== subroutine gw_rdg_break_trap(ncol, band, & - zi, nm, ni, ubm, ubi, rhoi, kwvrdg, bwv, tlb, wbr, & - src_level, tlb_level, & + zi, nm, ni, ubm, ubi, rhoi, kwvrdg, bwv, tlb, wbr, & + src_level, tlb_level, & hdspwv, hdspdw, mxdis, & - tauoro, taudsw, tau, & + tauoro, taudsw, tau, & ldo_trapped_waves, wdth_kwv_scale_in ) use gw_common, only: GWBand !----------------------------------------------------------------------- @@ -893,7 +1098,7 @@ subroutine gw_rdg_break_trap(ncol, band, & endwhere end do - ! Take square root of m**2 and + ! Take square root of m**2 and ! do vertical integral to find ! WKB phase. !----------------------------- @@ -901,8 +1106,8 @@ subroutine gw_rdg_break_trap(ncol, band, & phswkb(:,:)=0 do k=pver,1,-1 where( zi(:,k) > tlb(:) ) - delz(:) = min( zi(:,k)-zi(:,k+1) , zi(:,k)-tlb(:) ) - phswkb(:,k) = phswkb(:,k+1) + m2(:,k)*delz(:) + delz(:) = min( zi(:,k)-zi(:,k+1) , zi(:,k)-tlb(:) ) + phswkb(:,k) = phswkb(:,k+1) + m2(:,k)*delz(:) endwhere end do @@ -913,9 +1118,9 @@ subroutine gw_rdg_break_trap(ncol, band, & wbrx(:)=0._r8 if (do_smooth_regimes) then do k=pver,1,-1 - where( (phswkb(:,k+1)<1.5_r8*pii).and.(phswkb(:,k)>=1.5_r8*pii) & + where( (phswkb(:,k+1)<1.5_r8*pii).and.(phswkb(:,k)>=1.5_r8*pii) & .and.(hdspdw(:)>hdspwv(:)) ) - wbr(:) = zi(:,k) + wbr(:) = zi(:,k) ! Extrapolation to make regime ! transitions smoother wbrx(:) = zi(:,k) - ( phswkb(:,k) - 1.5_r8*pii ) & @@ -925,7 +1130,7 @@ subroutine gw_rdg_break_trap(ncol, band, & end do else do k=pver,1,-1 - where( (phswkb(:,k+1)<1.5_r8*pii).and.(phswkb(:,k)>=1.5_r8*pii) & + where( (phswkb(:,k+1)<1.5_r8*pii).and.(phswkb(:,k)>=1.5_r8*pii) & .and.(hdspdw(:)>hdspwv(:)) ) wbr(:) = zi(:,k) src_level(:) = k @@ -936,12 +1141,12 @@ subroutine gw_rdg_break_trap(ncol, band, & ! Adjust tauoro at new source levels if needed. ! This is problematic if Fr_c<1.0. Not sure why. !---------------------------------------------------------- - if (do_adjust_tauoro) then + if (do_adjust_tauoro) then do i = 1,ncol if (wbr(i) > 0._r8 ) then - tausat(i) = (Fr_c**2) * kwvrdg(i) * rhoi( i, src_level(i) ) & + tausat(i) = (Fr_c**2) * kwvrdg(i) * rhoi( i, src_level(i) ) & * abs(ubi(i , src_level(i) ))**3 & - / ni( i , src_level(i) ) + / ni( i , src_level(i) ) tauoro(i) = min( tauoro(i), tausat(i) ) end if end do @@ -954,9 +1159,9 @@ subroutine gw_rdg_break_trap(ncol, band, & tau(i,0,k) = tauoro(i) + (taudsw(i)-tauoro(i)) * & ( wbrx(i) - zi(i,k) ) / & ( wbrx(i) - tlb(i) ) - tau(i,0,k) = max( tau(i,0,k), tauoro(i) ) + tau(i,0,k) = max( tau(i,0,k), tauoro(i) ) endif - end do + end do end do else ! Following is for backwards B4B compatibility with earlier versions @@ -969,7 +1174,7 @@ subroutine gw_rdg_break_trap(ncol, band, & ( wbr(i) - zi(i,k) ) / & ( wbr(i) - tlb(i) ) endif - end do + end do end do else do i = 1, ncol @@ -979,13 +1184,13 @@ subroutine gw_rdg_break_trap(ncol, band, & ( wbr(i) - zi(i,k) ) / & ( wbr(i) - tlb(i) ) endif - end do + end do end do end if end if - - if (lldo_trapped_waves) then - + + if (lldo_trapped_waves) then + ! Identify top edge of layer in which Scorer param drops below 0 ! - approximately the "turning level" !---------------------------------------------------------- diff --git a/src/physics/cam/macrop_driver.F90 b/src/physics/cam/macrop_driver.F90 index d381387bfc..26217c2a8c 100644 --- a/src/physics/cam/macrop_driver.F90 +++ b/src/physics/cam/macrop_driver.F90 @@ -87,7 +87,6 @@ module macrop_driver 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. @@ -395,7 +394,8 @@ subroutine macrop_driver_tend( & ! ! !-------------------------------------------------------- ! - use cloud_fraction, only: cldfrc, cldfrc_fice + use cloud_fraction, only: cldfrc + use cloud_fraction_fice, only: cloud_fraction_fice_run 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 @@ -486,7 +486,6 @@ subroutine macrop_driver_tend( & ! 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. @@ -872,8 +871,8 @@ subroutine macrop_driver_tend( & fice(:,:) = 0._r8 fsnow(:,:) = 0._r8 !REMOVECAM_END - call cldfrc_fice( ncol, state_loc%t(:ncol,:), fice(:ncol,:), fsnow(:ncol,:) ) + call cloud_fraction_fice_run(ncol, state_loc%t(:ncol,:), tmelt, top_lev, pver, fice(:ncol,:), fsnow(:ncol,:)) lq(:) = .FALSE. diff --git a/src/physics/cam/microp_driver.F90 b/src/physics/cam/microp_driver.F90 index baf11c4a9e..b328e3a670 100644 --- a/src/physics/cam/microp_driver.F90 +++ b/src/physics/cam/microp_driver.F90 @@ -50,7 +50,7 @@ subroutine microp_driver_readnl(nlfile) select case (microp_scheme) case ('MG') call micro_pumas_cam_readnl(nlfile) - case ('NONE', 'RK', 'SPCAM_sam1mom', 'SPCAM_m2005') + case ('NONE', 'RK') continue case default call endrun('microp_driver_readnl:: unrecognized microp_scheme, "'//trim(microp_scheme)//'"') @@ -95,7 +95,7 @@ function microp_driver_implements_cnst(name) select case (microp_scheme) case ('MG') microp_driver_implements_cnst = micro_pumas_cam_implements_cnst(name) - case ('NONE', 'RK', 'SPCAM_sam1mom', 'SPCAM_m2005') + case ('NONE', 'RK') continue case default call endrun('microp_driver_implements_cnst:: unrecognized microp_scheme, '//trim(microp_scheme)) @@ -123,12 +123,6 @@ subroutine microp_driver_init_cnst(name, latvals, lonvals, mask, q) case ('RK') ! microp_driver doesn't handle this one continue - case ('SPCAM_m2005') - ! microp_driver doesn't handle this one - continue - case ('SPCAM_sam1mom') - ! microp_driver doesn't handle this one - continue case default call endrun('microp_driver_init_cnst:: unrecognized microp_scheme'//trim(microp_scheme)) end select diff --git a/src/physics/cam/ndrop.F90 b/src/physics/cam/ndrop.F90 index ea3d7522da..3a2bed88c3 100644 --- a/src/physics/cam/ndrop.F90 +++ b/src/physics/cam/ndrop.F90 @@ -173,7 +173,7 @@ end subroutine ndrop_init subroutine dropmixnuc( aero_props, aero_state, & state, ptend, dtmicro, pbuf, wsub, wmixmin, & - cldn, cldo, cldliqf, tendnd, factnum, from_spcam) + cldn, cldo, cldliqf, tendnd, factnum) ! vertical diffusion and nucleation of cloud droplets ! assume cloud presence controlled by cloud fraction @@ -195,7 +195,6 @@ subroutine dropmixnuc( aero_props, aero_state, & 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 ! output arguments real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) @@ -311,7 +310,6 @@ subroutine dropmixnuc( aero_props, aero_state, & real(r8) :: zerogas(pver) character*200 fieldnamegas - logical :: called_from_spcam integer :: errnum character(len=shr_kind_cs) :: errstr !------------------------------------------------------------------------------- @@ -374,14 +372,6 @@ subroutine dropmixnuc( aero_props, aero_state, & ! intersitial and cloud borne phases. call aero_state%get_states( aero_props, raer, qqcw ) - called_from_spcam = (present(from_spcam)) - - if (called_from_spcam) then - rgas => state%q - allocate(rgascol(pver, pcnst, 2)) - allocate(coltendgas(pcols)) - endif - factnum = 0._r8 wtke = 0._r8 nsource = 0._r8 @@ -450,31 +440,12 @@ subroutine dropmixnuc( aero_props, aero_state, & raercol(top_lev:pver,mm,nsav) = raer(mm)%fld(i,top_lev:pver) end do - 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 @@ -919,21 +890,6 @@ subroutine dropmixnuc( aero_props, aero_state, & end do end do - 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 - end do ! old_cloud_nsubmix_loop ! evaporate particles again if no cloud (either ice or liquid) @@ -992,18 +948,6 @@ subroutine dropmixnuc( aero_props, aero_state, & end do end do - 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 ! end of main loop over i/longitude .................................... @@ -1012,11 +956,6 @@ subroutine dropmixnuc( aero_props, aero_state, & call outfld('NDROPMIX', ndropmix, pcols, lchnk) call outfld('WTKE ', wtke, pcols, lchnk) - if(called_from_spcam) then - call outfld('SPLCLOUD ', cldn , pcols, lchnk ) - call outfld('SPKVH ', kvh , pcols, lchnk ) - endif - call ccncalc(aero_state, aero_props, state, cs, ccn) do l = 1, psat call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) @@ -1031,22 +970,6 @@ subroutine dropmixnuc( aero_props, aero_state, & end do end do - 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 - deallocate( & nact, & mact, & diff --git a/src/physics/cam/nucleate_ice_cam.F90 b/src/physics/cam/nucleate_ice_cam.F90 index bd0a8b6636..3edd3f616a 100644 --- a/src/physics/cam/nucleate_ice_cam.F90 +++ b/src/physics/cam/nucleate_ice_cam.F90 @@ -69,7 +69,7 @@ module nucleate_ice_cam naai_hom_idx = -1 integer :: & - ast_idx = -1 + aist_idx = -1 integer :: & qsatfac_idx = -1 @@ -360,7 +360,7 @@ subroutine nucleate_ice_cam_init(mincld_in, bulk_scale_in, pbuf2d, aero_props) mincld) ! get indices for fields in the physics buffer - ast_idx = pbuf_get_index('AST') + aist_idx = pbuf_get_index('AIST') end subroutine nucleate_ice_cam_init @@ -400,8 +400,7 @@ subroutine nucleate_ice_cam_calc( & real(r8), pointer :: pmid(:,:) ! pressure at layer midpoints (pa) real(r8), pointer :: aer_mmr(:,:) ! aerosol mass mixing ratio - - real(r8), pointer :: ast(:,:) + real(r8), pointer :: aist(:,:) real(r8) :: icecldf(pcols,pver) ! ice cloud fraction real(r8), pointer :: qsatfac(:,:) ! Subgrid cloud water saturation scaling factor. @@ -509,9 +508,8 @@ subroutine nucleate_ice_cam_calc( & end if 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) + call pbuf_get_field(pbuf, aist_idx, aist, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + icecldf(:ncol,:pver) = aist(:ncol,:pver) ! naai and naai_hom are the outputs from this parameterization call pbuf_get_field(pbuf, naai_idx, naai) diff --git a/src/physics/cam/phys_control.F90 b/src/physics/cam/phys_control.F90 index 7105f2d6cd..0ad08646ce 100644 --- a/src/physics/cam/phys_control.F90 +++ b/src/physics/cam/phys_control.F90 @@ -85,8 +85,6 @@ module phys_control 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 @@ -206,9 +204,6 @@ subroutine phys_ctl_readnl(nlfile) call mpi_bcast(do_hb_above_clubb, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(use_hemco, 1, mpi_logical, masterprocid, mpicom, ierr) - use_spcam = ( cam_physpkg_is('spcam_sam1mom') & - .or. cam_physpkg_is('spcam_m2005')) - call cam_ctrl_set_physics_type(cam_physpkg) ! Error checking: @@ -231,13 +226,13 @@ subroutine phys_ctl_readnl(nlfile) 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 + if ( do_clubb_sgs .and. microp_scheme .ne. 'MG') 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 (do_clubb_sgs) 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') @@ -250,11 +245,6 @@ subroutine phys_ctl_readnl(nlfile) write(iulog,*) 'cam7 is only compatible with CLUBB. Quitting' call endrun('cam7 is only compatible with eddy, macrop, and shallow schemes = CLUBB_SGS') end if - ! Add a check to make sure SPCAM is not used - if (use_spcam) then - write(iulog,*)'SPCAM not compatible with cam7 physics. Quitting' - call endrun('SPCAM and cam7 incompatible') - end if ! Add check to make sure we are not trying to use `camrt` if (trim(radiation_scheme) == 'camrt') then write(iulog,*) ' camrt specified and it is not compatible with cam7' @@ -324,7 +314,7 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi 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, & + do_clubb_sgs_out, state_debug_checks_out, cld_macmic_num_steps_out, & offline_driver_out, convproc_do_aer_out, cam_snapshot_before_num_out, cam_snapshot_after_num_out,& cam_take_snapshot_before_out, cam_take_snapshot_after_out, physics_grid_out, do_hb_above_clubb_out) !----------------------------------------------------------------------- @@ -334,7 +324,6 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi ! 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 @@ -344,7 +333,6 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi 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 @@ -382,7 +370,6 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi 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 diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index 3a39635457..0e83ad2707 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -155,7 +155,6 @@ subroutine phys_register use subcol, only: subcol_register use subcol_utils, only: is_subcol_on, subcol_get_scheme use dyn_comp, only: dyn_register - use spcam_drivers, only: spcam_register use offline_driver, only: offline_driver_reg use hemco_interface, only: HCOI_Chunk_Init use upper_bc, only: ubc_fixed_conc @@ -309,9 +308,6 @@ subroutine phys_register ! shallow convection call convect_shallow_register - - call spcam_register - ! radiation call radiation_register call cloud_diagnostics_register @@ -731,6 +727,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use co2_cycle, only: co2_init, co2_transport use convect_deep, only: convect_deep_init use convect_shallow, only: convect_shallow_init + use constituents, only: cnst_get_ind use cam_diagnostics, only: diag_init use gw_drag, only: gw_init use radheat, only: radheat_init @@ -742,7 +739,6 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) 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 @@ -787,7 +783,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! local variables integer :: lchnk - integer :: ierr + integer :: ierr, ixq logical :: history_budget ! output tendencies and state variables for ! temperature, water vapor, cloud @@ -910,16 +906,11 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) call microp_aero_init(phys_state,pbuf2d) 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 lunar_tides_init() @@ -966,7 +957,8 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! Initialize CAM CCPP constituent properties array ! for use in CCPP-ized physics schemes: - call ccpp_const_props_init() + call cnst_get_ind('Q', ixq) + call ccpp_const_props_init(ixq) ! Initialize qneg3 and qneg4 call qneg_init() @@ -1067,7 +1059,6 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) 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 use cam_history, only: outfld, write_camiop @@ -1094,7 +1085,6 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) ! integer :: c ! indices integer :: nstep ! current timestep number - logical :: use_spcam type(physics_buffer_desc), pointer :: phys_buffer_chunk(:) call t_startf ('physpkg_st1') @@ -1148,8 +1138,6 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) 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 ! @@ -1161,16 +1149,8 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) 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 - + call tphysbc(ztodt, phys_state(c), phys_tend(c), phys_buffer_chunk, & + cam_out(c), cam_in(c) ) end do call t_adj_detailf(-1) diff --git a/src/physics/cam/pkg_cldoptics.F90 b/src/physics/cam/pkg_cldoptics.F90 index aa40dae6c3..221184a301 100644 --- a/src/physics/cam/pkg_cldoptics.F90 +++ b/src/physics/cam/pkg_cldoptics.F90 @@ -118,7 +118,7 @@ subroutine cldems(lchnk ,ncol ,clwp ,fice ,rei ,emis ,cldtau) !note that optical properties for ice valid only !in range of 13 > rei > 130 micron (Ebert and Curry 92) - if ( microp_scheme == 'RK' .or. microp_scheme == 'SPCAM_sam1mom') then + if ( microp_scheme == 'RK') then kabsi = 0.005_r8 + 1._r8/rei(i,k) else kabsi = 0.005_r8 + 1._r8/min(max(13._r8,rei(i,k)),130._r8) diff --git a/src/physics/cam/rk_stratiform.F90 b/src/physics/cam/rk_stratiform.F90 index 002300dbfd..148ea3fd28 100644 --- a/src/physics/cam/rk_stratiform.F90 +++ b/src/physics/cam/rk_stratiform.F90 @@ -427,7 +427,8 @@ subroutine rk_stratiform_tend( & ! ! !-------------------------------------------------------- ! - use cloud_fraction, only: cldfrc, cldfrc_fice + use cloud_fraction, only: cldfrc + use cloud_fraction_fice, only: cloud_fraction_fice_run 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 @@ -440,7 +441,7 @@ subroutine rk_stratiform_tend( & use phys_control, only: cam_physpkg_is use tropopause, only: tropopause_find_cam use phys_grid, only: get_rlat_all_p - use physconst, only: pi + use physconst, only: pi, tmelt ! Arguments type(physics_state), intent(in) :: state ! State variables @@ -577,6 +578,9 @@ subroutine rk_stratiform_tend( & real(r8) :: dlat(pcols) real(r8), parameter :: rad2deg = 180._r8/pi + integer :: top_lev + + ! ====================================================================== lchnk = state%lchnk @@ -812,7 +816,9 @@ subroutine rk_stratiform_tend( & fice(:,:) = 0._r8 fsnow(:,:) = 0._r8 !REMOVECAM_END - call cldfrc_fice(ncol, state1%t(1:ncol,:), fice(1:ncol,:), fsnow(1:ncol,:)) + top_lev = 1 + call cloud_fraction_fice_run(ncol, state1%t(:ncol,:), tmelt, top_lev, pver, fice(:ncol,:), fsnow(:ncol,:)) + ! Perform repartitioning of stratiform condensate. ! Corresponding heating tendency will be added later. diff --git a/src/physics/cam/spcam_drivers.F90 b/src/physics/cam/spcam_drivers.F90 deleted file mode 100644 index d44c1db730..0000000000 --- a/src/physics/cam/spcam_drivers.F90 +++ /dev/null @@ -1,54 +0,0 @@ -module spcam_drivers - -! stub module - -use shr_kind_mod, only: r8 => shr_kind_r8 -use physics_types, only: physics_state, physics_tend -use physics_buffer, only: physics_buffer_desc -use camsrfexch, only: cam_out_t, cam_in_t -use cam_abortutils, only: endrun - -implicit none -private -save - -public :: tphysbc_spcam, spcam_register, spcam_init - -!======================================================================================== -contains -!======================================================================================== - -subroutine tphysbc_spcam (ztodt, state, & - tend, pbuf, & - cam_out, cam_in ) - - real(r8), intent(in) :: ztodt - 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 - !--------------------------------------------------------------------------- - - call endrun('tphysbc_spcam: ERROR: this is a stub') - -end subroutine tphysbc_spcam - -!======================================================================================== - -subroutine spcam_register() - -end subroutine spcam_register - -!======================================================================================== - -subroutine spcam_init(pbuf2d) - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - -end subroutine spcam_init - -!======================================================================================== - -end module spcam_drivers - diff --git a/src/physics/cam/vertical_diffusion.F90 b/src/physics/cam/vertical_diffusion.F90 index e2d571a4de..efd571269a 100644 --- a/src/physics/cam/vertical_diffusion.F90 +++ b/src/physics/cam/vertical_diffusion.F90 @@ -195,7 +195,7 @@ subroutine vd_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) + if (eddy_scheme == 'diag_TKE') call eddy_diff_readnl(nlfile) end subroutine vd_readnl @@ -240,7 +240,7 @@ subroutine vd_register() end if ! diag_TKE fields - if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005') then + if (eddy_scheme == 'diag_TKE') then call eddy_diff_register() end if @@ -433,11 +433,11 @@ subroutine vertical_diffusion_init(pbuf2d) call phys_getopts(do_hb_above_clubb_out=do_hb_above_clubb) select case ( eddy_scheme ) - case ( 'diag_TKE', 'SPCAM_m2005' ) + case ( 'diag_TKE' ) 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') + case ( 'HB', 'HBR') 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) @@ -709,7 +709,6 @@ subroutine vertical_diffusion_tend( & !---------------------------------------------------- ! 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 physics_types, only : set_dry_to_wet, set_wet_to_dry use camsrfexch, only : cam_in_t use cam_history, only : outfld @@ -904,9 +903,6 @@ subroutine vertical_diffusion_tend( & ! Main Computation Begins ! ! ----------------------- ! - ! Assume 'wet' mixing ratios in diffusion code. - call set_dry_to_wet(state, convert_cnst_type='dry') - rztodt = 1._r8 / ztodt lchnk = state%lchnk ncol = state%ncol @@ -1014,7 +1010,7 @@ subroutine vertical_diffusion_tend( & th(:ncol,:pver) = state%t(:ncol,:pver) * state%exner(:ncol,:pver) select case (eddy_scheme) - case ( 'diag_TKE', 'SPCAM_m2005' ) + case ( 'diag_TKE' ) call eddy_diff_tend(state, pbuf, cam_in, & ztodt, p, tint, rhoi, cldn, wstarent, & @@ -1030,7 +1026,7 @@ subroutine vertical_diffusion_tend( & khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) - case ( 'HB', 'HBR', 'SPCAM_sam1mom' ) + case ( 'HB', 'HBR' ) ! Modification : We may need to use 'taux' instead of 'tautotx' here, for ! consistency with the previous HB scheme. @@ -1375,8 +1371,6 @@ subroutine vertical_diffusion_tend( & ptend%q(:ncol,:pver,m) = ptend%q(:ncol,:pver,m)*state%pdel(:ncol,:pver)/state%pdeldry(:ncol,:pver) endif end do - ! convert wet mmr back to dry before conservation check - call set_wet_to_dry(state, convert_cnst_type='dry') if (.not. do_pbl_diags) then slten(:ncol,:) = ( sl(:ncol,:) - sl_prePBL(:ncol,:) ) * rztodt @@ -1395,7 +1389,7 @@ subroutine vertical_diffusion_tend( & ! ! ! ------------------------------------------------------------ ! - if( (eddy_scheme .eq. 'diag_TKE' .or. eddy_scheme .eq. 'SPCAM_m2005') .and. do_pseudocon_diff ) then + if( eddy_scheme .eq. 'diag_TKE' .and. do_pseudocon_diff ) then ptend%q(:ncol,:pver,1) = qtten(:ncol,:pver) ptend%s(:ncol,:pver) = slten(:ncol,:pver) diff --git a/src/physics/cam/wv_sat_methods.F90 b/src/physics/cam/wv_sat_methods.F90 deleted file mode 100644 index bb2ffeb45b..0000000000 --- a/src/physics/cam/wv_sat_methods.F90 +++ /dev/null @@ -1,759 +0,0 @@ -module wv_sat_methods - -! This portable module contains all CAM methods for estimating -! the saturation vapor pressure of water. -! -! wv_saturation provides CAM-specific interfaces and utilities -! based on these formulae. -! -! Typical usage of this module: -! -! Init: -! call wv_sat_methods_init(r8, , errstring) -! -! Get scheme index from a name string: -! scheme_idx = wv_sat_get_scheme_idx(scheme_name) -! if (.not. wv_sat_valid_idx(scheme_idx)) -! -! Get pressures: -! es = wv_sat_svp_water(t, scheme_idx) -! es = wv_sat_svp_ice(t, scheme_idx) -! -! Use ice/water transition range: -! es = wv_sat_svp_trice(t, ttrice, scheme_idx) -! -! Note that elemental functions cannot be pointed to, nor passed -! as arguments. If you need to do either, it is recommended to -! wrap the function so that it can be given an explicit (non- -! elemental) interface. - -implicit none -private -save - -integer, parameter :: r8 = selected_real_kind(12) ! 8 byte real - -integer, parameter :: VLENS = 128 ! vector length for a GPU kernel - -real(r8) :: tmelt ! Melting point of water at 1 atm (K) -real(r8) :: h2otrip ! Triple point temperature of water (K) -real(r8) :: tboil ! Boiling point of water at 1 atm (K) - -real(r8) :: ttrice ! Ice-water transition range - -real(r8) :: epsilo ! Ice-water transition range -real(r8) :: omeps ! 1._r8 - epsilo - -! Indices representing individual schemes -integer, parameter :: Invalid_idx = -1 -integer, parameter :: GoffGratch_idx = 1 -integer, parameter :: MurphyKoop_idx = 2 -integer, parameter :: Bolton_idx = 3 - -! Index representing the current default scheme. -integer, parameter :: initial_default_idx = GoffGratch_idx -integer :: default_idx = initial_default_idx - -!$acc declare create (epsilo, tmelt, tboil, omeps, h2otrip, ttrice) - -public wv_sat_methods_init -public wv_sat_get_scheme_idx -public wv_sat_valid_idx - -public wv_sat_set_default -public wv_sat_reset_default - -public wv_sat_qsat_water, wv_sat_qsat_water_vect -public wv_sat_qsat_ice, wv_sat_qsat_ice_vect - -public wv_sat_svp_trans, wv_sat_svp_trans_vect - -! pressure -> humidity conversion -public wv_sat_svp_to_qsat, wv_sat_svp_to_qsat_vect - -! Combined qsat operations -public wv_sat_qsat_trans - -public wv_sat_svp_water, wv_sat_svp_water_vect -public wv_sat_svp_ice, wv_sat_svp_ice_vect - -contains - -!--------------------------------------------------------------------- -! ADMINISTRATIVE FUNCTIONS -!--------------------------------------------------------------------- - -! Get physical constants -subroutine wv_sat_methods_init(kind, tmelt_in, h2otrip_in, tboil_in, & - ttrice_in, epsilo_in, errstring) - integer, intent(in) :: kind - real(r8), intent(in) :: tmelt_in - real(r8), intent(in) :: h2otrip_in - real(r8), intent(in) :: tboil_in - real(r8), intent(in) :: ttrice_in - real(r8), intent(in) :: epsilo_in - character(len=*), intent(out) :: errstring - - errstring = ' ' - - if (kind /= r8) then - write(errstring,*) 'wv_sat_methods_init: ERROR: ', & - kind,' was input kind but ',r8,' is internal kind.' - return - end if - - if (ttrice_in < 0._r8) then - write(errstring,*) 'wv_sat_methods_init: ERROR: ', & - ttrice_in,' was input for ttrice, but negative range is invalid.' - return - end if - - tmelt = tmelt_in - h2otrip = h2otrip_in - tboil = tboil_in - ttrice = ttrice_in - epsilo = epsilo_in - - omeps = 1._r8 - epsilo - - !$acc update device (tmelt,h2otrip,tboil,ttrice,epsilo,omeps) - -end subroutine wv_sat_methods_init - -! Look up index by name. -pure function wv_sat_get_scheme_idx(name) result(idx) - character(len=*), intent(in) :: name - integer :: idx - - select case (name) - case("GoffGratch") - idx = GoffGratch_idx - case("MurphyKoop") - idx = MurphyKoop_idx - case("Bolton") - idx = Bolton_idx - case default - idx = Invalid_idx - end select - -end function wv_sat_get_scheme_idx - -! Check validity of an index from the above routine. -pure function wv_sat_valid_idx(idx) result(status) - integer, intent(in) :: idx - logical :: status - - status = (idx /= Invalid_idx) - -end function wv_sat_valid_idx - -! Set default scheme (otherwise, Goff & Gratch is default) -! Returns a logical representing success (.true.) or -! failure (.false.). -function wv_sat_set_default(name) result(status) - character(len=*), intent(in) :: name - logical :: status - - ! Don't want to overwrite valid default with invalid, - ! so assign to temporary and check it first. - integer :: tmp_idx - - tmp_idx = wv_sat_get_scheme_idx(name) - - status = wv_sat_valid_idx(tmp_idx) - - if (status) default_idx = tmp_idx - -end function wv_sat_set_default - -! Reset default scheme to initial value. -! The same thing can be accomplished with wv_sat_set_default; -! the real reason to provide this routine is to reset the -! module for testing purposes. -subroutine wv_sat_reset_default() - - default_idx = initial_default_idx - -end subroutine wv_sat_reset_default - -!--------------------------------------------------------------------- -! UTILITIES -!--------------------------------------------------------------------- - -! Get saturation specific humidity given pressure and SVP. -! Specific humidity is limited to range 0-1. -function wv_sat_svp_to_qsat(es, p) result(qs) - real(r8), intent(in) :: es ! SVP - real(r8), intent(in) :: p ! Current pressure. - real(r8) :: qs - - ! If pressure is less than SVP, set qs to maximum of 1. - if ( (p - es) <= 0._r8 ) then - qs = 1.0_r8 - else - qs = epsilo*es / (p - omeps*es) - end if - -end function wv_sat_svp_to_qsat - -! Get saturation specific humidity given pressure and SVP. -! Specific humidity is limited to range 0-1. -subroutine wv_sat_svp_to_qsat_vect(es, p, qs, vlen) - - integer, intent(in) :: vlen - real(r8), intent(in) :: es(vlen) ! SVP - real(r8), intent(in) :: p(vlen) ! Current pressure. - real(r8), intent(out) :: qs(vlen) - integer :: i - - ! If pressure is less than SVP, set qs to maximum of 1. - - !$acc data present (es,p,qs) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i=1,vlen - if ( (p(i) - es(i)) <= 0._r8 ) then - qs(i) = 1.0_r8 - else - qs(i) = epsilo*es(i) / (p(i) - omeps*es(i)) - end if - end do - !$acc end parallel - - !$acc end data -end subroutine wv_sat_svp_to_qsat_vect - -subroutine wv_sat_qsat_water(t, p, es, qs, idx) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over water at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - !------------------------------------------------------------------! - - ! Inputs - real(r8), intent(in) :: t ! Temperature - real(r8), intent(in) :: p ! Pressure - ! Outputs - real(r8), intent(out) :: es ! Saturation vapor pressure - real(r8), intent(out) :: qs ! Saturation specific humidity - - integer, intent(in), optional :: idx ! Scheme index - - es = wv_sat_svp_water(t, idx) - - qs = wv_sat_svp_to_qsat(es, p) - - ! Ensures returned es is consistent with limiters on qs. - es = min(es, p) - -end subroutine wv_sat_qsat_water - -subroutine wv_sat_qsat_water_vect(t, p, es, qs, vlen, idx) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over water at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - !------------------------------------------------------------------! - ! Inputs - - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) ! Temperature - real(r8), intent(in) :: p(vlen) ! Pressure - ! Outputs - real(r8), intent(out) :: es(vlen) ! Saturation vapor pressure - real(r8), intent(out) :: qs(vlen) ! Saturation specific humidity - - integer, intent(in), optional :: idx ! Scheme index - integer :: i - - !$acc data present (t,p,es,qs) - - call wv_sat_svp_water_vect(t, es, vlen, idx) - call wv_sat_svp_to_qsat_vect(es, p, qs, vlen) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i=1,vlen - ! Ensures returned es is consistent with limiters on qs. - es(i) = min(es(i), p(i)) - enddo - !$acc end parallel - - !$acc end data -end subroutine wv_sat_qsat_water_vect - -subroutine wv_sat_qsat_ice(t, p, es, qs, idx) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over ice at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - !------------------------------------------------------------------! - - ! Inputs - real(r8), intent(in) :: t ! Temperature - real(r8), intent(in) :: p ! Pressure - ! Outputs - real(r8), intent(out) :: es ! Saturation vapor pressure - real(r8), intent(out) :: qs ! Saturation specific humidity - - integer, intent(in), optional :: idx ! Scheme index - - es = wv_sat_svp_ice(t, idx) - - qs = wv_sat_svp_to_qsat(es, p) - - ! Ensures returned es is consistent with limiters on qs. - es = min(es, p) - -end subroutine wv_sat_qsat_ice - -subroutine wv_sat_qsat_ice_vect(t, p, es, qs, vlen, idx) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over ice at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - !------------------------------------------------------------------! - ! Inputs - - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) ! Temperature - real(r8), intent(in) :: p(vlen) ! Pressure - ! Outputs - real(r8), intent(out) :: es(vlen) ! Saturation vapor pressure - real(r8), intent(out) :: qs(vlen) ! Saturation specific humidity - - integer, intent(in), optional :: idx ! Scheme index - integer :: i - - !$acc data present (t,p,es,qs) - - call wv_sat_svp_ice_vect(t, es, vlen, idx) - call wv_sat_svp_to_qsat_vect(es, p, qs, vlen) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i=1,vlen - ! Ensures returned es is consistent with limiters on qs. - es(i) = min(es(i), p(i)) - enddo - !$acc end parallel - - !$acc end data -end subroutine wv_sat_qsat_ice_vect - -subroutine wv_sat_qsat_trans(t, p, es, qs, idx) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over ice at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - !------------------------------------------------------------------! - - ! Inputs - real(r8), intent(in) :: t ! Temperature - real(r8), intent(in) :: p ! Pressure - ! Outputs - real(r8), intent(out) :: es ! Saturation vapor pressure - real(r8), intent(out) :: qs ! Saturation specific humidity - - integer, intent(in), optional :: idx ! Scheme index - - es = wv_sat_svp_trans(t, idx) - - qs = wv_sat_svp_to_qsat(es, p) - - ! Ensures returned es is consistent with limiters on qs. - es = min(es, p) - -end subroutine wv_sat_qsat_trans - -!--------------------------------------------------------------------- -! SVP INTERFACE FUNCTIONS -!--------------------------------------------------------------------- - -function wv_sat_svp_water(t, idx) result(es) - real(r8), intent(in) :: t - integer, intent(in), optional :: idx - real(r8) :: es - - integer :: use_idx - - if (present(idx)) then - use_idx = idx - else - use_idx = default_idx - end if - - select case (use_idx) - case(GoffGratch_idx) - es = GoffGratch_svp_water(t) - case(MurphyKoop_idx) - es = MurphyKoop_svp_water(t) - case(Bolton_idx) - es = Bolton_svp_water(t) - end select - -end function wv_sat_svp_water - -subroutine wv_sat_svp_water_vect(t, es, vlen, idx) - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) - integer, intent(in), optional :: idx - real(r8), intent(out) :: es(vlen) - integer :: i - integer :: use_idx - - !$acc data present (t,es) - - if (present(idx)) then - use_idx = idx - else - use_idx = default_idx - end if - - select case (use_idx) - case(GoffGratch_idx) - call GoffGratch_svp_water_vect(t,es,vlen) - case(MurphyKoop_idx) - call MurphyKoop_svp_water_vect(t,es,vlen) - case(Bolton_idx) - call Bolton_svp_water_vect(t,es,vlen) - end select - - !$acc end data -end subroutine wv_sat_svp_water_vect - -function wv_sat_svp_ice(t, idx) result(es) - real(r8), intent(in) :: t - integer, intent(in), optional :: idx - real(r8) :: es - - integer :: use_idx - - if (present(idx)) then - use_idx = idx - else - use_idx = default_idx - end if - - select case (use_idx) - case(GoffGratch_idx) - es = GoffGratch_svp_ice(t) - case(MurphyKoop_idx) - es = MurphyKoop_svp_ice(t) - case(Bolton_idx) - es = Bolton_svp_water(t) - end select - -end function wv_sat_svp_ice - -subroutine wv_sat_svp_ice_vect(t, es, vlen, idx) - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) - integer, intent(in), optional :: idx - real(r8), intent(out) :: es(vlen) - integer :: i - - integer :: use_idx - - !$acc data present (t,es) - - if (present(idx)) then - use_idx = idx - else - use_idx = default_idx - end if - - select case (use_idx) - case(GoffGratch_idx) - call GoffGratch_svp_ice_vect(t,es,vlen) - case(MurphyKoop_idx) - call MurphyKoop_svp_ice_vect(t,es,vlen) - case(Bolton_idx) - call Bolton_svp_water_vect(t,es,vlen) - end select - - !$acc end data -end subroutine wv_sat_svp_ice_vect - -function wv_sat_svp_trans(t, idx) result(es) - - real(r8), intent(in) :: t - integer, intent(in), optional :: idx - real(r8) :: es - - real(r8) :: esice ! Saturation vapor pressure over ice - real(r8) :: weight ! Intermediate scratch variable for es transition - -! -! Water -! - if (t >= (tmelt - ttrice)) then - es = wv_sat_svp_water(t,idx) - else - es = 0.0_r8 - end if - -! -! Ice -! - if (t < tmelt) then - - esice = wv_sat_svp_ice(t,idx) - - if ( (tmelt - t) > ttrice ) then - weight = 1.0_r8 - else - weight = (tmelt - t)/ttrice - end if - - es = weight*esice + (1.0_r8 - weight)*es - end if - -end function wv_sat_svp_trans - -subroutine wv_sat_svp_trans_vect(t, es, vlen, idx) - - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) - integer, intent(in), optional :: idx - real(r8), intent(out) :: es(vlen) - - real(r8) :: esice(vlen) ! Saturation vapor pressure over ice - real(r8) :: weight ! Intermediate scratch variable for es transition - integer :: i - - !$acc data present (t,es) & - !$acc create (esice) - -! -! Water -! - call wv_sat_svp_water_vect(t,es,vlen,idx) - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - if (t(i) < (tmelt - ttrice)) then - es(i) = 0.0_r8 - end if - end do - !$acc end parallel -! -! Ice -! - call wv_sat_svp_ice_vect(t,esice,vlen,idx) - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - if (t(i) < tmelt) then - if ( (tmelt - t(i)) > ttrice ) then - weight = 1.0_r8 - else - weight = (tmelt - t(i))/ttrice - end if - - es(i) = weight*esice(i) + (1.0_r8 - weight)*es(i) - end if - end do - !$acc end parallel - - !$acc end data -end subroutine wv_sat_svp_trans_vect - -!--------------------------------------------------------------------- -! SVP METHODS -!--------------------------------------------------------------------- - -! Goff & Gratch (1946) - -function GoffGratch_svp_water(t) result(es) - real(r8), intent(in) :: t ! Temperature in Kelvin - real(r8) :: es ! SVP in Pa - - ! uncertain below -70 C - es = 10._r8**(-7.90298_r8*(tboil/t-1._r8)+ & - 5.02808_r8*log10(tboil/t)- & - 1.3816e-7_r8*(10._r8**(11.344_r8*(1._r8-t/tboil))-1._r8)+ & - 8.1328e-3_r8*(10._r8**(-3.49149_r8*(tboil/t-1._r8))-1._r8)+ & - log10(1013.246_r8))*100._r8 - -end function GoffGratch_svp_water - -subroutine GoffGratch_svp_water_vect(t, es, vlen) - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) ! Temperature in Kelvin - real(r8), intent(out) :: es(vlen) ! SVP in Pa - real(r8) :: log_tboil - integer :: i - - !$acc data present (t,es) - - ! Goff, J. A., and S. Gratch. “Low-Pressure Properties of Water from -160F - ! to 212F.” Trans. Am. Soc. Heat. Vent. Eng. 52 (1946): 95–121. - ! uncertain below -70 C - - log_tboil = log10(tboil) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i=1,vlen - es(i) = 10._r8**(-7.90298_r8*(tboil/t(i)-1._r8)+ & - 5.02808_r8*(log_tboil-log10(t(i)))- & - 1.3816e-7_r8*(10._r8**(11.344_r8*(1._r8-t(i)/tboil))-1._r8)+ & - 8.1328e-3_r8*(10._r8**(-3.49149_r8*(tboil/t(i)-1._r8))-1._r8)+ & - log10(1013.246_r8))*100._r8 - enddo - !$acc end parallel - - !$acc end data -end subroutine GoffGratch_svp_water_vect - -function GoffGratch_svp_ice(t) result(es) - real(r8), intent(in) :: t ! Temperature in Kelvin - real(r8) :: es ! SVP in Pa - - ! good down to -100 C - es = 10._r8**(-9.09718_r8*(h2otrip/t-1._r8)-3.56654_r8* & - log10(h2otrip/t)+0.876793_r8*(1._r8-t/h2otrip)+ & - log10(6.1071_r8))*100._r8 - -end function GoffGratch_svp_ice - -subroutine GoffGratch_svp_ice_vect(t, es, vlen) - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) ! Temperature in Kelvin - real(r8), intent(out) :: es(vlen) ! SVP in Pa - real(r8), parameter :: log_param = log10(6.1071_r8) - integer :: i - ! good down to -100 C - - !$acc data present (t,es) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i=1,vlen - es(i) = 10._r8**(-9.09718_r8*(h2otrip/t(i)-1._r8)-3.56654_r8* & - log10(h2otrip/t(i))+0.876793_r8*(1._r8-t(i)/h2otrip)+ & - log_param)*100._r8 - enddo - !$acc end parallel - - !$acc end data -end subroutine GoffGratch_svp_ice_vect - -! Murphy & Koop (2005) - -function MurphyKoop_svp_water(t) result(es) - real(r8), intent(in) :: t ! Temperature in Kelvin - real(r8) :: es ! SVP in Pa - - ! (good for 123 < T < 332 K) - es = exp(54.842763_r8 - (6763.22_r8 / t) - (4.210_r8 * log(t)) + & - (0.000367_r8 * t) + (tanh(0.0415_r8 * (t - 218.8_r8)) * & - (53.878_r8 - (1331.22_r8 / t) - (9.44523_r8 * log(t)) + & - 0.014025_r8 * t))) - -end function MurphyKoop_svp_water - -subroutine MurphyKoop_svp_water_vect(t, es, vlen) - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) ! Temperature in Kelvin - real(r8), intent(out) :: es(vlen) ! SVP in Pa - - integer :: i - ! Murphy, D. M., and T. Koop. “Review of the Vapour Pressure of Ice and - ! Supercooled Water for Atmospheric Applications.” Q. J. R. Meteorol. - ! Soc. 131, no. 608 (2005): 1539–65. 10.1256/qj.04.94 - ! (good for 123 < T < 332 K) - - !$acc data present (t,es) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - es(i) = exp(54.842763_r8 - (6763.22_r8 / t(i)) - (4.210_r8 * log(t(i))) + & - (0.000367_r8 * t(i)) + (tanh(0.0415_r8 * (t(i) - 218.8_r8)) * & - (53.878_r8 - (1331.22_r8 / t(i)) - (9.44523_r8 * log(t(i))) + & - 0.014025_r8 * t(i)))) - end do - !$acc end parallel - - !$acc end data -end subroutine MurphyKoop_svp_water_vect - -function MurphyKoop_svp_ice(t) result(es) - real(r8), intent(in) :: t ! Temperature in Kelvin - real(r8) :: es ! SVP in Pa - - ! (good down to 110 K) - es = exp(9.550426_r8 - (5723.265_r8 / t) + (3.53068_r8 * log(t)) & - - (0.00728332_r8 * t)) - -end function MurphyKoop_svp_ice - -subroutine MurphyKoop_svp_ice_vect(t, es, vlen) - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) ! Temperature in Kelvin - real(r8), intent(out) :: es(vlen) ! SVP in Pa - - integer :: i - ! (good down to 110 K) - - !$acc data present (t,es) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - es(i) = exp(9.550426_r8 - (5723.265_r8 / t(i)) + (3.53068_r8 * log(t(i))) & - - (0.00728332_r8 * t(i))) - end do - !$acc end parallel - - !$acc end data -end subroutine MurphyKoop_svp_ice_vect - -! Bolton (1980) -! zm_conv deep convection scheme contained this SVP calculation. -! It appears to be from D. Bolton, 1980, Monthly Weather Review. -! Unlike the other schemes, no distinct ice formula is associated -! with it. (However, a Bolton ice formula exists in CLUBB.) - -! The original formula used degrees C, but this function -! takes Kelvin and internally converts. - -function Bolton_svp_water(t) result(es) - real(r8),parameter :: c1 = 611.2_r8 - real(r8),parameter :: c2 = 17.67_r8 - real(r8),parameter :: c3 = 243.5_r8 - - real(r8), intent(in) :: t ! Temperature in Kelvin - real(r8) :: es ! SVP in Pa - - es = c1*exp( (c2*(t - tmelt))/((t - tmelt)+c3) ) - -end function Bolton_svp_water - -subroutine Bolton_svp_water_vect(t, es,vlen) - real(r8),parameter :: c1 = 611.2_r8 - real(r8),parameter :: c2 = 17.67_r8 - real(r8),parameter :: c3 = 243.5_r8 - - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) ! Temperature in Kelvin - real(r8), intent(out) :: es(vlen) ! SVP in Pa - - integer :: i - - !$acc data present (t,es) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - es(i) = c1*exp( (c2*(t(i) - tmelt))/((t(i) - tmelt)+c3) ) - end do - !$acc end parallel - - !$acc end data -end subroutine Bolton_svp_water_vect - -end module wv_sat_methods diff --git a/src/physics/cam/wv_saturation.F90 b/src/physics/cam/wv_saturation.F90 deleted file mode 100644 index ac94482e20..0000000000 --- a/src/physics/cam/wv_saturation.F90 +++ /dev/null @@ -1,1484 +0,0 @@ -module wv_saturation - -!--------------------------------------------------------------------! -! Module Overview: ! -! ! -! This module provides an interface to wv_sat_methods, providing ! -! saturation vapor pressure and related calculations to CAM. ! -! ! -! The original wv_saturation codes were introduced by J. J. Hack, ! -! February 1990. The code has been extensively rewritten since then, ! -! including a total refactoring in Summer 2012. ! -! ! -!--------------------------------------------------------------------! -! Methods: ! -! ! -! Pure water/ice saturation vapor pressures are calculated on the ! -! fly, with the specific method determined by a runtime option. ! -! Mixed phase SVP is interpolated from the internal table, estbl, ! -! which is created during initialization. ! -! ! -! The default method for calculating SVP is determined by a namelist ! -! option, and used whenever svp_water/ice or qsat are called. ! -! ! -!--------------------------------------------------------------------! - -use shr_kind_mod, only: r8 => shr_kind_r8 -use physconst, only: epsilo, & - latvap, & - latice, & - rh2o, & - cpair, & - tmelt, & - h2otrip - -use wv_sat_methods, only: & - svp_to_qsat => wv_sat_svp_to_qsat, & - svp_to_qsat_vect => wv_sat_svp_to_qsat_vect - -implicit none -private -save - -! Public interfaces -! Namelist, initialization, finalization -public wv_sat_readnl -public wv_sat_init -public wv_sat_final - -! Saturation vapor pressure calculations -public svp_water, svp_water_vect -public svp_ice, svp_ice_vect - -! Mixed phase (water + ice) saturation vapor pressure table lookup -public estblf - -public svp_to_qsat - -! Subroutines that return both SVP and humidity -! Optional arguments do temperature derivatives -interface qsat - module procedure qsat_line - module procedure qsat_vect - module procedure qsat_2D -end interface -public qsat ! Mixed phase -interface qsat_water - module procedure qsat_water_line - module procedure qsat_water_vect - module procedure qsat_water_2D -end interface -public qsat_water ! SVP over water only -interface qsat_ice - module procedure qsat_ice_line - module procedure qsat_ice_vect - module procedure qsat_ice_2D -end interface -public qsat_ice ! SVP over ice only - -! Wet bulb temperature solver -public :: findsp_vc, findsp - -! Data - -! This value is slightly high, but it seems to be the value for the -! steam point of water originally (and most frequently) used in the -! Goff & Gratch scheme. -real(r8), parameter :: tboil = 373.16_r8 - -! Table of saturation vapor pressure values (estbl) from tmin to -! tmax+1 Kelvin, in one degree increments. ttrice defines the -! transition region, estbl contains a combination of ice & water -! values. -! Make these public parameters in case another module wants to see the -! extent of the table. - real(r8), public, parameter :: tmin = 127.16_r8 - real(r8), public, parameter :: tmax = 375.16_r8 - - real(r8), parameter :: ttrice = 20.00_r8 ! transition range from es over H2O to es over ice - - integer :: plenest ! length of estbl - real(r8), allocatable :: estbl(:) ! table values of saturation vapor pressure - - real(r8) :: omeps ! 1.0_r8 - epsilo - - real(r8) :: c3 ! parameter used by findsp - - ! Set coefficients for polynomial approximation of difference - ! between saturation vapor press over water and saturation pressure - ! over ice for -ttrice < t < 0 (degrees C). NOTE: polynomial is - ! valid in the range -40 < t < 0 (degrees C). - real(r8) :: pcf(5) = (/ & - 5.04469588506e-01_r8, & - -5.47288442819e+00_r8, & - -3.67471858735e-01_r8, & - -8.95963532403e-03_r8, & - -7.78053686625e-05_r8 /) - -! --- Degree 6 approximation --- -! real(r8) :: pcf(6) = (/ & -! 7.63285250063e-02, & -! 5.86048427932e+00, & -! 4.38660831780e-01, & -! 1.37898276415e-02, & -! 2.14444472424e-04, & -! 1.36639103771e-06 /) - - integer, parameter :: VLENS = 128 ! vector length for a GPU kernel - - !$acc declare create (plenest,estbl,omeps,c3,pcf) - -contains - -!--------------------------------------------------------------------- -! ADMINISTRATIVE FUNCTIONS -!--------------------------------------------------------------------- - -subroutine wv_sat_readnl(nlfile) - !------------------------------------------------------------------! - ! Purpose: ! - ! Get runtime options for wv_saturation. ! - !------------------------------------------------------------------! - - use wv_sat_methods, only: wv_sat_get_scheme_idx, & - wv_sat_valid_idx, & - wv_sat_set_default - - use spmd_utils, only: masterproc - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use mpishorthand - use cam_abortutils, only: endrun - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - - character(len=32) :: wv_sat_scheme = "GoffGratch" - - character(len=*), parameter :: subname = 'wv_sat_readnl' - - namelist /wv_sat_nl/ wv_sat_scheme - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'wv_sat_nl', status=ierr) - if (ierr == 0) then - read(unitn, wv_sat_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - return - end if - end if - close(unitn) - call freeunit(unitn) - - end if - -#ifdef SPMD - call mpibcast(wv_sat_scheme, len(wv_sat_scheme) , mpichar, 0, mpicom) -#endif - - if (.not. wv_sat_set_default(wv_sat_scheme)) then - call endrun('wv_sat_readnl :: Invalid wv_sat_scheme.') - return - end if - -end subroutine wv_sat_readnl - -subroutine wv_sat_init - !------------------------------------------------------------------! - ! Purpose: ! - ! Initialize module (e.g. setting parameters, initializing the ! - ! SVP lookup table). ! - !------------------------------------------------------------------! - - use wv_sat_methods, only: wv_sat_methods_init, & - wv_sat_get_scheme_idx, & - wv_sat_valid_idx - use spmd_utils, only: masterproc - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - use shr_assert_mod, only: shr_assert_in_domain - use error_messages, only: handle_errmsg - - integer :: status - - ! For wv_sat_methods error reporting. - character(len=256) :: errstring - - ! For generating internal SVP table. - real(r8) :: t ! Temperature - integer :: i ! Increment counter - - ! Precalculated because so frequently used. - omeps = 1.0_r8 - epsilo - - ! Transition range method is only valid for transition temperatures at: - ! -40 deg C < T < 0 deg C - call shr_assert_in_domain(ttrice, ge=0._r8, le=40._r8, varname="ttrice",& - msg="wv_sat_init: Invalid transition temperature range.") - -! This parameter uses a hardcoded 287.04_r8? - c3 = 287.04_r8*(7.5_r8*log(10._r8))/cpair - -! Init "methods" module containing actual SVP formulae. - - call wv_sat_methods_init(r8, tmelt, h2otrip, tboil, ttrice, & - epsilo, errstring) - - call handle_errmsg(errstring, subname="wv_sat_methods_init") - - ! Add two to make the table slightly too big, just in case. - plenest = ceiling(tmax-tmin) + 2 - - ! Allocate SVP table. - allocate(estbl(plenest), stat=status) - if (status /= 0) then - call endrun('wv_sat_init :: ERROR allocating saturation vapor pressure table') - return - end if - - do i = 1, plenest - estbl(i) = svp_trans(tmin + real(i-1,r8)) - end do - - !$acc update device (plenest,estbl,omeps,c3,pcf) - - if (masterproc) then - write(iulog,*)' *** SATURATION VAPOR PRESSURE TABLE COMPLETED ***' - end if - -end subroutine wv_sat_init - -subroutine wv_sat_final - !------------------------------------------------------------------! - ! Purpose: ! - ! Deallocate global variables in module. ! - !------------------------------------------------------------------! - use cam_abortutils, only: endrun - - integer :: status - - if (allocated(estbl)) then - - deallocate(estbl, stat=status) - - if (status /= 0) then - call endrun('wv_sat_final :: ERROR deallocating table') - return - end if - - end if - -end subroutine wv_sat_final - -!--------------------------------------------------------------------- -! DEFAULT SVP FUNCTIONS -!--------------------------------------------------------------------- - -! Compute saturation vapor pressure over water -function svp_water(t) result(es) - - use wv_sat_methods, only: & - wv_sat_svp_water - - real(r8), intent(in) :: t ! Temperature (K) - real(r8) :: es ! SVP (Pa) - - es = wv_sat_svp_water(t) - -end function svp_water - -! Compute saturation vapor pressure over water -subroutine svp_water_vect(t, es, vlen) - - use wv_sat_methods, only: & - wv_sat_svp_water_vect - - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) ! Temperature (K) - real(r8), intent(out) :: es(vlen) ! SVP (Pa) - - !$acc data copyin (t) copyout (es) - - call wv_sat_svp_water_vect(t, es, vlen) - - !$acc end data -end subroutine svp_water_vect - -! Compute saturation vapor pressure over ice -function svp_ice(t) result(es) - - use wv_sat_methods, only: & - wv_sat_svp_ice - - real(r8), intent(in) :: t ! Temperature (K) - real(r8) :: es ! SVP (Pa) - - es = wv_sat_svp_ice(t) - -end function svp_ice - -! Compute saturation vapor pressure over ice -subroutine svp_ice_vect(t, es, vlen) - - use wv_sat_methods, only: & - wv_sat_svp_ice_vect - - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) ! Temperature (K) - real(r8), intent(out) :: es(vlen) ! SVP (Pa) - - !$acc data copyin(t) copyout(es) - - call wv_sat_svp_ice_vect(t, es, vlen) - - !$acc end data -end subroutine svp_ice_vect - -! Compute saturation vapor pressure with an ice-water transition -function svp_trans(t) result(es) - - use wv_sat_methods, only: & - wv_sat_svp_trans - - real(r8), intent(in) :: t ! Temperature (K) - real(r8) :: es ! SVP (Pa) - - es = wv_sat_svp_trans(t) - -end function svp_trans - -! Compute saturation vapor pressure with an ice-water transition -subroutine svp_trans_vect(t, es, vlen) - - use wv_sat_methods, only: & - wv_sat_svp_trans_vect - - integer, intent(in) :: vlen - real(r8), intent(in) :: t(vlen) ! Temperature (K) - real(r8), intent(out) :: es(vlen) ! SVP (Pa) - - !$acc data copyin(t) copyout(es) - - call wv_sat_svp_trans_vect(t, es, vlen) - - !$acc end data -end subroutine svp_trans_vect - -!--------------------------------------------------------------------- -! UTILITIES -!--------------------------------------------------------------------- - -! Does linear interpolation from nearest values found -! in the table (estbl). -elemental function estblf(t) result(es) - - real(r8), intent(in) :: t ! Temperature - real(r8) :: es ! SVP (Pa) - - integer :: i ! Index for t in the table - real(r8) :: t_tmp ! intermediate temperature for es look-up - - real(r8) :: weight ! Weight for interpolation - - t_tmp = max(min(t,tmax)-tmin, 0._r8) ! Number of table entries above tmin - i = int(t_tmp) + 1 ! Corresponding index. - weight = t_tmp - aint(t_tmp, r8) ! Fractional part of t_tmp (for interpolation). - es = (1._r8 - weight)*estbl(i) + weight*estbl(i+1) - -end function estblf - -! Does linear interpolation from nearest values found -! in the table (estbl). -subroutine estblf_vect(t, es, vlen) - - integer, intent(in) :: vlen - real(r8), dimension(vlen), intent(in) :: t ! Temperature - real(r8), dimension(vlen), intent(out) :: es ! SVP (Pa) - - integer :: i ! Index for t in the table - integer :: j - real(r8) :: t_tmp ! intermediate temperature for es look-up - - real(r8) :: weight ! Weight for interpolation - - !$acc data present (t,es) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector private(t_tmp,weight,i) - do j = 1, vlen - t_tmp = max(min(t(j),tmax)-tmin, 0._r8) ! Number of table entries above tmin - i = int(t_tmp) + 1 ! Corresponding index. - weight = t_tmp - aint(t_tmp, r8) ! Fractional part of t_tmp (for interpolation). - es(j) = (1._r8 - weight)*estbl(i) + weight*estbl(i+1) - end do - !$acc end parallel - - !$acc end data -end subroutine estblf_vect - -! Get enthalpy based only on temperature -! and specific humidity. -elemental function tq_enthalpy(t, q, hltalt) result(enthalpy) - - real(r8), intent(in) :: t ! Temperature - real(r8), intent(in) :: q ! Specific humidity - real(r8), intent(in) :: hltalt ! Modified hlat for T derivatives - - real(r8) :: enthalpy - - enthalpy = cpair * t + hltalt * q - -end function tq_enthalpy - -! Get enthalpy based only on temperature -! and specific humidity. -subroutine tq_enthalpy_vect(t, q, hltalt, enthalpy, vlen) - - integer, intent(in) :: vlen - real(r8), dimension(vlen), intent(in) :: t ! Temperature - real(r8), dimension(vlen), intent(in) :: q ! Specific humidity - real(r8), dimension(vlen), intent(in) :: hltalt ! Modified hlat for T derivatives - - real(r8), dimension(vlen), intent(out) :: enthalpy - - integer :: i - - !$acc data present(t,q,hltalt,enthalpy) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - enthalpy(i) = cpair * t(i) + hltalt(i) * q(i) - end do - !$acc end parallel - - !$acc end data -end subroutine tq_enthalpy_vect - -!--------------------------------------------------------------------- -! LATENT HEAT OF VAPORIZATION CORRECTIONS -!--------------------------------------------------------------------- - -elemental subroutine no_ip_hltalt(t, hltalt) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate latent heat of vaporization of pure liquid water at ! - ! a given temperature. ! - !------------------------------------------------------------------! - - ! Inputs - real(r8), intent(in) :: t ! Temperature - ! Outputs - real(r8), intent(out) :: hltalt ! Appropriately modified hlat - - hltalt = latvap - - ! Account for change of latvap with t above freezing where - ! constant slope is given by -2369 j/(kg c) = cpv - cw - if (t >= tmelt) then - hltalt = hltalt - 2369.0_r8*(t-tmelt) - end if - -end subroutine no_ip_hltalt - -subroutine no_ip_hltalt_vect(t, hltalt, vlen) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate latent heat of vaporization of pure liquid water at ! - ! a given temperature. ! - !------------------------------------------------------------------! - - ! Inputs - integer, intent(in) :: vlen - real(r8), dimension(vlen), intent(in) :: t ! Temperature - ! Outputs - real(r8), dimension(vlen), intent(out) :: hltalt ! Appropriately modified hlat - - integer :: i - - !$acc data present(t,hltalt) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - hltalt(i) = latvap - ! Account for change of latvap with t above freezing where - ! constant slope is given by -2369 j/(kg c) = cpv - cw - if (t(i) >= tmelt) then - hltalt(i) = hltalt(i) - 2369.0_r8*(t(i)-tmelt) - end if - end do - !$acc end parallel - - !$acc end data -end subroutine no_ip_hltalt_vect - -elemental subroutine calc_hltalt(t, hltalt, tterm) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate latent heat of vaporization of water at a given ! - ! temperature, taking into account the ice phase if temperature ! - ! is below freezing. ! - ! Optional argument also calculates a term used to calculate ! - ! d(es)/dT within the water-ice transition range. ! - !------------------------------------------------------------------! - - ! Inputs - real(r8), intent(in) :: t ! Temperature - ! Outputs - real(r8), intent(out) :: hltalt ! Appropriately modified hlat - ! Term to account for d(es)/dT in transition region. - real(r8), intent(out), optional :: tterm - - ! Local variables - real(r8) :: tc ! Temperature in degrees C - real(r8) :: weight ! Weight for es transition from water to ice - ! Loop iterator - integer :: i - - if (present(tterm)) tterm = 0.0_r8 - - call no_ip_hltalt(t,hltalt) - if (t < tmelt) then - ! Weighting of hlat accounts for transition from water to ice. - tc = t - tmelt - - if (tc >= -ttrice) then - weight = -tc/ttrice - - ! polynomial expression approximates difference between es - ! over water and es over ice from 0 to -ttrice (C) (max of - ! ttrice is 40): required for accurate estimate of es - ! derivative in transition range from ice to water - if (present(tterm)) then - do i = size(pcf), 1, -1 - tterm = pcf(i) + tc*tterm - end do - tterm = tterm/ttrice - end if - - else - weight = 1.0_r8 - end if - - hltalt = hltalt + weight*latice - - end if - -end subroutine calc_hltalt - -subroutine calc_hltalt_vect(t, hltalt, vlen, tterm) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate latent heat of vaporization of water at a given ! - ! temperature, taking into account the ice phase if temperature ! - ! is below freezing. ! - ! Optional argument also calculates a term used to calculate ! - ! d(es)/dT within the water-ice transition range. ! - !------------------------------------------------------------------! - - ! Inputs - integer, intent(in) :: vlen - real(r8), dimension(vlen), intent(in) :: t ! Temperature - ! Outputs - real(r8), dimension(vlen), intent(out) :: hltalt ! Appropriately modified hlat - ! Term to account for d(es)/dT in transition region. - real(r8), dimension(vlen), intent(out), optional :: tterm - - ! Local variables - real(r8) :: tc ! Temperature in degrees C - real(r8) :: weight ! Weight for es transition from water to ice - logical :: present_tterm - ! Loop iterator - integer :: i, j, size_pcf - - present_tterm = present(tterm) - size_pcf = size(pcf) - - !$acc data present(t,hltalt,tterm) - - if (present_tterm) then - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - tterm(i) = 0.0_r8 - end do - !$acc end parallel - end if - - call no_ip_hltalt_vect(t,hltalt,vlen) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector private(tc,weight) - do j = 1, vlen - if (t(j) < tmelt) then - ! Weighting of hlat accounts for transition from water to ice. - tc = t(j) - tmelt - - if (tc >= -ttrice) then - weight = -tc/ttrice - - ! polynomial expression approximates difference between es - ! over water and es over ice from 0 to -ttrice (C) (max of - ! ttrice is 40): required for accurate estimate of es - ! derivative in transition range from ice to water - if (present_tterm) then - !$acc loop seq - do i = size_pcf, 1, -1 - tterm(j) = pcf(i) + tc*tterm(j) - end do - tterm(j) = tterm(j)/ttrice - end if - - else - weight = 1.0_r8 - end if - - hltalt(j) = hltalt(j) + weight*latice - - end if - end do - !$acc end parallel - - !$acc end data -end subroutine calc_hltalt_vect - -!--------------------------------------------------------------------- -! OPTIONAL OUTPUTS -!--------------------------------------------------------------------- - -! Temperature derivative outputs, for qsat_* -subroutine deriv_outputs_line(t, p, es, qs, hltalt, tterm, & - gam, dqsdt) - - ! Inputs - real(r8), intent(in) :: t ! Temperature - real(r8), intent(in) :: p ! Pressure - real(r8), intent(in) :: es ! Saturation vapor pressure - real(r8), intent(in) :: qs ! Saturation specific humidity - real(r8), intent(in) :: hltalt ! Modified latent heat - real(r8), intent(in) :: tterm ! Extra term for d(es)/dT in - ! transition region. - - ! Outputs - real(r8), intent(out), optional :: gam ! (hltalt/cpair)*(d(qs)/dt) - real(r8), intent(out), optional :: dqsdt ! (d(qs)/dt) - - ! Local variables - real(r8) :: desdt ! d(es)/dt - real(r8) :: dqsdt_loc ! local copy of dqsdt - - if (qs == 1.0_r8) then - dqsdt_loc = 0._r8 - else - desdt = hltalt*es/(rh2o*t*t) + tterm - dqsdt_loc = qs*p*desdt/(es*(p-omeps*es)) - end if - - if (present(dqsdt)) dqsdt = dqsdt_loc - if (present(gam)) gam = dqsdt_loc * (hltalt/cpair) - -end subroutine deriv_outputs_line - -! Temperature derivative outputs, for qsat_* -subroutine deriv_outputs_vect(t, p, es, qs, hltalt, tterm, vlen, & - gam, dqsdt) - - ! Inputs - integer, intent(in) :: vlen - real(r8), dimension(vlen), intent(in) :: t ! Temperature - real(r8), dimension(vlen), intent(in) :: p ! Pressure - real(r8), dimension(vlen), intent(in) :: es ! Saturation vapor pressure - real(r8), dimension(vlen), intent(in) :: qs ! Saturation specific humidity - real(r8), dimension(vlen), intent(in) :: hltalt ! Modified latent heat - real(r8), dimension(vlen), intent(in) :: tterm ! Extra term for d(es)/dT in - ! transition region. - - ! Outputs - real(r8), dimension(vlen), intent(out), optional :: gam ! (hltalt/cpair)*(d(qs)/dt) - real(r8), dimension(vlen), intent(out), optional :: dqsdt ! (d(qs)/dt) - - ! Local variables - real(r8) :: desdt ! d(es)/dt - real(r8) :: dqsdt_loc ! local copy of dqsdt - logical :: present_dqsdt, present_gam - integer :: i - - present_dqsdt = present(dqsdt) - present_gam = present(gam) - - !$acc data present(t,p,es,qs,hltalt,tterm,gam,dqsdt) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector private(dqsdt_loc,desdt) - do i = 1, vlen - if (qs(i) == 1.0_r8) then - dqsdt_loc = 0._r8 - else - desdt = hltalt(i)*es(i)/(rh2o*t(i)*t(i)) + tterm(i) - dqsdt_loc = qs(i)*p(i)*desdt/(es(i)*(p(i)-omeps*es(i))) - end if - - if (present_dqsdt) dqsdt(i) = dqsdt_loc - if (present_gam) gam(i) = dqsdt_loc * (hltalt(i)/cpair) - end do - !$acc end parallel - - !$acc end data -end subroutine deriv_outputs_vect - -!--------------------------------------------------------------------- -! QSAT (SPECIFIC HUMIDITY) PROCEDURES -!--------------------------------------------------------------------- - -subroutine qsat_line(t, p, es, qs, gam, dqsdt, enthalpy) - !------------------------------------------------------------------! - ! Purpose: ! - ! Look up and return saturation vapor pressure from precomputed ! - ! table, then calculate and return saturation specific humidity. ! - ! Optionally return various temperature derivatives or enthalpy ! - ! at saturation. ! - !------------------------------------------------------------------! - - ! Inputs - real(r8), intent(in) :: t ! Temperature - real(r8), intent(in) :: p ! Pressure - ! Outputs - real(r8), intent(out) :: es ! Saturation vapor pressure - real(r8), intent(out) :: qs ! Saturation specific humidity - - real(r8), intent(out), optional :: gam ! (l/cpair)*(d(qs)/dt) - real(r8), intent(out), optional :: dqsdt ! (d(qs)/dt) - real(r8), intent(out), optional :: enthalpy ! cpair*t + hltalt*q - - ! Local variables - real(r8) :: hltalt ! Modified latent heat for T derivatives - real(r8) :: tterm ! Account for d(es)/dT in transition region - - es = estblf(t) - - qs = svp_to_qsat(es, p) - - ! Ensures returned es is consistent with limiters on qs. - es = min(es, p) - - ! Calculate optional arguments. - if (present(gam) .or. present(dqsdt) .or. present(enthalpy)) then - - ! "generalized" analytic expression for t derivative of es - ! accurate to within 1 percent for 173.16 < t < 373.16 - call calc_hltalt(t, hltalt, tterm) - - if (present(enthalpy)) enthalpy = tq_enthalpy(t, qs, hltalt) - - call deriv_outputs_line(t, p, es, qs, hltalt, tterm, & - gam=gam, dqsdt=dqsdt) - - end if - -end subroutine qsat_line - -subroutine qsat_vect(t, p, es, qs, vlen, gam, dqsdt, enthalpy) - !------------------------------------------------------------------! - ! Purpose: ! - ! Look up and return saturation vapor pressure from precomputed ! - ! table, then calculate and return saturation specific humidity. ! - ! Optionally return various temperature derivatives or enthalpy ! - ! at saturation. ! - !------------------------------------------------------------------! - - ! Inputs - integer, intent(in) :: vlen - real(r8), dimension(vlen), intent(in) :: t ! Temperature - real(r8), dimension(vlen), intent(in) :: p ! Pressure - ! Outputs - real(r8), dimension(vlen), intent(out) :: es ! Saturation vapor pressure - real(r8), dimension(vlen), intent(out) :: qs ! Saturation specific humidity - - real(r8), dimension(vlen), intent(out), optional :: gam ! (l/cpair)*(d(qs)/dt) - real(r8), dimension(vlen), intent(out), optional :: dqsdt ! (d(qs)/dt) - real(r8), dimension(vlen), intent(out), optional :: enthalpy ! cpair*t + hltalt*q - - ! Local variables - real(r8), dimension(vlen) :: hltalt ! Modified latent heat for T derivatives - real(r8), dimension(vlen) :: tterm ! Account for d(es)/dT in transition region - integer :: i - logical :: present_gam, present_dqsdt, present_enthalpy - - present_gam = present(gam) - present_dqsdt = present(dqsdt) - present_enthalpy = present(enthalpy) - - !$acc data copyin (t,p) & - !$acc copyout (es,qs,gam,dqsdt,enthalpy) & - !$acc create (hltalt,tterm) - - call estblf_vect(t, es, vlen) - - call svp_to_qsat_vect(es, p, qs, vlen) - - ! Ensures returned es is consistent with limiters on qs. - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - es(i) = min(es(i), p(i)) - end do - !$acc end parallel - - ! Calculate optional arguments. - if (present_gam .or. present_dqsdt .or. present_enthalpy) then - - ! "generalized" analytic expression for t derivative of es - ! accurate to within 1 percent for 173.16 < t < 373.16 - call calc_hltalt_vect(t, hltalt, vlen, tterm) - - if (present_enthalpy) call tq_enthalpy_vect(t, qs, hltalt, enthalpy, vlen) - - call deriv_outputs_vect(t, p, es, qs, hltalt, tterm, vlen, & - gam=gam, dqsdt=dqsdt) - - end if - - !$acc end data -end subroutine qsat_vect - -subroutine qsat_2D(t, p, es, qs, dim1, dim2, gam, dqsdt, enthalpy) - !------------------------------------------------------------------! - ! Purpose: ! - ! Look up and return saturation vapor pressure from precomputed ! - ! table, then calculate and return saturation specific humidity. ! - ! Optionally return various temperature derivatives or enthalpy ! - ! at saturation. ! - !------------------------------------------------------------------! - - ! Inputs - integer, intent(in) :: dim1, dim2 - real(r8), dimension(dim1,dim2), intent(in) :: t ! Temperature - real(r8), dimension(dim1,dim2), intent(in) :: p ! Pressure - ! Outputs - real(r8), dimension(dim1,dim2), intent(out) :: es ! Saturation vapor pressure - real(r8), dimension(dim1,dim2), intent(out) :: qs ! Saturation specific humidity - - real(r8), dimension(dim1,dim2), intent(out), optional :: gam ! (l/cpair)*(d(qs)/dt) - real(r8), dimension(dim1,dim2), intent(out), optional :: dqsdt ! (d(qs)/dt) - real(r8), dimension(dim1,dim2), intent(out), optional :: enthalpy ! cpair*t + hltalt*q - - ! Local variables - real(r8), dimension(dim1,dim2) :: hltalt ! Modified latent heat for T derivatives - real(r8), dimension(dim1,dim2) :: tterm ! Account for d(es)/dT in transition region - integer :: i, k, vlen - logical :: present_gam, present_dqsdt, present_enthalpy - - vlen = dim1 * dim2 - present_gam = present(gam) - present_dqsdt = present(dqsdt) - present_enthalpy = present(enthalpy) - - !$acc data copyin (t,p) & - !$acc copyout (es,qs,gam,dqsdt,enthalpy) & - !$acc create (hltalt,tterm) - - call estblf_vect(t, es, vlen) - - call svp_to_qsat_vect(es, p, qs, vlen) - - ! Ensures returned es is consistent with limiters on qs. - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector collapse(2) - do k = 1, dim2 - do i = 1, dim1 - es(i,k) = min(es(i,k), p(i,k)) - end do - end do - !$acc end parallel - - ! Calculate optional arguments. - if (present_gam .or. present_dqsdt .or. present_enthalpy) then - - ! "generalized" analytic expression for t derivative of es - ! accurate to within 1 percent for 173.16 < t < 373.16 - call calc_hltalt_vect(t, hltalt, vlen, tterm) - - if (present_enthalpy) call tq_enthalpy_vect(t, qs, hltalt, enthalpy, vlen) - - call deriv_outputs_vect(t, p, es, qs, hltalt, tterm, vlen, & - gam=gam, dqsdt=dqsdt) - - end if - - !$acc end data -end subroutine qsat_2D - -subroutine qsat_water_line(t, p, es, qs, gam, dqsdt, enthalpy) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over water at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - ! Optionally return various temperature derivatives or enthalpy ! - ! at saturation. ! - !------------------------------------------------------------------! - - use wv_sat_methods, only: wv_sat_qsat_water - - ! Inputs - real(r8), intent(in) :: t ! Temperature - real(r8), intent(in) :: p ! Pressure - ! Outputs - real(r8), intent(out) :: es ! Saturation vapor pressure - real(r8), intent(out) :: qs ! Saturation specific humidity - - real(r8), intent(out), optional :: gam ! (l/cpair)*(d(qs)/dt) - real(r8), intent(out), optional :: dqsdt ! (d(qs)/dt) - real(r8), intent(out), optional :: enthalpy ! cpair*t + hltalt*q - - ! Local variables - real(r8) :: hltalt ! Modified latent heat for T derivatives - - call wv_sat_qsat_water(t, p, es, qs) - - if (present(gam) .or. present(dqsdt) .or. present(enthalpy)) then - - ! "generalized" analytic expression for t derivative of es - ! accurate to within 1 percent for 173.16 < t < 373.16 - call no_ip_hltalt(t, hltalt) - - if (present(enthalpy)) enthalpy = tq_enthalpy(t, qs, hltalt) - - ! For pure water/ice transition term is 0. - call deriv_outputs_line(t, p, es, qs, hltalt, 0._r8, & - gam=gam, dqsdt=dqsdt) - - end if - -end subroutine qsat_water_line - -subroutine qsat_water_vect(t, p, es, qs, vlen, gam, dqsdt, enthalpy) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over water at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - ! Optionally return various temperature derivatives or enthalpy ! - ! at saturation. ! - !------------------------------------------------------------------! - - use wv_sat_methods, only: wv_sat_qsat_water_vect - - ! Inputs - integer, intent(in) :: vlen - real(r8), dimension(vlen), intent(in) :: t ! Temperature - real(r8), dimension(vlen), intent(in) :: p ! Pressure - ! Outputs - real(r8), dimension(vlen), intent(out) :: es ! Saturation vapor pressure - real(r8), dimension(vlen), intent(out) :: qs ! Saturation specific humidity - - real(r8), dimension(vlen), intent(out), optional :: gam ! (l/cpair)*(d(qs)/dt) - real(r8), dimension(vlen), intent(out), optional :: dqsdt ! (d(qs)/dt) - real(r8), dimension(vlen), intent(out), optional :: enthalpy ! cpair*t + hltalt*q - - ! Local variables - real(r8), dimension(vlen) :: hltalt ! Modified latent heat for T derivatives - real(r8), dimension(vlen) :: tterm - integer :: i - logical :: present_gam, present_dqsdt, present_enthalpy - - present_gam = present(gam) - present_dqsdt = present(dqsdt) - present_enthalpy = present(enthalpy) - - !$acc data copyin (t,p) & - !$acc copyout (es,qs,gam,dqsdt,enthalpy) & - !$acc create (tterm,hltalt) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - tterm(i) = 0._r8 - end do - !$acc end parallel - - call wv_sat_qsat_water_vect(t, p, es, qs, vlen) - - if (present_gam .or. present_dqsdt .or. present_enthalpy) then - - ! "generalized" analytic expression for t derivative of es - ! accurate to within 1 percent for 173.16 < t < 373.16 - call no_ip_hltalt_vect(t, hltalt, vlen) - - if (present_enthalpy) call tq_enthalpy_vect(t, qs, hltalt, enthalpy, vlen) - - ! For pure water/ice transition term is 0. - call deriv_outputs_vect(t, p, es, qs, hltalt, tterm, vlen, & - gam=gam, dqsdt=dqsdt) - - end if - - !$acc end data -end subroutine qsat_water_vect - -subroutine qsat_water_2D(t, p, es, qs, dim1, dim2, gam, dqsdt, enthalpy) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over water at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - ! Optionally return various temperature derivatives or enthalpy ! - ! at saturation. ! - !------------------------------------------------------------------! - - use wv_sat_methods, only: wv_sat_qsat_water_vect - - ! Inputs - integer, intent(in) :: dim1, dim2 - real(r8), dimension(dim1,dim2), intent(in) :: t ! Temperature - real(r8), dimension(dim1,dim2), intent(in) :: p ! Pressure - ! Outputs - real(r8), dimension(dim1,dim2), intent(out) :: es ! Saturation vapor pressure - real(r8), dimension(dim1,dim2), intent(out) :: qs ! Saturation specific humidity - - real(r8), dimension(dim1,dim2), intent(out), optional :: gam ! (l/cpair)*(d(qs)/dt) - real(r8), dimension(dim1,dim2), intent(out), optional :: dqsdt ! (d(qs)/dt) - real(r8), dimension(dim1,dim2), intent(out), optional :: enthalpy ! cpair*t + hltalt*q - - ! Local variables - real(r8), dimension(dim1,dim2) :: hltalt ! Modified latent heat for T derivatives - real(r8), dimension(dim1,dim2) :: tterm - integer :: i, k, vlen - logical :: present_gam, present_dqsdt, present_enthalpy - - vlen = dim1 * dim2 - present_gam = present(gam) - present_dqsdt = present(dqsdt) - present_enthalpy = present(enthalpy) - - !$acc data copyin (t,p) & - !$acc copyout (es,qs,gam,dqsdt,enthalpy) & - !$acc create (hltalt,tterm) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector collapse(2) - do k = 1, dim2 - do i = 1, dim1 - tterm(i,k) = 0._r8 - end do - end do - !$acc end parallel - - call wv_sat_qsat_water_vect(t, p, es, qs, vlen) - - if (present_gam .or. present_dqsdt .or. present_enthalpy) then - - ! "generalized" analytic expression for t derivative of es - ! accurate to within 1 percent for 173.16 < t < 373.16 - call no_ip_hltalt_vect(t, hltalt, vlen) - - if (present_enthalpy) call tq_enthalpy_vect(t, qs, hltalt, enthalpy, vlen) - - ! For pure water/ice transition term is 0. - call deriv_outputs_vect(t, p, es, qs, hltalt, tterm, vlen, & - gam=gam, dqsdt=dqsdt) - - end if - - !$acc end data -end subroutine qsat_water_2D - -subroutine qsat_ice_line(t, p, es, qs, gam, dqsdt, enthalpy) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over ice at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - ! Optionally return various temperature derivatives or enthalpy ! - ! at saturation. ! - !------------------------------------------------------------------! - - use wv_sat_methods, only: wv_sat_qsat_ice - - ! Inputs - real(r8), intent(in) :: t ! Temperature - real(r8), intent(in) :: p ! Pressure - ! Outputs - real(r8), intent(out) :: es ! Saturation vapor pressure - real(r8), intent(out) :: qs ! Saturation specific humidity - - real(r8), intent(out), optional :: gam ! (l/cpair)*(d(qs)/dt) - real(r8), intent(out), optional :: dqsdt ! (d(qs)/dt) - real(r8), intent(out), optional :: enthalpy ! cpair*t + hltalt*q - - ! Local variables - real(r8) :: hltalt ! Modified latent heat for T derivatives - - call wv_sat_qsat_ice(t, p, es, qs) - - if (present(gam) .or. present(dqsdt) .or. present(enthalpy)) then - - ! For pure ice, just add latent heats. - hltalt = latvap + latice - - if (present(enthalpy)) enthalpy = tq_enthalpy(t, qs, hltalt) - - ! For pure water/ice transition term is 0. - call deriv_outputs_line(t, p, es, qs, hltalt, 0._r8, & - gam=gam, dqsdt=dqsdt) - - end if - -end subroutine qsat_ice_line - -subroutine qsat_ice_vect(t, p, es, qs, vlen, gam, dqsdt, enthalpy) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over ice at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - ! Optionally return various temperature derivatives or enthalpy ! - ! at saturation. ! - !------------------------------------------------------------------! - - use wv_sat_methods, only: wv_sat_qsat_ice_vect - - ! Inputs - integer, intent(in) :: vlen - real(r8), dimension(vlen), intent(in) :: t ! Temperature - real(r8), dimension(vlen), intent(in) :: p ! Pressure - ! Outputs - real(r8), dimension(vlen), intent(out) :: es ! Saturation vapor pressure - real(r8), dimension(vlen), intent(out) :: qs ! Saturation specific humidity - - real(r8), dimension(vlen), intent(out), optional :: gam ! (l/cpair)*(d(qs)/dt) - real(r8), dimension(vlen), intent(out), optional :: dqsdt ! (d(qs)/dt) - real(r8), dimension(vlen), intent(out), optional :: enthalpy ! cpair*t + hltalt*q - - ! Local variables - real(r8), dimension(vlen) :: hltalt ! Modified latent heat for T derivatives - real(r8), dimension(vlen) :: tterm - integer :: i - logical :: present_gam, present_dqsdt, present_enthalpy - - present_gam = present(gam) - present_dqsdt = present(dqsdt) - present_enthalpy = present(enthalpy) - - !$acc data copyin (t,p) & - !$acc copyout (es,qs,gam,dqsdt,enthalpy) & - !$acc create (hltalt,tterm) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - tterm(i) = 0._r8 - end do - !$acc end parallel - - call wv_sat_qsat_ice_vect(t, p, es, qs, vlen) - - if (present_gam .or. present_dqsdt .or. present_enthalpy) then - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector - do i = 1, vlen - ! For pure ice, just add latent heats. - hltalt(i) = latvap + latice - end do - !$acc end parallel - - if (present_enthalpy) call tq_enthalpy_vect(t, qs, hltalt, enthalpy, vlen) - - ! For pure water/ice transition term is 0. - call deriv_outputs_vect(t, p, es, qs, hltalt, tterm, vlen, & - gam=gam, dqsdt=dqsdt) - - end if - - !$acc end data -end subroutine qsat_ice_vect - -subroutine qsat_ice_2D(t, p, es, qs, dim1, dim2, gam, dqsdt, enthalpy) - !------------------------------------------------------------------! - ! Purpose: ! - ! Calculate SVP over ice at a given temperature, and then ! - ! calculate and return saturation specific humidity. ! - ! Optionally return various temperature derivatives or enthalpy ! - ! at saturation. ! - !------------------------------------------------------------------! - - use wv_sat_methods, only: wv_sat_qsat_ice_vect - - ! Inputs - integer, intent(in) :: dim1, dim2 - real(r8), dimension(dim1,dim2), intent(in) :: t ! Temperature - real(r8), dimension(dim1,dim2), intent(in) :: p ! Pressure - ! Outputs - real(r8), dimension(dim1,dim2), intent(out) :: es ! Saturation vapor pressure - real(r8), dimension(dim1,dim2), intent(out) :: qs ! Saturation specific humidity - - real(r8), dimension(dim1,dim2), intent(out), optional :: gam ! (l/cpair)*(d(qs)/dt) - real(r8), dimension(dim1,dim2), intent(out), optional :: dqsdt ! (d(qs)/dt) - real(r8), dimension(dim1,dim2), intent(out), optional :: enthalpy ! cpair*t + hltalt*q - - ! Local variables - real(r8), dimension(dim1,dim2) :: hltalt ! Modified latent heat for T derivatives - real(r8), dimension(dim1,dim2) :: tterm - integer :: i, k, vlen - logical :: present_gam, present_dqsdt, present_enthalpy - - vlen = dim1 * dim2 - present_gam = present(gam) - present_dqsdt = present(dqsdt) - present_enthalpy = present(enthalpy) - - !$acc data copyin (t,p) & - !$acc copyout (es,qs,gam,dqsdt,enthalpy) & - !$acc create (hltalt,tterm) - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector collapse(2) - do k = 1, dim2 - do i = 1, dim1 - tterm(i,k) = 0._r8 - end do - end do - !$acc end parallel - - call wv_sat_qsat_ice_vect(t, p, es, qs, vlen) - - if (present_gam .or. present_dqsdt .or. present_enthalpy) then - - !$acc parallel vector_length(VLENS) default(present) - !$acc loop gang vector collapse(2) - do k = 1, dim2 - do i = 1, dim1 - ! For pure ice, just add latent heats. - hltalt(i,k) = latvap + latice - end do - end do - !$acc end parallel - - if (present_enthalpy) call tq_enthalpy_vect(t, qs, hltalt, enthalpy, vlen) - - ! For pure water/ice transition term is 0. - call deriv_outputs_vect(t, p, es, qs, hltalt, tterm, vlen, & - gam=gam, dqsdt=dqsdt) - - end if - - !$acc end data -end subroutine qsat_ice_2D - -!--------------------------------------------------------------------- -! FINDSP (WET BULB TEMPERATURE) PROCEDURES -!--------------------------------------------------------------------- - -subroutine findsp_vc(q, t, p, use_ice, tsp, qsp) - - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - - ! Wrapper for findsp which is 1D and handles the output status. - ! Changing findsp to elemental restricted debugging output. - ! If that output is needed again, it's preferable *not* to copy findsp, - ! but to change the existing version. - - ! input arguments - real(r8), intent(in) :: q(:) ! water vapor (kg/kg) - real(r8), intent(in) :: t(:) ! temperature (K) - real(r8), intent(in) :: p(:) ! pressure (Pa) - logical, intent(in) :: use_ice ! flag to include ice phase in calculations - - ! output arguments - real(r8), intent(out) :: tsp(:) ! saturation temp (K) - real(r8), intent(out) :: qsp(:) ! saturation mixing ratio (kg/kg) - - integer :: status(size(q)) ! flag representing state of output - ! 0 => Successful convergence - ! 1 => No calculation done: pressure or specific - ! humidity not within usable range - ! 2 => Run failed to converge - ! 4 => Temperature fell below minimum - ! 8 => Enthalpy not conserved - - integer :: n, i - - n = size(q) - - ! Currently, only 2 and 8 seem to be treated as fatal errors. - do i = 1,n - call findsp(q(i), t(i), p(i), use_ice, tsp(i), qsp(i), status(i)) - if (status(i) == 2) then - write(iulog,*) ' findsp not converging at i = ', i - write(iulog,*) ' t, q, p ', t(i), q(i), p(i) - write(iulog,*) ' tsp, qsp ', tsp(i), qsp(i) - call endrun ('wv_saturation::FINDSP -- not converging') - else if (status(i) == 8) then - write(iulog,*) ' the enthalpy is not conserved at i = ', i - write(iulog,*) ' t, q, p ', t(i), q(i), p(i) - write(iulog,*) ' tsp, qsp ', tsp(i), qsp(i) - call endrun ('wv_saturation::FINDSP -- enthalpy is not conserved') - endif - end do - -end subroutine findsp_vc - -subroutine findsp (q, t, p, use_ice, tsp, qsp, status) -!----------------------------------------------------------------------- -! -! Purpose: -! find the wet bulb temperature for a given t and q -! in a longitude height section -! wet bulb temp is the temperature and spec humidity that is -! just saturated and has the same enthalpy -! if q > qs(t) then tsp > t and qsp = qs(tsp) < q -! if q < qs(t) then tsp < t and qsp = qs(tsp) > q -! -! Method: -! a Newton method is used -! first guess uses an algorithm provided by John Petch from the UKMO -! we exclude points where the physical situation is unrealistic -! e.g. where the temperature is outside the range of validity for the -! saturation vapor pressure, or where the water vapor pressure -! exceeds the ambient pressure, or the saturation specific humidity is -! unrealistic -! -! Author: P. Rasch -! -!----------------------------------------------------------------------- -! -! input arguments -! - - real(r8), intent(in) :: q ! water vapor (kg/kg) - real(r8), intent(in) :: t ! temperature (K) - real(r8), intent(in) :: p ! pressure (Pa) - logical, intent(in) :: use_ice ! flag to include ice phase in calculations -! -! output arguments -! - real(r8), intent(out) :: tsp ! saturation temp (K) - real(r8), intent(out) :: qsp ! saturation mixing ratio (kg/kg) - integer, intent(out) :: status ! flag representing state of output - ! 0 => Successful convergence - ! 1 => No calculation done: pressure or specific - ! humidity not within usable range - ! 2 => Run failed to converge - ! 4 => Temperature fell below minimum - ! 8 => Enthalpy not conserved -! -! local variables -! - integer, parameter :: iter = 8 ! max number of times to iterate the calculation - integer :: l ! iterator - - real(r8) es ! sat. vapor pressure - real(r8) gam ! change in sat spec. hum. wrt temperature (times hltalt/cpair) - real(r8) dgdt ! work variable - real(r8) g ! work variable - real(r8) hltalt ! lat. heat. of vap. - real(r8) qs ! spec. hum. of water vapor - -! work variables - real(r8) t1, q1, dt, dq - real(r8) qvd - real(r8) r1b, c1, c2 - real(r8), parameter :: dttol = 1.e-4_r8 ! the relative temp error tolerance required to quit the iteration - real(r8), parameter :: dqtol = 1.e-4_r8 ! the relative moisture error tolerance required to quit the iteration - real(r8) enin, enout - - ! Saturation specific humidity at this temperature - if (use_ice) then - call qsat(t, p, es, qs) - else - call qsat_water(t, p, es, qs) - end if - - ! make sure a meaningful calculation is possible - if (p <= 5._r8*es .or. qs <= 0._r8 .or. qs >= 0.5_r8 & - .or. t < tmin .or. t > tmax) then - status = 1 - ! Keep initial parameters when conditions aren't suitable - tsp = t - qsp = q - enin = 1._r8 - enout = 1._r8 - - return - end if - - ! Prepare to iterate - status = 2 - - ! Get initial enthalpy - if (use_ice) then - call calc_hltalt(t,hltalt) - else - call no_ip_hltalt(t,hltalt) - end if - enin = tq_enthalpy(t, q, hltalt) - - ! make a guess at the wet bulb temp using a UKMO algorithm (from J. Petch) - c1 = hltalt*c3 - c2 = (t + 36._r8)**2 - r1b = c2/(c2 + c1*qs) - qvd = r1b * (q - qs) - tsp = t + ((hltalt/cpair)*qvd) - - ! Generate qsp, gam, and enout from tsp. - if (use_ice) then - call qsat(tsp, p, es, qsp, gam=gam, enthalpy=enout) - else - call qsat_water(tsp, p, es, qsp, gam=gam, enthalpy=enout) - end if - - ! iterate on first guess - do l = 1, iter - - g = enin - enout - dgdt = -cpair * (1 + gam) - - ! New tsp - t1 = tsp - g/dgdt - dt = abs(t1 - tsp)/t1 - tsp = t1 - - ! bail out if past end of temperature range - if ( tsp < tmin ) then - tsp = tmin - ! Get latent heat and set qsp to a value - ! that preserves enthalpy. - if (use_ice) then - call calc_hltalt(tsp,hltalt) - else - call no_ip_hltalt(tsp,hltalt) - end if - qsp = (enin - cpair*tsp)/hltalt - enout = tq_enthalpy(tsp, qsp, hltalt) - status = 4 - exit - end if - - ! Re-generate qsp, gam, and enout from new tsp. - if (use_ice) then - call qsat(tsp, p, es, q1, gam=gam, enthalpy=enout) - else - call qsat_water(tsp, p, es, q1, gam=gam, enthalpy=enout) - end if - dq = abs(q1 - qsp)/max(q1,1.e-12_r8) - qsp = q1 - - ! if converged at this point, exclude it from more iterations - if (dt < dttol .and. dq < dqtol) then - status = 0 - exit - endif - end do - - ! Test for enthalpy conservation - if (abs((enin-enout)/(enin+enout)) > 1.e-4_r8) status = 8 - -end subroutine findsp - -end module wv_saturation diff --git a/src/physics/cam/zm_conv_intr.F90 b/src/physics/cam/zm_conv_intr.F90 index 5db6d1bc03..44488ac737 100644 --- a/src/physics/cam/zm_conv_intr.F90 +++ b/src/physics/cam/zm_conv_intr.F90 @@ -14,6 +14,7 @@ module zm_conv_intr use zm_convr, only: zm_convr_init, zm_convr_run use zm_conv_convtran, only: zm_conv_convtran_run use zm_conv_momtran, only: zm_conv_momtran_run + use cloud_fraction_fice, only: cloud_fraction_fice_run 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 !, & @@ -23,6 +24,8 @@ module zm_conv_intr use perf_mod use cam_logfile, only: iulog use constituents, only: cnst_add + use ref_pres, only: trop_cloud_top_lev + use phys_control, only: phys_getopts implicit none private @@ -37,7 +40,7 @@ module zm_conv_intr zm_conv_tend, &! return tendencies zm_conv_tend_2 ! return tendencies - public zmconv_ke, zmconv_ke_lnd, zmconv_org ! needed by convect_shallow + public zmconv_ke, zmconv_ke_lnd ! needed by convect_shallow integer ::& ! indices for fields in the physics buffer zm_mu_idx, & @@ -52,11 +55,9 @@ module zm_conv_intr zm_ideep_idx, & dp_flxprc_idx, & dp_flxsnw_idx, & - ixorg, & + dp_cldliq_idx, & + 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, & mconzm_idx ! convective mass flux @@ -70,8 +71,6 @@ module zm_conv_intr 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) real(r8) :: zmconv_dmpdz = unset_r8 ! Parcel fractional mass entrainment rate real(r8) :: zmconv_tiedke_add = unset_r8 ! Convective parcel temperature perturbation real(r8) :: zmconv_capelmt = unset_r8 ! Triggering thereshold for ZM convection @@ -141,15 +140,9 @@ subroutine zm_conv_register ! 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) ! convective mass fluxes call pbuf_add_field('CMFMC_DP', 'physpkg', dtype_r8, (/pcols,pverp/), mconzm_idx) -!CACNOTE - Is zm_org really a constituent or was it just a handy structure to use for an allocatable which persists in the run? - 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 @@ -159,7 +152,6 @@ 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 @@ -168,15 +160,14 @@ subroutine zm_conv_readnl(nlfile) 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_ke, zmconv_ke_lnd, & zmconv_momcu, zmconv_momcd, & zmconv_dmpdz, zmconv_tiedke_add, zmconv_capelmt, & zmconv_parcel_pbl, zmconv_tau !----------------------------------------------------------------------------- if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) + open( newunit=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) @@ -185,7 +176,6 @@ subroutine zm_conv_readnl(nlfile) end if end if close(unitn) - call freeunit(unitn) end if @@ -204,8 +194,6 @@ subroutine zm_conv_readnl(nlfile) 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_dmpdz, 1, mpi_real8, masterprocid, mpicom, ierr) if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_dmpdz") call mpi_bcast(zmconv_tiedke_add, 1, mpi_real8, masterprocid, mpicom, ierr) @@ -260,10 +248,6 @@ subroutine zm_conv_init(pref_edge) ! 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') @@ -306,16 +290,11 @@ subroutine zm_conv_init(pref_edge) 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') 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, ' ') @@ -362,14 +341,17 @@ subroutine zm_conv_init(pref_edge) end if no_deep_pbl = phys_deepconv_pbl() -!CACNOTE - Need to check errflg and report errors - call zm_convr_init(cpair, epsilo, gravit, latvap, tmelt, rair, & - limcnv,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & - zmconv_momcu, zmconv_momcd, zmconv_num_cin, zmconv_org, & + call zm_convr_init(plev, plevp, cpair, epsilo, gravit, latvap, tmelt, rair, & + pref_edge,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & + zmconv_momcu, zmconv_momcd, zmconv_num_cin, & no_deep_pbl, zmconv_tiedke_add, & zmconv_capelmt, zmconv_dmpdz,zmconv_parcel_pbl, zmconv_tau, & masterproc, iulog, errmsg, errflg) + if (errflg /= 0) then + call endrun('From zm_convr_init:' // errmsg) + end if + cld_idx = pbuf_get_index('CLD') fracis_idx = pbuf_get_index('FRACIS') @@ -394,8 +376,10 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & 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 physconst, only: gravit, latice, latvap, tmelt, cpwv, cpliq, rh2o + use phys_grid, only: get_rlat_all_p, get_rlon_all_p use phys_control, only: cam_physpkg_is + use ccpp_constituent_prop_mod, only: ccpp_const_props ! Arguments @@ -451,9 +435,6 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & 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 :: 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 :: mconzm(:,:) !convective mass fluxes @@ -475,10 +456,13 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & real(r8) :: pcont(pcols), pconb(pcols), freqzm(pcols) + real(r8) :: lat_all(pcols), long_all(pcols) + ! history output fields real(r8) :: cape(pcols) ! w convective available potential energy. real(r8) :: mu_out(pcols,pver) real(r8) :: md_out(pcols,pver) + real(r8) :: dif(pcols,pver) ! used in momentum transport calculation real(r8) :: pguallu(pcols, pver) @@ -490,17 +474,18 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & real(r8) :: icwdu(pcols,pver) real(r8) :: icwdv(pcols,pver) real(r8) :: seten(pcols, pver) - logical :: l_windt(2) + logical :: l_windt real(r8) :: tfinal1, tfinal2 integer :: ii - real(r8),pointer :: zm_org2d(:,:) - real(r8),allocatable :: orgt_alloc(:,:), org_alloc(:,:) - - real(r8) :: zm_org2d_ncol(state%ncol,pver) - real(r8) :: orgt_ncol(state%ncol,pver), org_ncol(state%ncol,pver) + real(r8) :: fice(pcols,pver) + real(r8) :: fsnow_conv(pcols,pver) logical :: lq(pcnst) + character(len=16) :: macrop_scheme + character(len=40) :: scheme_name + character(len=40) :: str + integer :: top_lev !---------------------------------------------------------------------- @@ -517,9 +502,6 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & lq(:) = .FALSE. lq(1) = .TRUE. - if (zmconv_org) then - lq(ixorg) = .TRUE. - endif call physics_ptend_init(ptend_loc, state%psetcols, 'zm_convr_run', ls=.true., lq=lq)! initialize local ptend type ! @@ -547,35 +529,22 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & 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) call pbuf_get_field(pbuf, mconzm_idx, mconzm) - allocate(dnlf(pcols,pver), dnif(pcols,pver)) - -! ! Begin with Zhang-McFarlane (1996) convection parameterization ! call t_startf ('zm_convr_run') - if (zmconv_org) then - allocate(zm_org2d(pcols,pver)) - allocate(org_alloc(ncol,pver)) - allocate(orgt_alloc(ncol,pver)) - org_ncol(:ncol,:) = state%q(1:ncol,:,ixorg) - endif - !REMOVECAM - no longer need these when CAM is retired and pcols no longer exists ptend_loc%q(:,:,1) = 0._r8 ptend_loc%s(:,:) = 0._r8 + dif(:,:) = 0._r8 mcon(:,:) = 0._r8 dlf(:,:) = 0._r8 cme(:,:) = 0._r8 cape(:) = 0._r8 zdu(:,:) = 0._r8 rprd(:,:) = 0._r8 - dif(:,:) = 0._r8 - dnlf(:,:) = 0._r8 - dnif(:,:) = 0._r8 mu(:,:) = 0._r8 eu(:,:) = 0._r8 du(:,:) = 0._r8 @@ -591,29 +560,27 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ideep(:) = 0._r8 !REMOVECAM_END -!CACNOTE - Need to check errflg and report errors + + call get_rlat_all_p(lchnk, ncol, lat_all) + call get_rlon_all_p(lchnk, ncol, long_all) + call zm_convr_run(ncol, pver, & pverp, gravit, latice, cpwv, cpliq, rh2o, & + lat_all, long_all, & state%t(:ncol,:), state%q(:ncol,:,1), prec(:ncol), & pblh(:ncol), state%zm(:ncol,:), state%phis(:ncol), state%zi(:ncol,:), ptend_loc%q(:ncol,:,1), & ptend_loc%s(:ncol,:), state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), & ztodt, mcon(:ncol,:), cme(:ncol,:), cape(:ncol), & - tpert(:ncol), dlf(:ncol,:), zdu(:ncol,:), rprd(:ncol,:), & + tpert(:ncol), dlf(:ncol,:), dif(:ncol,:), zdu(:ncol,:), rprd(:ncol,:), & mu(:ncol,:), md(:ncol,:), du(:ncol,:), eu(:ncol,:), ed(:ncol,:), & dp(:ncol,:), dsubcld(:ncol), jt(:ncol), maxg(:ncol), ideep(:ncol), & ql(:ncol,:), rliq(:ncol), landfrac(:ncol), & - org_ncol(:ncol,:), orgt_ncol(:ncol,:), zm_org2d_ncol(:ncol,:), & - dif(:ncol,:), dnlf(:ncol,:), dnif(:ncol,:), & - rice(:ncol), errmsg, errflg) + rice(:ncol), lengath, scheme_name, errmsg, errflg) - - if (zmconv_org) then - ptend_loc%q(:,:,ixorg)=orgt_ncol(:ncol,:) - zm_org2d(:ncol,:) = zm_org2d_ncol(:ncol,:) - endif - - lengath = count(ideep > 0) - if (lengath > ncol) lengath = ncol ! should not happen, but force it to not be larger than ncol for safety sake + if (errflg /= 0) then + write(str,*) 'From zm_convr_run: at chunk ',lchnk, ' : ' + call endrun(str // errmsg) + end if jctop(:) = real(pver,r8) jcbot(:) = 1._r8 @@ -657,7 +624,6 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call outfld('ZMDQ ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) call t_stopf ('zm_convr_run') - call outfld('DIFZM' ,dif ,pcols, lchnk) call outfld('DLFZM' ,dlf ,pcols, lchnk) pcont(:ncol) = state%ps(:ncol) @@ -683,9 +649,6 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ! 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_run', ls=.true., lq=lq) call t_startf ('zm_conv_evap_run') @@ -702,25 +665,28 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & flxprec(:,:) = 0._r8 flxsnow(:,:) = 0._r8 snow(:) = 0._r8 + fice(:,:) = 0._r8 + fsnow_conv(:,:) = 0._r8 !REMOVECAM_END + top_lev = 1 + call phys_getopts (macrop_scheme_out = macrop_scheme) + if ( .not. (macrop_scheme == "rk" .or. macrop_scheme == "SPCAM_sam1mom")) top_lev = trop_cloud_top_lev + + call cloud_fraction_fice_run(ncol, state1%t(:ncol,:), tmelt, top_lev, pver, fice(:ncol,:), fsnow_conv(:ncol,:)) + call zm_conv_evap_run(state1%ncol, pver, pverp, & gravit, latice, latvap, tmelt, & - cpair, zmconv_ke, zmconv_ke_lnd, zmconv_org, & + cpair, zmconv_ke, zmconv_ke_lnd, & state1%t(:ncol,:),state1%pmid(:ncol,:),state1%pdel(:ncol,:),state1%q(:ncol,:pver,1), & landfrac(:ncol), & ptend_loc%s(:ncol,:), tend_s_snwprd(:ncol,:), tend_s_snwevmlt(:ncol,:), ptend_loc%q(:ncol,:pver,1), & rprd(:ncol,:), cld(:ncol,:), ztodt, & - prec(:ncol), snow(:ncol), ntprprd(:ncol,:), ntsnprd(:ncol,:), flxprec(:ncol,:), flxsnow(:ncol,:) ) + prec(:ncol), snow(:ncol), ntprprd(:ncol,:), ntsnprd(:ncol,:), fsnow_conv(:ncol,:), flxprec(:ncol,:), flxsnow(:ncol,:),& + scheme_name, errmsg, errflg) 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_run ! @@ -755,8 +721,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_momtran_run', ls=.true., lu=.true., lv=.true.) - l_windt(1) = .true. - l_windt(2) = .true. + l_windt = .true. !REMOVECAM - no longer need these when CAM is retired and pcols no longer exists ptend_loc%s(:,:) = 0._r8 ptend_loc%u(:,:) = 0._r8 @@ -765,15 +730,16 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call t_startf ('zm_conv_momtran_run') - call zm_conv_momtran_run (ncol, pver, pverp, & - l_windt,state1%u(:ncol,:), state1%v(:ncol,:), 2, mu(:ncol,:), md(:ncol,:), & + call zm_conv_momtran_run (ncol, pver, pverp, & + l_windt,state1%u(:ncol,:), state1%v(:ncol,:), mu(:ncol,:), md(:ncol,:), & zmconv_momcu, zmconv_momcd, & du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & nstep, ptend_loc%u(:ncol,:), ptend_loc%v(:ncol,:),& pguallu(:ncol,:), pguallv(:ncol,:), pgdallu(:ncol,:), pgdallv(:ncol,:), & - icwuu(:ncol,:), icwuv(:ncol,:), icwdu(:ncol,:), icwdv(:ncol,:), ztodt, seten(:ncol,:) ) - call t_stopf ('zm_conv_momtran_run') + icwuu(:ncol,:), icwuv(:ncol,:), icwdu(:ncol,:), icwdv(:ncol,:), ztodt, seten(:ncol,:), & + scheme_name, errmsg, errflg) + call t_stopf ('zm_conv_momtran_run') ptend_loc%s(:ncol,:pver) = seten(:ncol,:pver) @@ -786,12 +752,8 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ! 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) + ftem(:ncol,:pver) = seten(:ncol,:pver)/cpair + call outfld('ZMMTT', ftem , pcols, lchnk) ! Output apparent force from pressure gradient call outfld('ZMUPGU', pguallu, pcols, lchnk) @@ -828,7 +790,8 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ptend_loc%lq,state1%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, fracis(:ncol,:,:), ptend_loc%q(:ncol,:,:), fake_dpdry(:ncol,:)) + nstep, fracis(:ncol,:,:), ptend_loc%q(:ncol,:,:), fake_dpdry(:ncol,:), ccpp_const_props, & + scheme_name, errmsg, errflg) call t_stopf ('convtran1') call outfld('ZMDICE ',ptend_loc%q(1,1,ixcldice) ,pcols ,lchnk ) @@ -840,11 +803,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call physics_state_dealloc(state1) call physics_ptend_dealloc(ptend_loc) - if (zmconv_org) then - deallocate(zm_org2d) - end if - deallocate(dnlf, dnif) end subroutine zm_conv_tend !========================================================================================= @@ -856,6 +815,8 @@ subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) 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 + use ccpp_constituent_prop_mod, only: ccpp_const_props + ! Arguments type(physics_state), intent(in ) :: state ! Physics state variables @@ -885,6 +846,11 @@ subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) integer, pointer :: jt(:) ! (pcols) integer, pointer :: maxg(:) ! (pcols) integer, pointer :: ideep(:) ! (pcols) + + character(len=40) :: scheme_name + character(len=512) :: errmsg + integer :: errflg + !----------------------------------------------------------------------------------- @@ -928,7 +894,13 @@ subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) ptend%lq,state%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:)) + nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:), ccpp_const_props, & + scheme_name, errmsg, errflg) + + if (errflg /= 0) then + call endrun('From zm_conv_convtran_run:' // errmsg) + end if + call t_stopf ('convtran2') end if diff --git a/src/physics/cam7/physpkg.F90 b/src/physics/cam7/physpkg.F90 index 160bd86764..43b55137f9 100644 --- a/src/physics/cam7/physpkg.F90 +++ b/src/physics/cam7/physpkg.F90 @@ -785,6 +785,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! local variables integer :: lchnk integer :: ierr + integer :: ixq logical :: history_budget ! output tendencies and state variables for ! temperature, water vapor, cloud @@ -955,7 +956,8 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! Initialize CAM CCPP constituent properties array ! for use in CCPP-ized physics schemes: - call ccpp_const_props_init() + call cnst_get_ind('Q', ixq) + call ccpp_const_props_init(ixq) ! Initialize qneg3 and qneg4 call qneg_init() diff --git a/src/physics/rrtmgp/rad_solar_var.F90 b/src/physics/rrtmgp/rad_solar_var.F90 new file mode 100644 index 0000000000..ab608db7f9 --- /dev/null +++ b/src/physics/rrtmgp/rad_solar_var.F90 @@ -0,0 +1,149 @@ +!------------------------------------------------------------------------------- +! This module uses the solar irradiance data +! to provide a spectral scaling factor +! to approximate the spectral distribution of irradiance +! when the radiation scheme might use a different solar source function +!------------------------------------------------------------------------------- +module rad_solar_var + + use shr_kind_mod , only : r8 => shr_kind_r8 + use radconstants, only : nswbands, get_sw_spectral_boundaries, band2gpt_sw + use solar_irrad_data, only : sol_irrad, we, nbins, has_spectrum, sol_tsi + use solar_irrad_data, only : do_spctrl_scaling + use cam_abortutils, only : endrun + use error_messages, only : alloc_err + + implicit none + save + + private + public :: rad_solar_var_init + public :: get_variability + + real(r8), allocatable :: irrad(:) ! solar irradiance at model timestep in each band + + real(r8), allocatable :: radbinmax(:) + real(r8), allocatable :: radbinmin(:) + +!------------------------------------------------------------------------------- +contains +!------------------------------------------------------------------------------- + + subroutine rad_solar_var_init( ) + + integer :: ierr + integer :: radmax_loc + + if ( do_spctrl_scaling ) then + + if ( .not.has_spectrum ) then + call endrun('rad_solar_var_init: solar input file must have irradiance spectrum') + endif + + allocate (radbinmax(nswbands),stat=ierr) + if (ierr /= 0) then + call endrun('rad_solar_var_init: Error allocating space for radbinmax') + end if + + allocate (radbinmin(nswbands),stat=ierr) + if (ierr /= 0) then + call endrun('rad_solar_var_init: Error allocating space for radbinmin') + end if + + allocate (irrad(nswbands), stat=ierr) + if (ierr /= 0) then + call endrun('rad_solar_var_init: Error allocating space for irrad') + end if + + call get_sw_spectral_boundaries(radbinmin, radbinmax, 'nm') + + ! Make sure that the far-IR is included, even if radiation grid does not + ! extend that far down. 10^5 nm corresponds to a wavenumber of + ! 100 cm^-1. + radmax_loc = maxloc(radbinmax,1) + radbinmax(radmax_loc) = max(100000._r8,radbinmax(radmax_loc)) + + endif + + end subroutine rad_solar_var_init + +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- + + subroutine get_variability(toa_flux, sfac) + + ! Arguments + real(r8), intent(in) :: toa_flux(:,:) ! TOA flux to be scaled (columns,gpts) + real(r8), intent(out) :: sfac(:,:) ! scaling factors (columns,gpts) + + ! Local variables + integer :: i, j, istat, gpt_start, gpt_end, ncols + real(r8), allocatable :: scale(:) + character(len=*), parameter :: sub = 'get_variability' + + if (do_spctrl_scaling) then + + ! Determine target irradiance for each band + call integrate_spectrum(nbins, nswbands, we, radbinmin, radbinmax, sol_irrad, irrad) + + ncols = size(toa_flux, 1) + allocate(scale(ncols), stat=istat) + call alloc_err(istat, sub, 'scale', ncols) + + do i = 1, nswbands + gpt_start = band2gpt_sw(1,i) + gpt_end = band2gpt_sw(2,i) + scale = spread(irrad(i), 1, ncols) / sum(toa_flux(:, gpt_start:gpt_end), dim=2) + do j = gpt_start, gpt_end + sfac(:,j) = scale + end do + end do + + else + sfac(:,:) = sol_tsi / spread(sum(toa_flux, 2), 2, size(toa_flux, 2)) + end if + end subroutine get_variability + + +!------------------------------------------------------------------------------- +! private method......... +!------------------------------------------------------------------------------- + + subroutine integrate_spectrum( nsrc, ntrg, src_x, min_trg, max_trg, src, trg ) + + use mo_util, only : rebin + + implicit none + + !--------------------------------------------------------------- + ! ... dummy arguments + !--------------------------------------------------------------- + integer, intent(in) :: nsrc ! dimension source array + integer, intent(in) :: ntrg ! dimension target array + real(r8), intent(in) :: src_x(nsrc+1) ! source coordinates + real(r8), intent(in) :: max_trg(ntrg) ! target coordinates + real(r8), intent(in) :: min_trg(ntrg) ! target coordinates + real(r8), intent(in) :: src(nsrc) ! source array + real(r8), intent(out) :: trg(ntrg) ! target array + + !--------------------------------------------------------------- + ! ... local variables + !--------------------------------------------------------------- + real(r8) :: trg_x(2), targ(1) ! target coordinates + integer :: i + + do i = 1, ntrg + + trg_x(1) = min_trg(i) + trg_x(2) = max_trg(i) + + call rebin( nsrc, 1, src_x, trg_x, src(1:nsrc), targ(:) ) + ! W/m2/nm --> W/m2 + trg( i ) = targ(1)*(trg_x(2)-trg_x(1)) + + enddo + + + end subroutine integrate_spectrum + +end module rad_solar_var diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index f490b81b7b..3d4b47d09e 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -26,6 +26,9 @@ module radconstants logical :: wavenumber_boundaries_set = .false. +! First and last g-point for each band. +integer, public, protected :: band2gpt_sw(2,nswbands) + integer, public, protected :: nswgpts ! number of SW g-points integer, public, protected :: nlwgpts ! number of LW g-points @@ -104,6 +107,9 @@ subroutine set_wavenumber_bands(kdist_sw, kdist_lw) wavenumber_low_shortwave = values(1,:) wavenumber_high_shortwave = values(2,:) + ! First and last g-point for each SW band: + band2gpt_sw = kdist_sw%get_band_lims_gpoint() + ! Indices into specific bands idx_sw_diag = get_band_index_by_value('sw', 500.0_r8, 'nm') idx_nir_diag = get_band_index_by_value('sw', 1000.0_r8, 'nm') diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index bb1667b0ec..58a973a3f0 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -16,7 +16,6 @@ module radiation pbuf_set_field, pbuf_get_field, pbuf_old_tim_idx use camsrfexch, only: cam_out_t, cam_in_t use physconst, only: cappa, cpair, gravit -use solar_irrad_data, only: sol_tsi use time_manager, only: get_nstep, is_first_step, is_first_restart_step, & get_curr_calday, get_step_size @@ -27,6 +26,7 @@ module radiation use radconstants, only: nradgas, gasnamelength, gaslist, nswbands, nlwbands, & nswgpts, set_wavenumber_bands +use rad_solar_var, only: rad_solar_var_init, get_variability use cloud_rad_props, only: cloud_rad_props_init @@ -495,6 +495,7 @@ subroutine radiation_init(pbuf2d) ! Set the sw/lw band boundaries in radconstants. Also sets ! indicies of specific bands for diagnostic output and COSP input. call set_wavenumber_bands(kdist_sw, kdist_lw) + call rad_solar_var_init() ! The spectral band boundaries need to be set before this init is called. call rrtmgp_inputs_init(ktopcam, ktoprad) @@ -937,8 +938,8 @@ subroutine radiation_tend( & ! TOA solar flux on RRTMGP g-points real(r8), allocatable :: toa_flux(:,:) - ! TSI from RRTMGP data (from sum over g-point representation) - real(r8) :: tsi_ref + ! Scale factors based on spectral distribution from input irradiance dataset + real(r8), allocatable :: sfac(:,:) ! Planck sources for LW. type(ty_source_func_lw) :: sources_lw @@ -1097,6 +1098,7 @@ subroutine radiation_tend( & allocate( & t_sfc(ncol), emis_sfc(nlwbands,ncol), toa_flux(nday,nswgpts), & + sfac(nday,nswgpts), & t_rad(ncol,nlay), pmid_rad(ncol,nlay), pint_rad(ncol,nlay+1), & t_day(nday,nlay), pmid_day(nday,nlay), pint_day(nday,nlay+1), & coszrs_day(nday), alb_dir(nswbands,nday), alb_dif(nswbands,nday), & @@ -1174,8 +1176,8 @@ subroutine radiation_tend( & call stop_on_err(errmsg, sub, 'kdist_sw%gas_optics') ! Scale the solar source - tsi_ref = sum(toa_flux(1,:)) - toa_flux = toa_flux * sol_tsi * eccf / tsi_ref + call get_variability(toa_flux, sfac) + toa_flux = toa_flux * sfac * eccf end if @@ -1303,7 +1305,7 @@ subroutine radiation_tend( & end if ! if (dolw) deallocate( & - t_sfc, emis_sfc, toa_flux, t_rad, pmid_rad, pint_rad, & + t_sfc, emis_sfc, toa_flux, sfac, t_rad, pmid_rad, pint_rad, & t_day, pmid_day, pint_day, coszrs_day, alb_dir, alb_dif) !================! diff --git a/src/physics/simple/physpkg.F90 b/src/physics/simple/physpkg.F90 index 70a2f147d5..0bbb63dd7e 100644 --- a/src/physics/simple/physpkg.F90 +++ b/src/physics/simple/physpkg.F90 @@ -208,6 +208,8 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use nudging, only: Nudge_Model, nudging_init use cam_snapshot, only: cam_snapshot_init use cam_budget, only: cam_budget_init + use constituents, only: cnst_get_ind + use ccpp_constituent_prop_mod, only: ccpp_const_props_init @@ -220,7 +222,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) type(cam_out_t),intent(inout) :: cam_out(begchunk:endchunk) ! local variables - integer :: lchnk + integer :: lchnk, ixq !----------------------------------------------------------------------- call physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, pcols) @@ -281,7 +283,8 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! Initialize CAM CCPP constituent properties array ! for use in CCPP-ized physics schemes: - call ccpp_const_props_init() + call cnst_get_ind('Q', ixq) + call ccpp_const_props_init(ixq) ! Initialize qneg3 and qneg4 call qneg_init() diff --git a/src/physics/spcam/crm/ADV_MPDATA/crmx_advect_scalar.F90 b/src/physics/spcam/crm/ADV_MPDATA/crmx_advect_scalar.F90 deleted file mode 100644 index df9574cf4b..0000000000 --- a/src/physics/spcam/crm/ADV_MPDATA/crmx_advect_scalar.F90 +++ /dev/null @@ -1,47 +0,0 @@ - -subroutine advect_scalar (f,fadv,flux,f2leadv,f2legrad,fwleadv,doit) - -! positively definite monotonic advection with non-oscillatory option - -use crmx_grid -use crmx_vars, only: u, v, w, rho, rhow -use crmx_params, only: docolumn - -implicit none - -real f(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) -real flux(nz), fadv(nz) -real f2leadv(nz),f2legrad(nz),fwleadv(nz) -logical doit - -real df(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) -integer i,j,k - -if(docolumn) then - flux = 0. - return -end if - -!call t_startf ('advect_scalars') - - df(:,:,:) = f(:,:,:) - -if(RUN3D) then - call advect_scalar3D(f, u, v, w, rho, rhow, flux) -else - call advect_scalar2D(f, u, w, rho, rhow, flux) -endif - - do k=1,nzm - fadv(k)=0. - do j=1,ny - do i=1,nx - fadv(k)=fadv(k)+f(i,j,k)-df(i,j,k) - end do - end do - end do - -!call t_stopf ('advect_scalars') - -end subroutine advect_scalar - diff --git a/src/physics/spcam/crm/ADV_MPDATA/crmx_advect_scalar2D.F90 b/src/physics/spcam/crm/ADV_MPDATA/crmx_advect_scalar2D.F90 deleted file mode 100644 index a3773aa1ca..0000000000 --- a/src/physics/spcam/crm/ADV_MPDATA/crmx_advect_scalar2D.F90 +++ /dev/null @@ -1,182 +0,0 @@ - -subroutine advect_scalar2D (f, u, w, rho, rhow, flux) - -! positively definite monotonic advection with non-oscillatory option - -use crmx_grid -use crmx_params, only: dowallx -implicit none - - -real f(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) -real u(dimx1_u:dimx2_u, dimy1_u:dimy2_u, nzm) -real w(dimx1_w:dimx2_w, dimy1_w:dimy2_w, nz ) -real rho(nzm) -real rhow(nz) -real flux(nz) - -real mx (0:nxp1,1,nzm) -real mn (0:nxp1,1,nzm) -real uuu(-1:nxp3,1,nzm) -real www(-1:nxp2,1,nz) - -real eps, dd -integer i,j,k,ic,ib,kc,kb -logical nonos -real iadz(nzm),irho(nzm),irhow(nzm) - -real x1, x2, a, b, a1, a2, y -real andiff,across,pp,pn -andiff(x1,x2,a,b)=(abs(a)-a*a*b)*0.5*(x2-x1) -across(x1,a1,a2)=0.03125*a1*a2*x1 -pp(y)= max(0.,y) -pn(y)=-min(0.,y) - -nonos = .true. -eps = 1.e-10 - -j=1 - -www(:,:,nz)=0. - -if(dowallx) then - - if(mod(rank,nsubdomains_x).eq.0) then - do k=1,nzm - do i=dimx1_u,1 - u(i,j,k) = 0. - end do - end do - end if - if(mod(rank,nsubdomains_x).eq.nsubdomains_x-1) then - do k=1,nzm - do i=nx+1,dimx2_u - u(i,j,k) = 0. - end do - end do - end if - -end if - -!----------------------------------------- - -if(nonos) then - - do k=1,nzm - kc=min(nzm,k+1) - kb=max(1,k-1) - do i=0,nxp1 - ib=i-1 - ic=i+1 - mx(i,j,k)=max(f(ib,j,k),f(ic,j,k),f(i,j,kb),f(i,j,kc),f(i,j,k)) - mn(i,j,k)=min(f(ib,j,k),f(ic,j,k),f(i,j,kb),f(i,j,kc),f(i,j,k)) - end do - end do - -end if ! nonos - -do k=1,nzm - kb=max(1,k-1) - do i=-1,nxp3 - uuu(i,j,k)=max(0.,u(i,j,k))*f(i-1,j,k)+min(0.,u(i,j,k))*f(i,j,k) - end do - do i=-1,nxp2 - www(i,j,k)=max(0.,w(i,j,k))*f(i,j,kb)+min(0.,w(i,j,k))*f(i,j,k) - end do - flux(k) = 0. - do i=1,nx - flux(k) = flux(k) + www(i,j,k) - end do -end do - -do k=1,nzm - irho(k) = 1./rho(k) - iadz(k) = 1./adz(k) - do i=-1,nxp2 - f(i,j,k) = f(i,j,k) - (uuu(i+1,j,k)-uuu(i,j,k) & - + (www(i,j,k+1)-www(i,j,k))*iadz(k))*irho(k) - end do -end do - - -do k=1,nzm - kc=min(nzm,k+1) - kb=max(1,k-1) - dd=2./(kc-kb)/adz(k) - irhow(k)=1./(rhow(k)*adz(k)) - do i=0,nxp2 - ib=i-1 - uuu(i,j,k)=andiff(f(ib,j,k),f(i,j,k),u(i,j,k),irho(k)) & - - across(dd*(f(ib,j,kc)+f(i,j,kc)-f(ib,j,kb)-f(i,j,kb)), & - u(i,j,k), w(ib,j,k)+w(ib,j,kc)+w(i,j,k)+w(i,j,kc)) *irho(k) - end do - - - do i=0,nxp1 - ib=i-1 - ic=i+1 - www(i,j,k)=andiff(f(i,j,kb),f(i,j,k),w(i,j,k),irhow(k)) & - -across(f(ic,j,kb)+f(ic,j,k)-f(ib,j,kb)-f(ib,j,k), & - w(i,j,k), u(i,j,kb)+u(i,j,k)+u(ic,j,k)+u(ic,j,kb)) *irho(k) - end do -end do -www(:,:,1) = 0. -!---------- non-osscilatory option --------------- - -if(nonos) then - - do k=1,nzm - kc=min(nzm,k+1) - kb=max(1,k-1) - do i=0,nxp1 - ib=i-1 - ic=i+1 - mx(i,j,k)=max(f(ib,j,k),f(ic,j,k),f(i,j,kb),f(i,j,kc),f(i,j,k),mx(i,j,k)) - mn(i,j,k)=min(f(ib,j,k),f(ic,j,k),f(i,j,kb),f(i,j,kc),f(i,j,k),mn(i,j,k)) - end do - end do - - do k=1,nzm - kc=min(nzm,k+1) - do i=0,nxp1 - ic=i+1 - mx(i,j,k)=rho(k)*(mx(i,j,k)-f(i,j,k))/(pn(uuu(ic,j,k)) + pp(uuu(i,j,k))+& - iadz(k)*(pn(www(i,j,kc)) + pp(www(i,j,k)))+eps) - mn(i,j,k)=rho(k)*(f(i,j,k)-mn(i,j,k))/(pp(uuu(ic,j,k)) + pn(uuu(i,j,k))+& - iadz(k)*(pp(www(i,j,kc)) + pn(www(i,j,k)))+eps) - end do - end do - - do k=1,nzm - kb=max(1,k-1) - do i=1,nxp1 - ib=i-1 - uuu(i,j,k)= pp(uuu(i,j,k))*min(1.,mx(i,j,k), mn(ib,j,k)) & - - pn(uuu(i,j,k))*min(1.,mx(ib,j,k),mn(i,j,k)) - end do - do i=1,nx - www(i,j,k)= pp(www(i,j,k))*min(1.,mx(i,j,k), mn(i,j,kb)) & - - pn(www(i,j,k))*min(1.,mx(i,j,kb),mn(i,j,k)) - flux(k) = flux(k) + www(i,j,k) - end do - end do - - -endif ! nonos - - - do k=1,nzm - kc=k+1 - do i=1,nx - ! MK: added fix for very small negative values (relative to positive values) - ! especially when such large numbers as - ! hydrometeor concentrations are advected. The reason for negative values is - ! most likely truncation error. - f(i,j,k)= max(0., f(i,j,k) - (uuu(i+1,j,k)-uuu(i,j,k) & - +(www(i,j,k+1)-www(i,j,k))*iadz(k))*irho(k)) - end do - end do - -end subroutine advect_scalar2D - - diff --git a/src/physics/spcam/crm/ADV_MPDATA/crmx_advect_scalar3D.F90 b/src/physics/spcam/crm/ADV_MPDATA/crmx_advect_scalar3D.F90 deleted file mode 100644 index cd66086006..0000000000 --- a/src/physics/spcam/crm/ADV_MPDATA/crmx_advect_scalar3D.F90 +++ /dev/null @@ -1,302 +0,0 @@ - -subroutine advect_scalar3D (f, u, v, w, rho, rhow, flux) - -! positively definite monotonic advection with non-oscillatory option - -use crmx_grid -use crmx_params, only: dowallx, dowally -implicit none - - -real f(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) -real u(dimx1_u:dimx2_u, dimy1_u:dimy2_u, nzm) -real v(dimx1_v:dimx2_v, dimy1_v:dimy2_v, nzm) -real w(dimx1_w:dimx2_w, dimy1_w:dimy2_w, nz ) -real rho(nzm) -real rhow(nz) -real flux(nz) - -real mx (0:nxp1,0:nyp1,nzm) -real mn (0:nxp1,0:nyp1,nzm) -real uuu(-1:nxp3,-1:nyp2,nzm) -real vvv(-1:nxp2,-1:nyp3,nzm) -real www(-1:nxp2,-1:nyp2,nz) - -real eps, dd -real iadz(nzm),irho(nzm),irhow(nzm) -integer i,j,k,ic,ib,jc,jb,kc,kb -logical nonos - -real x1, x2, a, b, a1, a2, y -real andiff,across,pp,pn -andiff(x1,x2,a,b)=(abs(a)-a*a*b)*0.5*(x2-x1) -across(x1,a1,a2)=0.03125*a1*a2*x1 -pp(y)= max(0.,y) -pn(y)=-min(0.,y) - -nonos = .true. -eps = 1.e-10 - -www(:,:,nz)=0. - -if(dowallx) then - - if(mod(rank,nsubdomains_x).eq.0) then - do k=1,nzm - do j=dimy1_u,dimy2_u - do i=dimx1_u,1 - u(i,j,k) = 0. - end do - end do - end do - end if - if(mod(rank,nsubdomains_x).eq.nsubdomains_x-1) then - do k=1,nzm - do j=dimy1_u,dimy2_u - do i=nx+1,dimx2_u - u(i,j,k) = 0. - end do - end do - end do - end if - -end if - -if(dowally) then - - if(rank.lt.nsubdomains_x) then - do k=1,nzm - do j=dimy1_v,1 - do i=dimx1_v,dimx2_v - v(i,j,k) = 0. - end do - end do - end do - end if - if(rank.gt.nsubdomains-nsubdomains_x-1) then - do k=1,nzm - do j=ny+1,dimy2_v - do i=dimx1_v,dimx2_v - v(i,j,k) = 0. - end do - end do - end do - end if - -end if - -!----------------------------------------- - -if(nonos) then - - do k=1,nzm - kc=min(nzm,k+1) - kb=max(1,k-1) - do j=0,nyp1 - jb=j-1 - jc=j+1 - do i=0,nxp1 - ib=i-1 - ic=i+1 - mx(i,j,k)=max(f(ib,j,k),f(ic,j,k),f(i,jb,k), & - f(i,jc,k),f(i,j,kb),f(i,j,kc),f(i,j,k)) - mn(i,j,k)=min(f(ib,j,k),f(ic,j,k),f(i,jb,k), & - f(i,jc,k),f(i,j,kb),f(i,j,kc),f(i,j,k)) - end do - end do - end do - -end if ! nonos - - do k=1,nzm - do j=-1,nyp2 - do i=-1,nxp3 - uuu(i,j,k)=max(0.,u(i,j,k))*f(i-1,j,k)+min(0.,u(i,j,k))*f(i,j,k) - end do - end do - end do - - do k=1,nzm - do j=-1,nyp3 - do i=-1,nxp2 - vvv(i,j,k)=max(0.,v(i,j,k))*f(i,j-1,k)+min(0.,v(i,j,k))*f(i,j,k) - end do - end do - end do - - do k=1,nzm - kb=max(1,k-1) - do j=-1,nyp2 - do i=-1,nxp2 - www(i,j,k)=max(0.,w(i,j,k))*f(i,j,kb)+min(0.,w(i,j,k))*f(i,j,k) - end do - end do - flux(k) = 0. - do j=1,ny - do i=1,nx - flux(k) = flux(k) + www(i,j,k) - end do - end do - end do - - - do k=1,nzm - irho(k) = 1./rho(k) - iadz(k) = 1./adz(k) - do j=-1,nyp2 - do i=-1,nxp2 - f(i,j,k)=f(i,j,k) -(uuu(i+1,j,k)-uuu(i,j,k)+vvv(i,j+1,k)-vvv(i,j,k) & - +(www(i,j,k+1)-www(i,j,k))*iadz(k))*irho(k) - end do - end do - end do - - - do k=1,nzm - kc=min(nzm,k+1) - kb=max(1,k-1) - dd=2./(kc-kb)/adz(k) - do j=0,nyp1 - jb=j-1 - jc=j+1 - do i=0,nxp2 - ib=i-1 - uuu(i,j,k)=andiff(f(ib,j,k),f(i,j,k),u(i,j,k),irho(k)) & - -(across(f(ib,jc,k)+f(i,jc,k)-f(ib,jb,k)-f(i,jb,k), & - u(i,j,k), v(ib,j,k)+v(ib,jc,k)+v(i,jc,k)+v(i,j,k)) & - +across(dd*(f(ib,j,kc)+f(i,j,kc)-f(ib,j,kb)-f(i,j,kb)), & - u(i,j,k), w(ib,j,k)+w(ib,j,kc)+w(i,j,k)+w(i,j,kc))) *irho(k) - end do - end do - end do - - do k=1,nzm - kc=min(nzm,k+1) - kb=max(1,k-1) - dd=2./(kc-kb)/adz(k) - do j=0,nyp2 - jb=j-1 - do i=0,nxp1 - ib=i-1 - ic=i+1 - vvv(i,j,k)=andiff(f(i,jb,k),f(i,j,k),v(i,j,k),irho(k)) & - -(across(f(ic,jb,k)+f(ic,j,k)-f(ib,jb,k)-f(ib,j,k), & - v(i,j,k), u(i,jb,k)+u(i,j,k)+u(ic,j,k)+u(ic,jb,k)) & - +across(dd*(f(i,jb,kc)+f(i,j,kc)-f(i,jb,kb)-f(i,j,kb)), & - v(i,j,k), w(i,jb,k)+w(i,j,k)+w(i,j,kc)+w(i,jb,kc))) *irho(k) - end do - end do - end do - - do k=1,nzm - kb=max(1,k-1) - irhow(k)=1./(rhow(k)*adz(k)) - do j=0,nyp1 - jb=j-1 - jc=j+1 - do i=0,nxp1 - ib=i-1 - ic=i+1 - www(i,j,k)=andiff(f(i,j,kb),f(i,j,k),w(i,j,k),irhow(k)) & - -(across(f(ic,j,kb)+f(ic,j,k)-f(ib,j,kb)-f(ib,j,k), & - w(i,j,k), u(i,j,kb)+u(i,j,k)+u(ic,j,k)+u(ic,j,kb)) & - +across(f(i,jc,k)+f(i,jc,kb)-f(i,jb,k)-f(i,jb,kb), & - w(i,j,k), v(i,j,kb)+v(i,jc,kb)+v(i,jc,k)+v(i,j,k))) *irho(k) - end do - end do - end do - -www(:,:,1) = 0. - -!---------- non-osscilatory option --------------- - -if(nonos) then - - do k=1,nzm - kc=min(nzm,k+1) - kb=max(1,k-1) - do j=0,nyp1 - jb=j-1 - jc=j+1 - do i=0,nxp1 - ib=i-1 - ic=i+1 - mx(i,j,k)=max(f(ib,j,k),f(ic,j,k),f(i,jb,k), & - f(i,jc,k),f(i,j,kb),f(i,j,kc),f(i,j,k),mx(i,j,k)) - mn(i,j,k)=min(f(ib,j,k),f(ic,j,k),f(i,jb,k), & - f(i,jc,k),f(i,j,kb),f(i,j,kc),f(i,j,k),mn(i,j,k)) - end do - end do - end do - - do k=1,nzm - kc=min(nzm,k+1) - do j=0,nyp1 - jc=j+1 - do i=0,nxp1 - ic=i+1 - mx(i,j,k)=rho(k)*(mx(i,j,k)-f(i,j,k))/ & - (pn(uuu(ic,j,k)) + pp(uuu(i,j,k))+ & - pn(vvv(i,jc,k)) + pp(vvv(i,j,k))+ & - iadz(k)*(pn(www(i,j,kc)) + pp(www(i,j,k)))+eps) - mn(i,j,k)=rho(k)*(f(i,j,k)-mn(i,j,k))/ & - (pp(uuu(ic,j,k)) + pn(uuu(i,j,k))+ & - pp(vvv(i,jc,k)) + pn(vvv(i,j,k))+ & - iadz(k)*(pp(www(i,j,kc)) + pn(www(i,j,k)))+eps) - end do - end do - end do - - do k=1,nzm - do j=1,ny - do i=1,nxp1 - ib=i-1 - uuu(i,j,k)=pp(uuu(i,j,k))*min(1.,mx(i,j,k), mn(ib,j,k)) & - - pn(uuu(i,j,k))*min(1.,mx(ib,j,k),mn(i,j,k)) - end do - end do - end do - - do k=1,nzm - do j=1,nyp1 - jb=j-1 - do i=1,nx - vvv(i,j,k)=pp(vvv(i,j,k))*min(1.,mx(i,j,k), mn(i,jb,k)) & - - pn(vvv(i,j,k))*min(1.,mx(i,jb,k),mn(i,j,k)) - end do - end do - end do - - do k=1,nzm - kb=max(1,k-1) - do j=1,ny - do i=1,nx - www(i,j,k)=pp(www(i,j,k))*min(1.,mx(i,j,k), mn(i,j,kb)) & - - pn(www(i,j,k))*min(1.,mx(i,j,kb),mn(i,j,k)) - flux(k) = flux(k) + www(i,j,k) - end do - end do - end do - - -endif ! nonos - - -do k=1,nzm - kc=k+1 - do j=1,ny - do i=1,nx - ! MK: added fix for very small negative values (relative to positive values) - ! especially when such large numbers as - ! hydrometeor concentrations are advected. The reason for negative values is - ! most likely truncation error. - - f(i,j,k)=max(0.,f(i,j,k) -(uuu(i+1,j,k)-uuu(i,j,k)+vvv(i,j+1,k)-vvv(i,j,k) & - +(www(i,j,k+1)-www(i,j,k))*iadz(k))*irho(k)) - end do - end do -end do - -end subroutine advect_scalar3D - - diff --git a/src/physics/spcam/crm/ADV_MPDATA/crmx_advection.F90 b/src/physics/spcam/crm/ADV_MPDATA/crmx_advection.F90 deleted file mode 100644 index 04b1f60d9c..0000000000 --- a/src/physics/spcam/crm/ADV_MPDATA/crmx_advection.F90 +++ /dev/null @@ -1,3 +0,0 @@ -module crmx_advection - integer, parameter :: NADV = 0, NADVS=0 ! add'l boundary points -end module crmx_advection diff --git a/src/physics/spcam/crm/CLUBB/crmx_Skw_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_Skw_module.F90 deleted file mode 100644 index 2f49672025..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_Skw_module.F90 +++ /dev/null @@ -1,71 +0,0 @@ -!$Id: Skw_module.F90 5999 2012-12-18 23:53:13Z raut@uwm.edu $ -!------------------------------------------------------------------------------- -module crmx_Skw_module - - implicit none - - private ! Default Scope - - public :: Skw_func - - contains - -!------------------------------------------------------------------------------- - elemental function Skw_func( wp2, wp3 ) & - result( Skw ) - -! Description: -! Calculate the skewness of w, Skw. - -! References: -! None -!------------------------------------------------------------------------------- - - use crmx_constants_clubb, only: & - w_tol_sqd, &! Constant for w_{_tol}^2, i.e. threshold for vertical velocity - Skw_max_mag ! Max magnitude of skewness - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! External - intrinsic :: min, max - - ! Parameter Constants - ! Factor to decrease sensitivity in the denominator of Skw calculation - real( kind = core_rknd ), parameter :: & - Skw_denom_coef = 8.0_core_rknd ! [-] - - ! Whether to apply clipping to the final result - logical, parameter :: & - l_clipping_kluge = .false. - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - wp2, & ! w'^2 [m^2/s^2] - wp3 ! w'^3 [m^3/s^3] - - ! Output Variable - real( kind = core_rknd ) :: & - Skw ! Result Skw [-] - - ! ---- Begin Code ---- - - !Skw = wp3 / ( max( wp2, w_tol_sqd ) )**1.5_core_rknd - ! Calculation of skewness to help reduce the sensitivity of this value to - ! small values of wp2. - Skw = wp3 / ( wp2 + Skw_denom_coef * w_tol_sqd )**1.5_core_rknd - - ! This is no longer needed since clipping is already - ! imposed on wp2 and wp3 elsewhere in the code - if ( l_clipping_kluge ) then - Skw = min( max( Skw, -Skw_max_mag ), Skw_max_mag ) - end if - - return - end function Skw_func -!----------------------------------------------------------------------- - -end module crmx_Skw_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_T_in_K_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_T_in_K_module.F90 deleted file mode 100644 index 971bccc073..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_T_in_K_module.F90 +++ /dev/null @@ -1,86 +0,0 @@ -! $Id: T_in_K_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ - -module crmx_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 crmx_constants_clubb, only: & - ! Variable(s) - Cp, & ! Dry air specific heat at constant p [J/kg/K] - Lv ! Latent heat of vaporization [J/kg] - - use crmx_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 crmx_constants_clubb, only: & - ! Variable(s) - Cp, & ! Dry air specific heat at constant p [J/kg/K] - Lv ! Latent heat of vaporization [J/kg] - - use crmx_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 crmx_T_in_K_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_advance_helper_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_advance_helper_module.F90 deleted file mode 100644 index 4f1d8b53a0..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_advance_helper_module.F90 +++ /dev/null @@ -1,136 +0,0 @@ -!------------------------------------------------------------------------- -! $Id: advance_helper_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_advance_helper_module - -! Description: -! This module contains helper methods for the advance_* modules. -!------------------------------------------------------------------------ - - implicit none - - public :: set_boundary_conditions_lhs, set_boundary_conditions_rhs - - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - integer, intent(in) :: & - diag_index, low_bound, high_bound ! boundary indexes for the first variable - - integer, intent(in), optional :: & - diag_index2, low_bound2, high_bound2 ! boundary indexes for the second variable - - real( kind = core_rknd ), dimension(:,:), intent(inout) :: & - lhs ! left hand side of the LAPACK matrix equation - - ! --------------------- 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 - - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! 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 - - ! 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 - - ! The right-hand side vector - real( kind = core_rknd ), dimension(:), intent(inout) :: rhs - - ! -------------------- 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 - - end subroutine set_boundary_conditions_rhs - -end module crmx_advance_helper_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_advance_windm_edsclrm_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_advance_windm_edsclrm_module.F90 deleted file mode 100644 index 57799743cb..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_advance_windm_edsclrm_module.F90 +++ /dev/null @@ -1,1909 +0,0 @@ -!------------------------------------------------------------------------ -! $Id: advance_windm_edsclrm_module.F90 5960 2012-10-18 20:34:59Z janhft@uwm.edu $ -!=============================================================================== -module crmx_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, Kh_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 crmx_grid_class, only: & - gr ! Variables(s) - - use crmx_parameters_model, only: & - ts_nudge, & ! Variable(s) - edsclr_dim - - use crmx_parameters_tunable, only: & - nu10_vert_res_dep ! Constant - - use crmx_model_flags, only: & - l_uv_nudge, & ! Variable(s) - l_tke_aniso - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_stats_type, only: & - stat_begin_update, & ! Subroutines - stat_end_update, & - stat_update_var - - use crmx_stats_variables, only: & - ium_ref, & ! Variables - ivm_ref, & - ium_sdmp, & - ivm_sdmp, & - ium_ndg, & - ivm_ndg, & - iwindm_matrix_condt_num, & - zt, & - l_stats_samp - - use crmx_clip_explicit, only: & - clip_covar ! Procedure(s) - - use crmx_error_code, only: & - clubb_at_least_debug_level, & ! Procedure(s) - fatal_error - - use crmx_error_code, only: & - clubb_no_error, & ! Constant(s) - clubb_singular_matrix - - use crmx_constants_clubb, only: & - fstderr, & ! Constant(s) - eps - - use crmx_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=time_precision), 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] - Kh_zm, & ! Eddy diffusivity on momentum levels [m^2/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, Kh_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, Kh_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( Kh_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( Kh_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, Kh_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/real( dt, kind = core_rknd ), zt ) - call stat_begin_update( ivm_sdmp, vm/real( dt, kind = core_rknd ), 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/real( dt, kind = core_rknd ), zt ) - call stat_end_update( ivm_sdmp, vm/real( dt, kind = core_rknd ), 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( Kh_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( Kh_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 / real( dt, kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_begin_update( ivm_ndg, vm / real( dt, kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - end if - - um(1:gr%nz) = um(1:gr%nz) & - - ((um(1:gr%nz) - um_ref(1:gr%nz)) * (real( dt, kind = core_rknd )/ts_nudge)) - vm(1:gr%nz) = vm(1:gr%nz) & - - ((vm(1:gr%nz) - vm_ref(1:gr%nz)) * (real( dt, kind = core_rknd )/ts_nudge)) - endif - - if( l_stats_samp ) then - - ! Reflect nudging in budget - if ( l_uv_nudge ) then - call stat_end_update( ium_ndg, um / real( dt, kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_end_update( ivm_ndg, vm / real( dt, kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - end if - - call stat_update_var( ium_ref, um_ref, zt ) - call stat_update_var( ivm_ref, vm_ref, 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, Kh_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( Kh_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, Kh_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( Kh_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,*) "Kh_zm = ", Kh_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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_lapack_wrap, only: & - tridag_solve, & ! Procedure(s) - tridag_solvex - - use crmx_stats_variables, only: & - sfc, & ! Variable(s) - l_stats_samp - - use crmx_stats_type, only: & - stat_update_var_pt ! Subroutine - - use crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_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) - 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 crmx_stats_variables, only: & - ium_ma, & ! Variables - ium_ta, & - ivm_ma, & - ivm_ta, & - ztscr01, & - ztscr02, & - ztscr03, & - ztscr04, & - ztscr05, & - ztscr06, & - zt - - use crmx_stats_type, only: & - stat_end_update_pt, & ! Subroutines - stat_update_var_pt - - use crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_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), 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), 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), 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), 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 crmx_grid_class, only: & - gr - - use crmx_stats_type, only: & - stat_update_var - - use crmx_stats_variables, only: & - ium_gf, & - ium_cf, & - ivm_gf, & - ivm_cf, & - ium_f, & - ivm_f, & - zt, & - l_stats_samp - - use crmx_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, zt ) - - ! xm term cf is completely explicit; call stat_update_var. - call stat_update_var( ixm_cf, xm_cf, zt ) - - ! xm term F - call stat_update_var( ixm_f, xm_forcing, 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, Kh_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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_diffusion, only: & - diffusion_zt_lhs ! Procedure(s) - - use crmx_mean_adv, only: & - term_ma_zt_lhs ! Procedures - - use crmx_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=time_precision), 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] - Kh_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) * Kh_zm(k), & - rho_ds_zm(km1) * Kh_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 / real( dt, kind = core_rknd ) - - 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) * Kh_zm(k), & - rho_ds_zm(km1) * Kh_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, Kh_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 crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_diffusion, only: & - diffusion_zt_lhs ! Procedure(s) - - use crmx_stats_variables, only: & - ium_ta, & ! Variable(s) - ivm_ta, & - zt, & - l_stats_samp - - use crmx_stats_type, only: & - stat_begin_update_pt, & ! Procedure(s) - stat_modify_pt - - use crmx_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=time_precision), 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) :: & - Kh_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) * Kh_zm(k), & - rho_ds_zm(km1) * Kh_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 / real ( dt, kind = core_rknd ) * 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), 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, & - 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) * Kh_zm(k), & - rho_ds_zm(km1) * Kh_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 / real( dt, kind = core_rknd ) * 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), zt ) - endif - - endif ! l_stats_samp - - - return - end function windm_edsclrm_rhs - -!=============================================================================== - elemental function xpwp_fnc( Kh_zm, xm, xmp1, invrs_dzm ) - - ! Description: - ! Compute x'w' from x, x, Kh and invrs_dzm - - ! References: - ! None - !----------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input variables - real( kind = core_rknd ), intent(in) :: & - Kh_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 = Kh_zm * invrs_dzm * ( xmp1 - xm ) - - return - end function xpwp_fnc - -!=============================================================================== - -end module crmx_advance_windm_edsclrm_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_advance_wp2_wp3_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_advance_wp2_wp3_module.F90 deleted file mode 100644 index cefd03f334..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_advance_wp2_wp3_module.F90 +++ /dev/null @@ -1,4427 +0,0 @@ -!------------------------------------------------------------------------ -! $Id: advance_wp2_wp3_module.F90 6146 2013-04-05 18:02:22Z raut@uwm.edu $ -!=============================================================================== -module crmx_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, & - 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 crmx_grid_class, only: & - gr, & ! Variable(s) - zt2zm, & ! Procedure(s) - zm2zt - - use crmx_parameters_tunable, only: & - C11c, & ! Variable(s) - C11b, & - C11, & - C1c, & - C1b, & - C1, & - c_K1, & - c_K8 - - use crmx_stats_type, only: & - stat_update_var - - use crmx_stats_variables, only: & - iC1_Skw_fnc, & - iC11_Skw_fnc, & - zm, & - zt, & - l_stats_samp - - use crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_model_flags, only: & - l_hyper_dfsn ! Variable(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_error_code, only: & - fatal_error, & ! Procedure(s) - clubb_at_least_debug_level - - use crmx_error_code, only: & - clubb_var_out_of_range ! Constant(s) - - implicit none - - intrinsic :: exp - - ! Input Variables - real(kind=time_precision), 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] - 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 - - !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, zt ) - call stat_update_var( iC1_Skw_fnc, C1_Skw_fnc, 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 - - ! Declare the number of subdiagonals and superdiagonals in the LHS matrix. - if ( l_hyper_dfsn ) then - ! There are nine overall diagonals (including four subdiagonals - ! and four superdiagonals). - nsub = 4 - nsup = 4 - else - ! There are five overall diagonals (including two subdiagonals - ! and two superdiagonals). - nsub = 2 - nsup = 2 - endif - - ! 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, & ! 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, & - 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_grid_class, only: & - zm2zt, & ! Function(s) - zt2zm, & - ddzt - - use crmx_constants_clubb, only: & - w_tol_sqd, & ! Variables(s) - eps, & - zero_threshold, & - fstderr - - use crmx_model_flags, only: & - l_tke_aniso, & ! Variable(s) - l_hyper_dfsn, & - l_hole_fill, & - l_gmres - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_lapack_wrap, only: & - band_solve, & ! Procedure(s) - band_solvex - - use crmx_fill_holes, only: & - fill_holes_driver - - use crmx_clip_explicit, only: & - clip_variance, & ! Procedure(s) - clip_skewness - - use crmx_stats_type, only: & - stat_begin_update, & ! Procedure(s) - stat_update_var_pt, & - stat_end_update, & - stat_end_update_pt - - use crmx_stats_variables, only: & - zm, & ! Variable(s) - zt, & - sfc, & - l_stats_samp, & - iwp2_ta, & - iwp2_ma, & - iwp2_pd, & - iwp2_ac, & - iwp2_dp1, & - iwp2_dp2, & - iwp2_pr1, & - iwp2_pr2, & - iwp2_4hd, & - iwp3_ta, & - iwp3_ma, & - iwp3_tp, & - iwp3_ac, & - iwp3_dp1, & - iwp3_pr1, & - iwp3_pr2, & - iwp3_4hd, & - iwp23_matrix_condt_num - - use crmx_stats_variables, only: & - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr10, & - zmscr11, & - zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17, & - ztscr01, & - ztscr02 - - use crmx_stats_variables, only: & - ztscr03, & - ztscr04, & - ztscr05, & - ztscr06, & - ztscr07, & - ztscr08, & - ztscr09, & - ztscr10, & - ztscr11, & - ztscr12, & - ztscr13, & - ztscr14, & - ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 - - implicit none - - ! External - intrinsic :: max, min, sqrt - - ! Parameter Constants - integer, parameter :: & - nrhs = 1 ! Number of RHS vectors - - ! Input Variables - real(kind=time_precision), 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] - 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, km2, kp1, kp2, 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, 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, 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, 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, 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 ) - km2 = max( k-2, 1 ) - kp1 = min( k+1, gr%nz ) - kp2 = min( k+2, 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), 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), zm ) - else - call stat_update_var_pt( iwp2_dp2, k, & - zmscr02(k) * wp2(km1) & - + zmscr03(k) * wp2(k) & - + zmscr04(k) * wp2(kp1), 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), 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), 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), 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), 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), zm ) - - ! w'^2 term 4hd is completely implicit; call stat_update_var_pt. - if ( l_hyper_dfsn ) then - call stat_update_var_pt( iwp2_4hd, k, & - zmscr13(k) * wp2(km2) & - + zmscr14(k) * wp2(km1) & - + zmscr15(k) * wp2(k) & - + zmscr16(k) * wp2(kp1) & - + zmscr17(k) * wp2(kp2), zm ) - endif - enddo - - ! Finalize implicit contributions for wp3 - - do k = 2, gr%nz-1, 1 - - km1 = max( k-1, 1 ) - km2 = max( k-2, 1 ) - kp1 = min( k+1, gr%nz ) - kp2 = min( k+2, 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), 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), zt ) - else - call stat_update_var_pt( iwp3_dp1, k, & - ztscr02(k) * wp3(km1) & - + ztscr03(k) * wp3(k) & - + ztscr04(k) * wp3(kp1), 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), 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), 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), 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), 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), zt ) - - ! w'^3 term 4hd is completely implicit; call stat_update_var_pt. - if ( l_hyper_dfsn ) then - call stat_update_var_pt( iwp3_4hd, k, & - ztscr17(k) * wp3(km2) & - + ztscr18(k) * wp3(km1) & - + ztscr19(k) * wp3(k) & - + ztscr20(k) * wp3(kp1) & - + ztscr21(k) * wp3(kp2), zt ) - endif - 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 / real( dt, kind = core_rknd ), zm ) - endif - - if ( l_hole_fill .and. any( wp2 < w_tol_sqd ) ) then - - ! Use a simple hole filling algorithm - call fill_holes_driver( 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 / real( dt, kind = core_rknd ), 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, 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - -#ifdef MKL - use crmx_error_code, only: & - fatal_error ! Procedure(s) - - use crmx_stats_variables, only: & - iwp23_matrix_condt_num, & ! Variable(s) - l_stats_samp, & - sfc - - use crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_lapack_wrap, only: & - band_solve, & ! Procedure(s) - band_solvex - - use crmx_stats_type, only: & - stat_update_var_pt ! Procedure(s) - - use crmx_csr_matrix_class, only: & - csr_intlc_5b_5b_ia, & ! Variables - csr_intlc_5b_5b_ja, & - intlc_5d_5d_ja_size - - use crmx_gmres_wrap, only: & - gmres_solve ! Subroutine - - use crmx_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=time_precision), 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] - 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 - - if (nsup > 2) then - write (fstderr, *) "WARNING: CSR-format solvers currently do not", & - "support solving with hyper diffusion", & - "at this time. l_hyper_dfsn ignored." - end if - 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, 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, 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, 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, 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) = 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, 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 crmx_grid_class, only: & - gr ! Variable - - use crmx_parameters_tunable, only: & - C4, & ! Variables - C5, & - C8, & - C8b, & - C12, & - nu1_vert_res_dep, & - nu8_vert_res_dep, & - nu_hd_vert_res_dep - - use crmx_constants_clubb, only: & - eps, & ! Variable(s) - three_halves, & - gamma_over_implicit_ts - - use crmx_model_flags, only: & - l_tke_aniso, & ! Variable(s) - l_hyper_dfsn - - use crmx_diffusion, only: & - diffusion_zm_lhs, & ! Procedures - diffusion_zt_lhs - - use crmx_mean_adv, only: & - term_ma_zm_lhs, & ! Procedures - term_ma_zt_lhs - - use crmx_hyper_diffusion_4th_ord, only: & - hyper_dfsn_4th_ord_zm_lhs, & - hyper_dfsn_4th_ord_zt_lhs - - use crmx_clubb_precision, only: & - time_precision, & - core_rknd - - use crmx_stats_variables, only: & - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr11, & - zmscr10, & - zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17, & - ztscr01, & - ztscr02 - - use crmx_stats_variables, only: & - ztscr03, & - ztscr04, & - ztscr05, & - ztscr06, & - ztscr07, & - ztscr08, & - ztscr09, & - ztscr10, & - ztscr11, & - ztscr12, & - ztscr13, & - ztscr14, & - ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 - - use crmx_stats_variables, only: & - l_stats_samp, & - iwp2_dp1, & - iwp2_dp2, & - iwp2_ta, & - iwp2_ma, & - iwp2_ac, & - iwp2_pr2, & - iwp2_pr1, & - iwp2_4hd, & - iwp3_ta, & - iwp3_tp, & - iwp3_ma, & - iwp3_ac, & - iwp3_pr2, & - iwp3_pr1, & - iwp3_dp1, & - iwp3_4hd - - use crmx_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_mdiag = 1, & ! Momentum super-super diagonal index for w'^2. - !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. - m_km2_mdiag = 9 ! Momentum sub-sub diagonal index for w'^2. - - ! Left-hand side matrix diagonal identifiers for - ! thermodynamic-level variable, w'^3. - integer, parameter :: & - t_kp2_tdiag = 1, & ! Thermodynamic super-super diagonal index for w'^3. - !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. - t_km2_tdiag = 9 ! Thermodynamic sub-sub diagonal index for w'^3. - - ! Input Variables - real(kind=time_precision), 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] - 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, km2, kp1, kp2, 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 ) - km2 = max( k-2, 1 ) - kp1 = min( k+1, gr%nz ) - kp2 = min( k+2, 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 / real( dt, kind = core_rknd ) - - ! 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), tau1m(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 - - ! LHS 4th-order hyper-diffusion (4hd). - if ( l_hyper_dfsn ) then - ! Note: w'^2 uses fixed-point boundary conditions. - lhs( (/m_kp2_mdiag,m_kp1_mdiag,m_k_mdiag,m_km1_mdiag,m_km2_mdiag/), & - k_wp2 ) & - = lhs( (/m_kp2_mdiag,m_kp1_mdiag,m_k_mdiag,m_km1_mdiag,m_km2_mdiag/), & - k_wp2 ) & - + hyper_dfsn_4th_ord_zm_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzm(k), & - gr%invrs_dzt(kp1), gr%invrs_dzt(k), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp2), gr%invrs_dzt(km1), 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), tau1m(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 - - if ( iwp2_4hd > 0 .and. l_hyper_dfsn ) then - tmp(1:5) = & - hyper_dfsn_4th_ord_zm_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzm(k), & - gr%invrs_dzt(kp1), gr%invrs_dzt(k), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp2), gr%invrs_dzt(km1), k ) - zmscr13(k) = -tmp(5) - zmscr14(k) = -tmp(4) - zmscr15(k) = -tmp(3) - zmscr16(k) = -tmp(2) - zmscr17(k) = -tmp(1) - 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 / real( dt, kind = core_rknd ) - - ! 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 - - ! LHS 4th-order hyper-diffusion (4hd). - if ( l_hyper_dfsn ) then - ! Note: w'^3 uses fixed-point boundary conditions. - lhs( (/t_kp2_tdiag,t_kp1_tdiag,t_k_tdiag,t_km1_tdiag,t_km2_tdiag/), & - k_wp3 ) & - = lhs( (/t_kp2_tdiag,t_kp1_tdiag,t_k_tdiag,t_km1_tdiag,t_km2_tdiag/), & - k_wp3 ) & - + hyper_dfsn_4th_ord_zt_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzt(k), & - gr%invrs_dzm(k), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp1), gr%invrs_dzt(km1), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km2), 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 - - if ( iwp3_4hd > 0 .and. l_hyper_dfsn ) then - tmp(1:5) = & - hyper_dfsn_4th_ord_zt_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzt(k), & - gr%invrs_dzm(k), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp1), gr%invrs_dzt(km1), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km2), k ) - ztscr17(k) = -tmp(5) - ztscr18(k) = -tmp(4) - ztscr19(k) = -tmp(3) - ztscr20(k) = -tmp(2) - ztscr21(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, 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 crmx_grid_class, only: & - gr ! Variable - - use crmx_parameters_tunable, only: & - C4, & ! Variables - C5, & - C8, & - C8b, & - C12, & - nu1_vert_res_dep, & - nu8_vert_res_dep, & - nu_hd_vert_res_dep - - use crmx_constants_clubb, only: & - eps, & ! Variable(s) - three_halves, & - gamma_over_implicit_ts - - use crmx_model_flags, only: & - l_tke_aniso, & ! Variable(s) - l_hyper_dfsn - - use crmx_diffusion, only: & - diffusion_zm_lhs, & ! Procedures - diffusion_zt_lhs - - use crmx_mean_adv, only: & - term_ma_zm_lhs, & ! Procedures - term_ma_zt_lhs - - use crmx_hyper_diffusion_4th_ord, only: & - hyper_dfsn_4th_ord_zm_lhs, & - hyper_dfsn_4th_ord_zt_lhs - - use crmx_clubb_precision, only: & - time_precision, & - core_rknd - - use crmx_stats_variables, only: & - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr11, & - zmscr10, & - zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17, & - ztscr01, & - ztscr02 - - use crmx_stats_variables, only: & - ztscr03, & - ztscr04, & - ztscr05, & - ztscr06, & - ztscr07, & - ztscr08, & - ztscr09, & - ztscr10, & - ztscr11, & - ztscr12, & - ztscr13, & - ztscr14, & - ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 - - use crmx_stats_variables, only: & - l_stats_samp, & - iwp2_dp1, & - iwp2_dp2, & - iwp2_ta, & - iwp2_ma, & - iwp2_ac, & - iwp2_pr2, & - iwp2_pr1, & - iwp2_4hd, & - iwp3_ta, & - iwp3_tp, & - iwp3_ma, & - iwp3_ac, & - iwp3_pr2, & - iwp3_pr1, & - iwp3_dp1, & - iwp3_4hd - - use crmx_csr_matrix_class, 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=time_precision), 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] - 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, km2, kp1, kp2, 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 ) - km2 = max( k-2, 1 ) - kp1 = min( k+1, gr%nz ) - kp2 = min( k+2, 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), tau1m(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 - - ! LHS 4th-order hyper-diffusion (4hd). - ! NOTE: 4th-order hyper-diffusion is not yet supported in CSR-format. - ! As such, this needs to remain commented out. - !if ( l_hyper_dfsn ) then - ! ! Note: w'^2 uses fixed-point boundary conditions. - ! lhs( (/m_kp2_mdiag,m_kp1_mdiag,m_k_mdiag,m_km1_mdiag,m_km2_mdiag/), & - ! k_wp2) & - ! = lhs( (/m_kp2_mdiag,m_kp1_mdiag,m_k_mdiag,m_km1_mdiag,m_km2_mdiag/), & - ! k_wp2) & - ! + hyper_dfsn_4th_ord_zm_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzm(k), & - ! gr%invrs_dzt(kp1), gr%invrs_dzt(k), & - ! gr%invrs_dzm(kp1), gr%invrs_dzm(km1), & - ! gr%invrs_dzt(kp2), gr%invrs_dzt(km1), 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), tau1m(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 - - if ( iwp2_4hd > 0 .and. l_hyper_dfsn ) then - tmp(1:5) = & - hyper_dfsn_4th_ord_zm_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzm(k), & - gr%invrs_dzt(kp1), gr%invrs_dzt(k), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp2), gr%invrs_dzt(km1), k ) - zmscr13(k) = -tmp(5) - zmscr14(k) = -tmp(4) - zmscr15(k) = -tmp(3) - zmscr16(k) = -tmp(2) - zmscr17(k) = -tmp(1) - 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 - - ! LHS 4th-order hyper-diffusion (4hd). - ! NOTE: 4th-order hyper-diffusion is not yet supported in CSR-format. - ! As such, this needs to remain commented out. - !if ( l_hyper_dfsn ) then - ! ! Note: w'^3 uses fixed-point boundary conditions. - ! lhs( (/t_kp2_tdiag,t_kp1_tdiag,t_k_tdiag,t_km1_tdiag,t_km2_tdiag/), & - ! k_wp3) & - ! = lhs( (/t_kp2_tdiag,t_kp1_tdiag,t_k_tdiag,t_km1_tdiag,t_km2_tdiag/), & - ! k_wp3) & - ! + hyper_dfsn_4th_ord_zt_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzt(k), & - ! gr%invrs_dzm(k), gr%invrs_dzm(km1), & - ! gr%invrs_dzt(kp1), gr%invrs_dzt(km1), & - ! gr%invrs_dzm(kp1), gr%invrs_dzm(km2), 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 - - if ( iwp3_4hd > 0 .and. l_hyper_dfsn ) then - tmp(1:5) = & - hyper_dfsn_4th_ord_zt_lhs( 'fixed-point', nu_hd_vert_res_dep, gr%invrs_dzt(k), & - gr%invrs_dzm(k), gr%invrs_dzm(km1), & - gr%invrs_dzt(kp1), gr%invrs_dzt(km1), & - gr%invrs_dzm(kp1), gr%invrs_dzm(km2), k ) - ztscr17(k) = -tmp(5) - ztscr18(k) = -tmp(4) - ztscr19(k) = -tmp(3) - ztscr20(k) = -tmp(2) - ztscr21(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, 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 crmx_grid_class, only: & - gr ! Variable - - use crmx_grid_class, only: & - ddzt ! Procedure - - use crmx_parameters_tunable, only: & - C4, & ! Variables - C5, & - C8, & - C8b, & - C12, & - C15, & - nu1_vert_res_dep, & - nu8_vert_res_dep - - use crmx_constants_clubb, only: & - w_tol_sqd, & ! Variable(s) - eps, & - three_halves, & - gamma_over_implicit_ts - - use crmx_model_flags, only: & - l_tke_aniso ! Variable - - use crmx_diffusion, only: & - diffusion_zm_lhs, & ! Procedures - diffusion_zt_lhs - - use crmx_clubb_precision, only: & - time_precision, & ! Variable - core_rknd - - use crmx_stats_variables, only: & - l_stats_samp, iwp2_dp1, iwp2_dp2, zm, iwp2_bp, & ! Variable(s) - iwp2_pr1, iwp2_pr2, iwp2_pr3, iwp3_ta, zt, & - iwp3_tp, iwp3_bp1, iwp3_pr2, iwp3_pr1, iwp3_dp1, iwp3_bp2 - - use crmx_stats_type, only: & - stat_update_var_pt, & ! Procedure(s) - stat_begin_update_pt, & - stat_modify_pt - - use crmx_advance_helper_module, only: set_boundary_conditions_rhs - - - implicit none - - ! Constant parameters - logical, parameter :: & - l_wp3_2nd_buoyancy_term = .true. - - ! Input Variables - real(kind=time_precision), 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] - 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 / real( dt, kind = core_rknd ) ) * 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), tau1m(k), w_tol_sqd ) - - ! 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), tau1m(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), 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) ), 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) ), 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) ), 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) ), 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), tau1m(k), w_tol_sqd ), 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), tau1m(k) ) - call stat_modify_pt( iwp2_dp1, k, & - + ( 1.0_core_rknd - gamma_over_implicit_ts ) & - * ( - lhs_fnc_output(1) * wp2(k) ), 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) ), & - 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 / real( dt, kind = core_rknd ) * 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) ), & -! zt ) - call stat_begin_update_pt( iwp3_ta, k, 0.0_core_rknd, 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) ), 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) ), & -! zt ) - call stat_begin_update_pt( iwp3_tp, k, 0.0_core_rknd, 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) ), 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) ), 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) ), & - 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) ), & - 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) ), 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), 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, 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 crmx_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 crmx_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 crmx_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 crmx_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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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 ) & - result( rhs ) - - ! Description: - ! 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. - - ! References: - !----------------------------------------------------------------------- - - use crmx_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] - threshold ! Minimum allowable value of w'^2 [m^2/s^2] - - ! Return Variable - real( kind = core_rknd ) :: rhs - - rhs & - = + ( C1_Skw_fnc / tau1m ) * threshold - - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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 crmx_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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_grid_class, only: & - gr ! Variable gr%weights_zt2zm - - use crmx_constants_clubb, only: & - w_tol_sqd - - use crmx_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 crmx_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 crmx_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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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 crmx_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 crmx_advance_wp2_wp3_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_advance_xm_wpxp_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_advance_xm_wpxp_module.F90 deleted file mode 100644 index 160755b817..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_advance_xm_wpxp_module.F90 +++ /dev/null @@ -1,3213 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: advance_xm_wpxp_module.F90 6146 2013-04-05 18:02:22Z raut@uwm.edu $ -!=============================================================================== -module crmx_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, wm_zm, wm_zt, wp2, & - Lscale, wp3_on_wp2, wp3_on_wp2_zt, Kh_zt, & - tau_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, & - w1_zm, w2_zm, varnce_w1_zm, varnce_w2_zm, & - mixt_frac_zm, l_implemented, & - sclrpthvp, sclrm_forcing, sclrp2, & - 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 crmx_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 crmx_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 crmx_parameters_model, only: & - sclr_dim, & ! Variable(s) - sclr_tol - - use crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_grid_class, only: & - zm2zt, & ! Procedure(s) - zt2zm - - use crmx_model_flags, only: & - l_clip_semi_implicit ! Variable(s) - - use crmx_mono_flux_limiter, only: & - calc_turb_adv_range ! Procedure(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_error_code, only: & - clubb_at_least_debug_level, & ! Procedure(s) - reportError, & - fatal_error - - use crmx_error_code, only: & - clubb_var_out_of_range ! Constant(s) - - use crmx_stats_type, only: & - stat_begin_update, & ! Procedure(s) - stat_end_update, & - stat_update_var - - use crmx_stats_variables, only: & - zt, & - 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 crmx_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=time_precision), intent(in) :: & - dt ! Timestep [s] - - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & - sigma_sqd_w, & ! sigma_sqd_w on momentum levels [-] - 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] - 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] - tau_zm, & ! Time-scale tau on momentum levels [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. - w1_zm, & ! Mean w (1st PDF component) [m/s] - w2_zm, & ! Mean w (2nd PDF component) [m/s] - varnce_w1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] - varnce_w2_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] - - ! 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 - - 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 C6 and 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 ) - 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, zm ) - call stat_update_var( iC6rt_Skw_fnc, C6rt_Skw_fnc, zm ) - call stat_update_var( iC6thl_Skw_fnc, C6thl_Skw_fnc, 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, w1_zm, w2_zm, varnce_w1_zm, varnce_w2_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, wprtp, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) - wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - Kw6, tau_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) - 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_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 reportError( 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 reportError( 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, wpthlp, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) - wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - Kw6, tau_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) - 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_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 reportError( 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 reportError( 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, wpsclrp(:,i), a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) - wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - Kw6, tau_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) - 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_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 reportError( 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 reportError( 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, dummy_1d, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) - wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) - Kw6, tau_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) - 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_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_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_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 reportError( 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 reportError( 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 reportError( 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 reportError( 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_zm = ", tau_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,*) "w1_zm = ", w1_zm - write(fstderr,*) "w2_zm = ", w2_zm - write(fstderr,*) "varnce_w1_zm = ", varnce_w1_zm - write(fstderr,*) "varnce_w2_zm = ", varnce_w2_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 / real( dt, kind = core_rknd ), 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 / real( dt, kind = core_rknd ), 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 / real( dt, kind = core_rknd ), 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 / real( dt, kind = core_rknd ), zt ) - end if - endif - - return - - end subroutine advance_xm_wpxp - - !============================================================================= - subroutine xm_wpxp_lhs( l_iter, dt, wpxp, a1, a1_zt, wm_zm, wm_zt, & - wp2, wp3_on_wp2, wp3_on_wp2_zt, & - Kw6, tau_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, & - 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 crmx_parameters_tunable, only: & - nu6_vert_res_dep ! Variable(s) - - use crmx_grid_class, only: & - gr, & ! Variable(s) - zm2zt ! Procedure(s) - - use crmx_constants_clubb, only: & - gamma_over_implicit_ts, & ! Constant(s) - one, & - zero - - use crmx_model_flags, only: & - l_clip_semi_implicit, & ! Variable(s) - l_upwind_wpxp_ta - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_diffusion, only: & - diffusion_zm_lhs ! Procedure(s) - - use crmx_mean_adv, only: & - term_ma_zt_lhs, & ! Procedure(s) - term_ma_zm_lhs - - use crmx_clip_semi_implicit, only: & - clip_semi_imp_lhs ! Procedure(s) - - use crmx_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 crmx_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 crmx_advance_helper_module, only: set_boundary_conditions_lhs ! Procedure(s) - - - 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=time_precision), 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] - a1, & ! a_1 (momentum levels) [-] - a1_zt, & ! a_1 interpolated to thermodynamic levels [-] - 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_zm, & ! Time-scale tau on momentum levels [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 - - - ! 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 - - - !!!!!***** 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 / real( dt, kind = core_rknd ) - - 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_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 / real(dt, kind = core_rknd) - 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_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 - - ! Upper boundary - k = gr%nz - !k_xm is 2*k - 1 - k_wpxp_high = 2*k - - 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_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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_constants_clubb, only: & - gamma_over_implicit_ts, & ! Constant(s) - one, & - zero - - use crmx_model_flags, only: & - l_clip_semi_implicit, & ! Variable(s) - l_upwind_wpxp_ta - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_clip_semi_implicit, only: & - clip_semi_imp_rhs ! Procedure(s) - - use crmx_stats_type, only: & - stat_update_var_pt, & - stat_begin_update_pt - - use crmx_stats_variables, only: & - zt, & ! Variable(s) - 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 crmx_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=time_precision), 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_zm, & ! Time-scale tau on momentum levels [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) / real( dt, kind = core_rknd ) - - ! 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), 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) / real( dt, kind = core_rknd ) - 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_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) ), 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) ), & - zm ) - - ! w'x' forcing term is completely explicit; call stat_update_var_pt. - call stat_update_var_pt( iwpxp_f, k, wpxp_forcing(k), 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) ), 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) ), 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_zm(k) ) - call stat_begin_update_pt( iwpxp_pr1, k, & - - ( one - gamma_over_implicit_ts ) & - * ( - lhs_fnc_output(1) * wpxp(k) ), 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_lapack_wrap, only: & - band_solve, & ! Procedure(s) - band_solvex - - use crmx_error_code, only: & - clubb_no_error ! Constant - - use crmx_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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_model_flags, only: & - l_clip_semi_implicit ! Variable(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_mono_flux_limiter, only: & - monotonic_turbulent_flux_limit ! Procedure(s) - - use crmx_pos_definite_module, only: & - pos_definite_adj ! Procedure(s) - - use crmx_clip_explicit, only: & - clip_covar, & ! Procedure(s) - clip_wprtp, & ! Variable(s) - clip_wpthlp, & - clip_wpsclrp - - use crmx_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 crmx_constants_clubb, only: & - fstderr, & ! Constant(s) - one, & - zero - - use crmx_fill_holes, only: & - fill_holes_driver ! Procedure - - use crmx_error_code, only: & - clubb_at_least_debug_level, & ! Procedure(s) - clubb_no_error ! Constant - - use crmx_stats_type, only: & - stat_begin_update, & ! Procedure(s) - stat_update_var_pt, & - stat_end_update_pt, & - stat_end_update, & - stat_update_var, & - stat_modify - - use crmx_stats_variables, only: & - zt, & ! Variable(s) - zm, & - 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 crmx_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 crmx_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=time_precision), 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, 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), 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), 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), 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), 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), 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), 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), 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), 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), 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), 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), zm ) - - call stat_update_var( ixm_pd, xm_pd(1:gr%nz), zt ) - - end if - - ! Computed value before clipping - if ( l_stats_samp ) then - call stat_begin_update( ixm_cl, xm / real( dt, kind = core_rknd ), & ! Intent(in) - 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_driver( 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 / real( dt, kind = core_rknd ), & ! Intent(in) - 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 / real( dt, kind = core_rknd ), 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 crmx_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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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 crmx_constants_clubb, only: & - zero ! Constant(s) - - use crmx_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 crmx_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 crmx_constants_clubb, only: & - one ! Constant(s) - - use crmx_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_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 crmx_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_zm ! Time-scale tau at momentum level (k) [s] - - ! Return Variable - real( kind = core_rknd ) :: lhs - - - ! Momentum main diagonal: [ x wpxp(k,) ] - lhs = C6x_Skw_fnc / tau_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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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 crmx_grid_class, only: & - gr ! Variable(s); gr%nz only. - - use crmx_clubb_precision, only: & - time_precision, & - core_rknd - - use crmx_stats_type, only: & - stat_update_var ! Procedure(s) - - use crmx_stats_variables, only: & - l_stats_samp, & ! Variable(s) - zt, & - ithlm_tacl, & - irtm_tacl - - implicit none - - ! Input Variables - integer, intent(in) :: & - solve_type ! Variable that is being solved for. - - real(kind=time_precision), 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) * real( dt, kind = core_rknd ) - 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, 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 crmx_constants_clubb, only: & - one_hundred ! Constant(s) - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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 -!=============================================================================== - -end module crmx_advance_xm_wpxp_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_advance_xp2_xpyp_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_advance_xp2_xpyp_module.F90 deleted file mode 100644 index c4f490df6f..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_advance_xp2_xpyp_module.F90 +++ /dev/null @@ -1,3417 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: advance_xp2_xpyp_module.F90 6149 2013-04-08 21:45:56Z storer@uwm.edu $ -!=============================================================================== -module crmx_advance_xp2_xpyp_module - - ! Description: - ! Contains the subroutine advance_xp2_xpyp and ancillary functions. - !----------------------------------------------------------------------- - - implicit none - - public :: advance_xp2_xpyp, & - update_xp2_mc_tndcy - - 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 crmx_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 crmx_model_flags, only: & - l_hole_fill, & ! logical constants - l_single_C2_Skw - - use crmx_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 crmx_parameters_model, only: & - sclr_dim, & ! Variable(s) - sclr_tol - - use crmx_grid_class, only: & - gr, & ! Variable(s) - zm2zt ! Procedure(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_clip_explicit, only: & - clip_covar, & ! Procedure(s) - clip_variance, & - clip_rtp2, & ! Variable(s) - clip_thlp2, & - clip_rtpthlp, & - clip_up2, & - clip_vp2, & - clip_sclrp2, & - clip_sclrprtp, & - clip_sclrpthlp - - use crmx_stats_type, only: & - stat_modify - - use crmx_error_code, only: & - clubb_no_error, & ! Variable(s) - clubb_var_out_of_range, & - clubb_singular_matrix - - use crmx_error_code, only: & - fatal_error, & ! Procedure(s) - clubb_at_least_debug_level - - use crmx_stats_variables, only: & - zm, & - irtp2_cl, & - l_stats_samp - - use crmx_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=time_precision), 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 / real( dt, kind = core_rknd ), 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 / real( dt, kind = core_rknd ), 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_constants_clubb, only: & - gamma_over_implicit_ts, & ! Constant(s) - one, & - zero - - use crmx_model_flags, only: & - l_upwind_xpyp_ta ! Constant(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_diffusion, only: & - diffusion_zm_lhs ! Procedure(s) - - use crmx_mean_adv, only: & - term_ma_zm_lhs ! Procedure(s) - - use crmx_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 crmx_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=time_precision), 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 / real( dt, kind = core_rknd ) ) - 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 crmx_constants_clubb, only: & - one ! Constant(s) - - use crmx_lapack_wrap, only: & - tridag_solve, & ! Variable(s) - tridag_solvex !, & -! band_solve - - use crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_stats_type, only: & - stat_update_var_pt ! Procedure(s) - - use crmx_stats_variables, only: & - 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 crmx_error_code, only: & - clubb_no_error ! Constant - - use crmx_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) - 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 crmx_grid_class, only: & - gr ! Derived type variable - - use crmx_stats_type, only: & - stat_end_update_pt, & ! Procedure(s) - stat_update_var_pt - - use crmx_stats_variables, only: & - 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 crmx_stats_variables, only: & - ivp2_dp2, & - ivp2_ta, & - ivp2_ma, & - ivp2_pr1, & - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr10, & - zmscr11 - - use crmx_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) - 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), & - 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), & - 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), & - 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) - 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_constants_clubb, only: & - gamma_over_implicit_ts, & ! Constant(s) - w_tol_sqd, & - one, & - two_thirds, & - one_third, & - zero - - use crmx_model_flags, only: & - l_upwind_xpyp_ta ! Constant(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_stats_type, only: & - stat_begin_update_pt, & ! Procedure(s) - stat_update_var_pt, & - stat_modify_pt - - use crmx_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, & - zm, & - zmscr01, & - zmscr11, & - l_stats_samp - - implicit none - - ! Input Variables - integer, intent(in) :: solve_type - - real(kind=time_precision), 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/real( dt, kind = core_rknd ) * 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 ), & - 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) ), & - 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) - 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) - 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) - 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) - 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) ), & - 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) ), & - 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_constants_clubb, only: & - gamma_over_implicit_ts, & ! Constant(s) - one, & - zero - - use crmx_model_flags, only: & - l_upwind_xpyp_ta ! Constant(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_stats_type, only: & - stat_begin_update_pt, & ! Procedure(s) - stat_update_var_pt, & - stat_modify_pt - - use crmx_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, & - zm, & - l_stats_samp - - use crmx_advance_helper_module, only: set_boundary_conditions_rhs - - implicit none - - ! Input Variables - integer, intent(in) :: solve_type - - real(kind=time_precision), 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/real( dt, kind = core_rknd ) * 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 ), & - 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) ), & - 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) - 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) - 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) ), & - 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) ), & - 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) ), & - 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), 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 crmx_grid_class, only: & ! gr%weights_zm2zt - gr ! Variable(s) - - use crmx_constants_clubb, only: & - one_third ! Constant(s) - - use crmx_model_flags, only: & - l_standard_term_ta - - use crmx_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 crmx_constants_clubb, only: & - one_third, & ! Constant(s) - zero - - use crmx_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 crmx_constants_clubb, only: & - one, & ! Constant(s) - one_third - - use crmx_model_flags, only: & - l_standard_term_ta - - use crmx_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 crmx_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 crmx_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 crmx_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 crmx_constants_clubb, only: & - w_tol_sqd, & ! Constant(s) - one_third - - use crmx_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 - - !============================================================================= - pure 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 crmx_constants_clubb, only: & ! Constants - grav, & ! Gravitational acceleration [m/s^2] - one, & - two_thirds, & - zero, & - zero_threshold - - use crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_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 - - !============================================================================= - pure 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 crmx_constants_clubb, only: & - two ! Constant(s) - - use crmx_interpolation, only : & - binary_search, lin_int ! Function(s) - - use crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_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_int( zt_high, gr%zt(k_high), gr%zt(k_high-1), & - um(k_high), um(k_high-1) ) - vm_high = lin_int( 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_int( zt_low, gr%zt(k_low), gr%zt(k_low-1), & - um(k_low), um(k_low-1) ) - vm_low = lin_int( 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 crmx_fill_holes, only: fill_holes_driver - use crmx_grid_class, only: gr - use crmx_clubb_precision, only: time_precision, core_rknd - - use crmx_stats_variables, only: & - zm, l_stats_samp, & - irtp2_pd, ithlp2_pd, iup2_pd, ivp2_pd ! variables - use crmx_stats_type, only: & - stat_begin_update, stat_end_update ! subroutines - - - implicit none - - ! External - intrinsic :: any, real, trim - - ! Input variables - integer, intent(in) :: & - solve_type - - real(kind=time_precision), 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 / real( dt, kind = core_rknd ), & ! Intent(in) - 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_driver( 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 / real( dt, kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - endif - - - return - end subroutine pos_definite_variances - - !============================================================================ - subroutine update_xp2_mc_tndcy( nz, dt, cloud_frac, rcm, rvm, thlm, & - exner, rrainm_evap, pdf_params, & - rtp2_mc_tndcy, thlp2_mc_tndcy ) - !Description: - !This subroutine is for use when l_morr_xp2_mc_tndcy = .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. --storer - - use crmx_pdf_parameter_module, only: pdf_parameter - - use crmx_constants_clubb, only: & - cloud_frac_min, & !Variables - Cp, & - Lv - - use crmx_clubb_precision, only: & - core_rknd, & ! Variable(s) - time_precision - - implicit none - - !input parameters - integer, intent(in) :: nz ! Points in the Vertical [-] - - real( kind = time_precision ), 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] - exner, & !Exner function [-] - rrainm_evap !Evaporation of rain [kg/kg/s] - - type(pdf_parameter), target, dimension(nz), intent(in) :: & - pdf_params ! PDF parameters - - !input/output variables - real( kind = core_rknd ), dimension(nz), intent(inout) :: & - rtp2_mc_tndcy, & !Tendency of rtp2 due to evaporation [(kg/kg)^2/s] - thlp2_mc_tndcy !Tendency of thlp2 due to evaporation [K^2/s] - - !local variables - real( kind = core_rknd ), dimension(nz) :: & - temp_rtp2, & !Used only to calculate rtp2_mc_tndcy [(kg/kg)^2] - temp_thlp2, & !Used to calculate thlp2_mc_tndcy [K^2/s] - precip_frac, & !Precipitation fraction [-] - pf_const ! ( 1 - pf )/( pf ) [-] - - integer :: k - - ! ---- Begin Code ---- - - ! Calculate precip_frac - precip_frac(nz) = 0.0_core_rknd - do k = nz-1, 1, -1 - if ( cloud_frac(k) > cloud_frac_min ) then - precip_frac(k) = cloud_frac(k) - else - precip_frac(k) = precip_frac(k+1) - end if - end do - - !Calculate increased variance (rtp2 and thlp2) due to rain evaporation - - where ( precip_frac > cloud_frac_min ) - pf_const = ( 1.0_core_rknd - precip_frac ) / precip_frac - 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%rt1 - ( rcm + rvm ) )**2 & - + pdf_params%varnce_rt1 ) + ( 1.0_core_rknd - pdf_params%mixt_frac ) & - * ( ( pdf_params%rt2 - ( rcm + rvm ) )**2 + pdf_params%varnce_rt2 ) - - rtp2_mc_tndcy = rrainm_evap**2 * pf_const * dt & - + 2.0_core_rknd * abs(rrainm_evap) * sqrt(temp_rtp2 * pf_const) - !use absolute value of evaporation, as evaporation will add - !to rt1 - - !Include the effects of rain evaporation on thlp2 - temp_thlp2 = pdf_params%mixt_frac * ( ( pdf_params%thl1 - thlm )**2 & - + pdf_params%varnce_thl1 ) + ( 1.0_core_rknd - pdf_params%mixt_frac ) & - * ( ( pdf_params%thl2 - thlm )**2 + pdf_params%varnce_thl2 ) - - thlp2_mc_tndcy = ( rrainm_evap * Lv / ( Cp * exner) )**2 * pf_const * dt & - + 2.0_core_rknd * rrainm_evap * Lv / ( Cp * exner ) & - * sqrt(temp_thlp2 * pf_const) - - end subroutine update_xp2_mc_tndcy - -!=============================================================================== - -end module crmx_advance_xp2_xpyp_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_anl_erf.F90 b/src/physics/spcam/crm/CLUBB/crmx_anl_erf.F90 deleted file mode 100644 index 4298620c1d..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_anl_erf.F90 +++ /dev/null @@ -1,228 +0,0 @@ -! $Id: anl_erf.F90 5324 2011-07-27 21:05:45Z dschanen@uwm.edu $ -module crmx_anl_erf - - implicit none - - public :: erf - - interface erf - module procedure dp_erf, sp_erf - end interface - - private :: dp_erf, sp_erf - - private ! Default Scope - - contains - - 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 = 8 ) X, the argument of ERF. -! Output, real ( kind = 8 ) ERFX, the value of ERF(X). -!----------------------------------------------------------------------- - - implicit none - - ! Input Variables(s) - double precision, intent(in) :: x - - ! External - intrinsic :: epsilon, exp, aint - - ! Local Constants - real( kind = 8 ), parameter, dimension( 5 ) :: & - a = (/ 3.16112374387056560D+00, & - 1.13864154151050156D+02, & - 3.77485237685302021D+02, & - 3.20937758913846947D+03, & - 1.85777706184603153D-01 /) - real( kind = 8 ), parameter, dimension( 4 ) :: & - b = (/ 2.36012909523441209D+01, & - 2.44024637934444173D+02, & - 1.28261652607737228D+03, & - 2.84423683343917062D+03 /) - real( kind = 8 ), parameter, dimension( 9 ) :: & - c = (/ 5.64188496988670089D-01, & - 8.88314979438837594D+00, & - 6.61191906371416295D+01, & - 2.98635138197400131D+02, & - 8.81952221241769090D+02, & - 1.71204761263407058D+03, & - 2.05107837782607147D+03, & - 1.23033935479799725D+03, & - 2.15311535474403846D-08 /) - real( kind = 8 ), parameter, dimension( 8 ) :: & - d = (/ 1.57449261107098347D+01, & - 1.17693950891312499D+02, & - 5.37181101862009858D+02, & - 1.62138957456669019D+03, & - 3.29079923573345963D+03, & - 4.36261909014324716D+03, & - 3.43936767414372164D+03, & - 1.23033935480374942D+03 /) - real( kind = 8 ), parameter, dimension( 6 ) :: & - p = (/ 3.05326634961232344D-01, & - 3.60344899949804439D-01, & - 1.25781726111229246D-01, & - 1.60837851487422766D-02, & - 6.58749161529837803D-04, & - 1.63153871373020978D-02 /) - - real( kind = 8 ), parameter, dimension( 5 ) :: & - q = (/ 2.56852019228982242D+00, & - 1.87295284992346047D+00, & - 5.27905102951428412D-01, & - 6.05183413124413191D-02, & - 2.33520497626869185D-03 /) - - real( kind = 8 ), parameter :: & - SQRPI = 0.56418958354775628695D+00, & - THRESH = 0.46875D+00, & - XBIG = 26.543D+00 - - ! Return type - real( kind = 8 ) :: erfx - - ! Local variables - real( kind = 8 ) :: & - del, & - xabs, & - xden, & - xnum, & - xsq - - integer :: i ! Index - -!------------------------------------------------------------------------------- - 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.0D+00 - 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.0D+00 ) 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.0D+00 ) / 16.0D+00 - 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.5D+00 - erfx ) + 0.5D+00 - - if ( x < 0.0D+00 ) then - erfx = - erfx - end if - ! - ! Evaluate ERFC(X) for 4.0 < |X|. - ! - else - - if ( XBIG <= xabs ) then - - if ( 0.0D+00 < x ) then - erfx = 1.0D+00 - else - erfx = -1.0D+00 - end if - - else - - xsq = 1.0D+00 / ( 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.0D+00 ) / 16.0D+00 - del = ( xabs - xsq ) * ( xabs + xsq ) - erfx = exp( - xsq * xsq ) * exp( - del ) * erfx - - erfx = ( 0.5D+00 - erfx ) + 0.5D+00 - if ( x < 0.0D+00 ) then - erfx = - erfx - end if - - end if - - end if - - return - end function dp_erf - -!----------------------------------------------------------------------- - function sp_erf( x ) result( erfx ) - -! Description: -! Return a truncation of the 64bit approx. of the error function. -! Ideally we would probably use a 32bit table for our approx. - -! References: -! None -!----------------------------------------------------------------------- - - implicit none - - ! External - intrinsic :: real - - ! Input Variables - real( kind=4 ), intent(in) :: x - - ! Return type - real( kind=4 ) :: erfx - - erfx = real( dp_erf( real(x, kind=8) ), kind=4 ) - - return - end function sp_erf - -end module crmx_anl_erf diff --git a/src/physics/spcam/crm/CLUBB/crmx_array_index.F90 b/src/physics/spcam/crm/CLUBB/crmx_array_index.F90 deleted file mode 100644 index 41c5b7f38d..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_array_index.F90 +++ /dev/null @@ -1,37 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: array_index.F90 5216 2011-06-06 18:58:41Z dschanen@uwm.edu $ -!----------------------------------------------------------------------- -module crmx_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 -!----------------------------------------------------------------------- - implicit none - - ! Variables - ! Microphysics mixing ratios - integer, public :: & - iirrainm, iirsnowm, iiricem, iirgraupelm ! [kg/kg] -!$omp threadprivate(iirrainm, iirsnowm, iiricem, iirgraupelm) - - ! Microphysics number concentration - integer, public :: & - iiNrm, iiNsnowm, iiNim, iiNgraupelm, iiNcm ! [#/kg] -!$omp threadprivate(iiNrm, iiNsnowm, iiNim, iiNgraupelm, iiNcm) - - ! 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) - - private ! Default Scope - -end module crmx_array_index -!----------------------------------------------------------------------- diff --git a/src/physics/spcam/crm/CLUBB/crmx_calendar.F90 b/src/physics/spcam/crm/CLUBB/crmx_calendar.F90 deleted file mode 100644 index 28d7987614..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_calendar.F90 +++ /dev/null @@ -1,250 +0,0 @@ -!$Id: calendar.F90 5867 2012-07-03 21:06:44Z dschanen@uwm.edu $ -module crmx_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 crmx_clubb_precision, only: & - time_precision ! Variable(s) - - use crmx_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 / sec_per_day ) - - ! 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 ) * sec_per_day ) - - 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 crmx_calendar diff --git a/src/physics/spcam/crm/CLUBB/crmx_clip_explicit.F90 b/src/physics/spcam/crm/CLUBB/crmx_clip_explicit.F90 deleted file mode 100644 index ce73c9c88a..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_clip_explicit.F90 +++ /dev/null @@ -1,859 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: clip_explicit.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module crmx_clip_explicit - - implicit none - - private - - public :: clip_covars_denom, & - clip_covar, & - 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 - - 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_parameters_model, only: & - sclr_dim ! Variable(s) - - use crmx_model_flags, only: & - l_tke_aniso ! Logical - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_stats_type, only: & - stat_modify ! Procedure(s) - - use crmx_stats_variables, only: & - iwprtp_bt, & ! Variable(s) - iwpthlp_bt, & - zm, & - l_stats_samp - - implicit none - - ! Input Variables - real(kind=time_precision), 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 / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - elseif ( wprtp_cl_num == 3 ) then - ! wprtp total time tendency (effect of clipping) - call stat_modify( iwprtp_bt, -wprtp / real( dt, kind = core_rknd ), & ! intent(in) - 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 / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - elseif ( wprtp_cl_num == 2 ) then - ! wprtp total time tendency (effect of clipping) - call stat_modify( iwprtp_bt, wprtp / real( dt, kind = core_rknd ), & ! intent(in) - 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 / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - elseif ( wpthlp_cl_num == 3 ) then - ! wpthlp total time tendency (effect of clipping) - call stat_modify( iwpthlp_bt, -wpthlp / real( dt, kind = core_rknd ), & ! intent(in) - 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 / real( dt, kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - elseif ( wpthlp_cl_num == 2 ) then - ! wpthlp total time tendency (effect of clipping) - call stat_modify( iwpthlp_bt, wpthlp / real( dt, kind = core_rknd ), & ! intent(in) - 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). - - ! References: - ! None - !----------------------------------------------------------------------- - - use crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_constants_clubb, only: & - max_mag_correlation ! Constant(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_stats_type, only: & - stat_begin_update, & ! Procedure(s) - stat_modify, & - stat_end_update - - use crmx_stats_variables, only: & - 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=time_precision), 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 / real( dt, kind = core_rknd ), zm ) - else - call stat_modify( ixpyp_cl, -xpyp / real( dt, kind = core_rknd ), 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 / real( dt, kind = core_rknd ), zm ) - else - call stat_modify( ixpyp_cl, xpyp / real( dt, kind = core_rknd ), zm ) - endif - endif - - - return - end subroutine clip_covar - - !============================================================================= - 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_stats_type, only: & - stat_begin_update, & ! Procedure(s) - stat_end_update - - use crmx_stats_variables, only: & - 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=time_precision), 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 / real( dt, kind = core_rknd ), 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. - do k = 2, 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 / real( dt, kind = core_rknd ), 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_stats_type, only: & - stat_begin_update, & ! Procedure(s) - stat_end_update - - use crmx_stats_variables, only: & - zt, & ! Variable(s) - iwp3_cl, & - l_stats_samp - - implicit none - - ! External - intrinsic :: sign, sqrt, real - - ! Input Variables - real(kind=time_precision), 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 / real( dt, kind = core_rknd ), zt ) - endif - - call clip_skewness_core( sfc_elevation, wp2_zt, wp3 ) - - if ( l_stats_samp ) then - call stat_end_update( iwp3_cl, wp3 / real( dt, kind = core_rknd ), zt ) - endif - - return - end subroutine clip_skewness - -!============================================================================= - subroutine clip_skewness_core( sfc_elevation, wp2_zt, wp3 ) -! - use crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_constants_clubb, only: & - Skw_max_mag_sqd ! [-] - - use crmx_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 crmx_clip_explicit diff --git a/src/physics/spcam/crm/CLUBB/crmx_clip_semi_implicit.F90 b/src/physics/spcam/crm/CLUBB/crmx_clip_semi_implicit.F90 deleted file mode 100644 index 4447d88325..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_clip_semi_implicit.F90 +++ /dev/null @@ -1,660 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: clip_semi_implicit.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module crmx_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 crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - 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=time_precision), parameter :: dt_clip_coef = 1.0_time_precision - - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s)implicit none - - implicit none - - ! Input Variables - real(kind=time_precision), 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=time_precision) :: & - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real(kind=time_precision), 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/real( dt_clip, kind = core_rknd ) * 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real(kind=time_precision), 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=time_precision) :: & - 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/real( dt_clip, kind = core_rknd ) & - * ( 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/ real( dt_clip, kind = core_rknd )) & - * ( 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 crmx_constants_clubb, only: eps ! Variable(s) - - use crmx_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 crmx_clip_semi_implicit diff --git a/src/physics/spcam/crm/CLUBB/crmx_clubb_core.F90 b/src/physics/spcam/crm/CLUBB/crmx_clubb_core.F90 deleted file mode 100644 index 3e768ff032..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_clubb_core.F90 +++ /dev/null @@ -1,3105 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: clubb_core.F90 6146 2013-04-05 18:02:22Z raut@uwm.edu $ -!----------------------------------------------------------------------- -module crmx_clubb_core - -! 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-2013 -! 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. -!----------------------------------------------------------------------- - - implicit none - - public :: & - setup_clubb_core, & - advance_clubb_core, & - cleanup_clubb_core, & - set_Lscale_max - - 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, & - 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, exner, & - rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & - invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & - rfrzm, radf, & - um, vm, upwp, vpwp, up2, vp2, & - thlm, rtm, wprtp, wpthlp, & - wp2, wp3, rtp2, thlp2, rtpthlp, & - sclrm, & -#ifdef GFDL - sclrm_trsport_only, & ! h1g, 2010-06-16 -#endif - sclrp2, sclrprtp, sclrpthlp, & - wpsclrp, edsclrm, err_code, & -#ifdef GFDL - RH_crit, do_liquid_only_in_clubb, & ! h1g, 2010-06-16 -#endif - rcm, wprcp, cloud_frac, ice_supersat_frac, & - rcm_in_layer, cloud_cover, & -#if defined(CLUBB_CAM) || defined(GFDL) || defined(CLUBB_SAM) - khzm, khzt, qclvar, & -#endif - pdf_params ) - - ! 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 crmx_constants_clubb, only: & - w_tol, & ! Variable(s) - em_min, & - thl_tol, & - rt_tol, & - w_tol_sqd, & - ep2, & - Cp, & - Lv, & - ep1, & - eps, & - p0, & - kappa, & - fstderr, & - zero_threshold, & - three_halves - - use crmx_parameters_tunable, only: & - gamma_coefc, & ! Variable(s) - gamma_coefb, & - gamma_coef, & - taumax, & - c_K, & - mu, & - Lscale_mu_coef, & - Lscale_pert_coef - - use crmx_parameters_model, only: & - sclr_dim, & ! Variable(s) - edsclr_dim, & - sclr_tol, & - ts_nudge, & - rtm_min, & - rtm_nudge_max_altitude - - use crmx_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 - - use crmx_grid_class, only: & - gr, & ! Variable(s) - zm2zt, & ! Procedure(s) - zt2zm, & - ddzm - - use crmx_numerical_check, only: & - parameterization_check, & ! Procedure(s) - calculate_spurious_source - - use crmx_variables_diagnostic_module, only: & - Skw_zt, & ! Variable(s) - Skw_zm, & - sigma_sqd_w_zt, & - wp4, & - thlpthvp, & - rtpthvp, & - rtprcp, & - thlprcp, & - rcp2, & - rsat, & - pdf_params_zm, & - wprtp2, & - wp2rtp, & - wpthlp2, & - wp2thlp, & - wprtpthlp, & - wpthvp, & - wp2thvp, & - wp2rcp - - use crmx_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 crmx_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 crmx_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 - Skw_velocity, & ! Skewness velocity [m/s] - a3_coef, & ! The a3 coefficient [-] - a3_coef_zt ! The a3 coefficient interp. to the zt grid [-] - - use crmx_variables_diagnostic_module, only: & - wp3_on_wp2, & ! Variable(s) - wp3_on_wp2_zt - - use crmx_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 crmx_advance_xm_wpxp_module, only: & - ! Variable(s) - advance_xm_wpxp ! Compute mean/flux terms - - use crmx_advance_xp2_xpyp_module, only: & - ! Variable(s) - advance_xp2_xpyp ! Computes variance terms - - use crmx_surface_varnce_module, only: & - surface_varnce ! Procedure - - use crmx_pdf_closure_module, only: & - ! Procedure - pdf_closure ! Prob. density function - - use crmx_mixing_length, only: & - compute_length ! Procedure - - use crmx_advance_windm_edsclrm_module, only: & - advance_windm_edsclrm ! Procedure(s) - - use crmx_saturation, only: & - ! Procedure - sat_mixrat_liq ! Saturation mixing ratio - - use crmx_advance_wp2_wp3_module, only: & - advance_wp2_wp3 ! Procedure - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_error_code, only : & - clubb_no_error ! Constant(s) - - use crmx_error_code, only : & - clubb_at_least_debug_level, & ! Procedure(s) - reportError, & - fatal_error - - use crmx_Skw_module, only: & - Skw_func ! Procedure - - use crmx_clip_explicit, only: & - clip_covars_denom ! Procedure(s) - - use crmx_T_in_K_module, only: & - ! Read values from namelist - thlm2T_in_K ! Procedure - - use crmx_stats_subs, only: & - stats_accumulate ! Procedure - - use crmx_stats_type, 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 crmx_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 - - use crmx_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, & - zt, & - zm, & - sfc, & - irtm_spur_src, & - ithlm_spur_src - - use crmx_stats_variables, only: & - irfrzm ! Variable(s) - - use crmx_stats_variables, only: & - iSkw_velocity, & ! Variable(s) - igamma_Skw_fnc, & - iLscale_pert_1, & - iLscale_pert_2 - - use crmx_fill_holes, only: & - vertical_integral ! Procedure(s) - - use crmx_sigma_sqd_w_module, only: & - compute_sigma_sqd_w ! Procedure(s) - - implicit none - - !!! External - intrinsic :: sqrt, min, max, exp, mod, real - - ! Constant Parameters - logical, parameter :: & - l_avg_Lscale = .true., & ! 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. - l_Lscale_plume_centered = .false. ! Alternate that uses the PDF to - ! compute the perturbed values - - logical, parameter :: & - l_use_ice_latent = .false. !Includes the effects of ice latent heating in turbulence terms -! l_use_ice_latent = .true. !Includes the effects of ice latent heating in turbulence terms +++mhwang test - - logical, parameter :: & - l_iter_xp2_xpyp = .true. ! Set to true when rtp2/thlp2/rtpthlp, et cetera are prognostic - - !!! Input Variables - logical, intent(in) :: & - l_implemented ! Is this part of a larger host model (T/F) ? - - real(kind=time_precision), 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] - - 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), intent(in) :: & - radf ! Buoyancy production at the CL top due to LW radiative cooling [m^2/s^3] - - 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] - - !!! 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] - 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] - - ! 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) || defined(CLUBB_SAM) - real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & - khzt, & ! eddy diffusivity on thermo levels - khzm, & ! eddy diffusivity on momentum levels - qclvar ! cloud water variance -#endif - - !!! 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, & - 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 [-] - w1_zm, & ! Mean w (1st PDF component) [m/s] - w2_zm, & ! Mean w (2nd PDF component) [m/s] - varnce_w1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] - varnce_w2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2] - mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-] - - 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 - - - !----- Begin Code ----- - - 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, & ! In - zt ) ! Out - end if - - ! Set up budget stats variables. - if ( l_stats_samp ) then - - call stat_begin_update( iwp2_bt, wp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( ivp2_bt, vp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( iup2_bt, up2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( iwprtp_bt, wprtp / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( iwpthlp_bt, wpthlp / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( irtp2_bt, rtp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( ithlp2_bt, thlp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_begin_update( irtpthlp_bt, rtpthlp / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - - call stat_begin_update( irtm_bt, rtm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_begin_update( ithlm_bt, thlm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_begin_update( ium_bt, um / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_begin_update( ivm_bt, vm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_begin_update( iwp3_bt, wp3 / real( dt , kind = core_rknd ), & ! Intent(in) - 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 - - !--------------------------------------------------------------------------- - ! 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 ) - - Skw_zt(1:gr%nz) = Skw_func( wp2_zt(1:gr%nz), wp3(1:gr%nz) ) - Skw_zm(1:gr%nz) = Skw_func( wp2(1:gr%nz), wp3_zm(1:gr%nz) ) - - ! 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, zm ) - endif - - ! Smooth in the vertical - sigma_sqd_w = zt2zm( zm2zt( sigma_sqd_w ) ) - - ! Interpolate the the 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, - !--------------------------------------------------------------------------- - - ! Iterpolate variances to the 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 - - - do k = 1, gr%nz, 1 - - call pdf_closure & - ( 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), 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) h1g, 2010-06-16 -#endif - 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_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) * ( real( dt, kind = core_rknd ) / 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 ) - - ! Call pdf_closure to output the variables which belong on the momentum grid. - do k = 1, gr%nz, 1 - - call pdf_closure & - ( 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), 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) h1g, 2010-06-16 -#endif - 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_SAM - if ( ircp2 > 0 ) then -#endif - rcp2 = max( zt2zm( rcp2_zt ), zero_threshold ) ! Pos. def. quantity -#ifndef CLUBB_SAM - 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 - !ice_supersat_frac = cloud_cover !?-mark - 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 - - thlm_frz = thlm - (Lv / (Cp*exner) ) * rfrzm ! Add effects of ice latent heat - ! Ice is treated as liquid water here - rtm_frz = rtm + rfrzm - - - do k = 1, gr%nz, 1 - - call pdf_closure & - ( 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), 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) h1g, 2010-06-16 -#endif - 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) * ( real( dt, kind = core_rknd ) / 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 & - ( 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), 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) h1g, 2010-06-16 -#endif - 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 - - end if ! l_use_ice_latent = .true. - - - - - - !---------------------------------------------------------------- - ! 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 = mu / 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 = mu * 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 = mu / 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 = mu * Lscale_mu_coef - end if - - call compute_length( thvm, thlm_pert_1, rtm_pert_1, em, & ! 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, & ! 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%rt1 > pdf_params_frz%rt2 ) - rtm_pert_pos_rt = pdf_params_frz%rt1 & - + Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt1, rt_tol**2 ) ) - thlm_pert_pos_rt = pdf_params_frz%thl1 + ( sign_rtpthlp * Lscale_pert_coef & - * sqrt( max( pdf_params_frz%varnce_thl1, thl_tol**2 ) ) ) - thlm_pert_neg_rt = pdf_params_frz%thl2 - ( sign_rtpthlp * Lscale_pert_coef & - * sqrt( max( pdf_params_frz%varnce_thl2, thl_tol**2 ) ) ) - rtm_pert_neg_rt = pdf_params_frz%rt2 & - - Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt2, rt_tol**2 ) ) - !Lscale_weight = pdf_params%mixt_frac - else where - rtm_pert_pos_rt = pdf_params_frz%rt2 & - + Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt2, rt_tol**2 ) ) - thlm_pert_pos_rt = pdf_params_frz%thl2 + ( sign_rtpthlp * Lscale_pert_coef & - * sqrt( max( pdf_params_frz%varnce_thl2, thl_tol**2 ) ) ) - thlm_pert_neg_rt = pdf_params_frz%thl1 - ( sign_rtpthlp * Lscale_pert_coef & - * sqrt( max( pdf_params_frz%varnce_thl1, thl_tol**2 ) ) ) - rtm_pert_neg_rt = pdf_params_frz%rt1 & - - Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt1, rt_tol**2 ) ) - !Lscale_weight = 1.0_core_rknd - pdf_params%mixt_frac - end where - else - where ( pdf_params%rt1 > pdf_params%rt2 ) - rtm_pert_pos_rt = pdf_params%rt1 & - + Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt1, rt_tol**2 ) ) - thlm_pert_pos_rt = pdf_params%thl1 + ( sign_rtpthlp * Lscale_pert_coef & - * sqrt( max( pdf_params%varnce_thl1, thl_tol**2 ) ) ) - thlm_pert_neg_rt = pdf_params%thl2 - ( sign_rtpthlp * Lscale_pert_coef & - * sqrt( max( pdf_params%varnce_thl2, thl_tol**2 ) ) ) - rtm_pert_neg_rt = pdf_params%rt2 & - - Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt2, rt_tol**2 ) ) - !Lscale_weight = pdf_params%mixt_frac - else where - rtm_pert_pos_rt = pdf_params%rt2 & - + Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt2, rt_tol**2 ) ) - thlm_pert_pos_rt = pdf_params%thl2 + ( sign_rtpthlp * Lscale_pert_coef & - * sqrt( max( pdf_params%varnce_thl2, thl_tol**2 ) ) ) - thlm_pert_neg_rt = pdf_params%thl1 - ( sign_rtpthlp * Lscale_pert_coef & - * sqrt( max( pdf_params%varnce_thl1, thl_tol**2 ) ) ) - rtm_pert_neg_rt = pdf_params%rt1 & - - Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt1, rt_tol**2 ) ) - !Lscale_weight = 1.0_core_rknd - pdf_params%mixt_frac - end where - end if - mu_pert_pos_rt = mu / Lscale_mu_coef - mu_pert_neg_rt = mu * 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, & ! 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, & ! 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 = -999._core_rknd - Lscale_pert_2 = -999._core_rknd - - end if ! l_avg_Lscale - - if ( l_stats_samp ) then - call stat_update_var( iLscale_pert_1, Lscale_pert_1, zt ) - call stat_update_var( iLscale_pert_2, Lscale_pert_2, zt ) - 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, & ! intent(in) - p_in_Pa, exner, thv_ds_zt, mu, 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) || defined (CLUBB_SAM) - khzt(:) = Kh_zt(:) - khzm(:) = Kh_zm(:) - qclvar(:) = rcp2_zt(:) -#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) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_begin_update_pt( irtp2_sf, 1, & ! intent(in) - rtp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_begin_update_pt( irtpthlp_sf, 1, & ! intent(in) - rtpthlp(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_begin_update_pt( iup2_sf, 1, & ! intent(in) - up2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_begin_update_pt( ivp2_sf, 1, & ! intent(in) - vp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_begin_update_pt( iwp2_sf, 1, & ! intent(in) - wp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - end if - - call surface_varnce( upwp_sfc, vpwp_sfc, wpthlp_sfc, wprtp_sfc, & ! intent(in) - um(2), vm(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 reportError( err_code_surface ) - 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) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_end_update_pt( irtp2_sf, 1, & ! intent(in) - rtp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_end_update_pt( irtpthlp_sf, 1, & ! intent(in) - rtpthlp(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_end_update_pt( iup2_sf, 1, & ! intent(in) - up2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_end_update_pt( ivp2_sf, 1, & ! intent(in) - vp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - zm ) ! intent(inout) - call stat_end_update_pt( iwp2_sf, 1, & ! intent(in) - wp2(1) / real( dt , kind = core_rknd ), & ! intent(in) - 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, zt ) - - ! 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, zt) - 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 - w1_zm = pdf_params_zm%w1 - w2_zm = pdf_params_zm%w2 - varnce_w1_zm = pdf_params_zm%varnce_w1 - varnce_w2_zm = pdf_params_zm%varnce_w2 - mixt_frac_zm = pdf_params_zm%mixt_frac - else - w1_zm = zt2zm( pdf_params%w1 ) - w2_zm = zt2zm( pdf_params%w2 ) - varnce_w1_zm = zt2zm( pdf_params%varnce_w1 ) - varnce_w2_zm = zt2zm( pdf_params%varnce_w2 ) - mixt_frac_zm = zt2zm( pdf_params%mixt_frac ) - end if - - if ( l_use_ice_latent ) then - !calculate turbulence with terms including ice latent heating - call advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & ! intent(in) - Lscale, wp3_on_wp2, wp3_on_wp2_zt, Kh_zt, & ! intent(in) - tau_zm, Skw_zm, rtpthvp_frz, rtm_forcing, & ! intent(in) - wprtp_forcing, rtm_ref, thlpthvp_frz, & ! 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) - w1_zm, w2_zm, varnce_w1_zm, varnce_w2_zm, & ! intent(in) - mixt_frac_zm, l_implemented, & ! intent(in) - sclrpthvp, sclrm_forcing, sclrp2, & ! intent(in) - rtm, wprtp, thlm, wpthlp, & ! intent(inout) - err_code, & ! intent(inout) - sclrm, wpsclrp ) ! intent(inout) - else - call advance_xm_wpxp( dt, sigma_sqd_w, wm_zm, wm_zt, wp2, & ! intent(in) - Lscale, wp3_on_wp2, wp3_on_wp2_zt, Kh_zt, & ! intent(in) - tau_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) - w1_zm, w2_zm, varnce_w1_zm, varnce_w2_zm, & ! intent(in) - mixt_frac_zm, l_implemented, & ! intent(in) - sclrpthvp, sclrm_forcing, sclrp2, & ! intent(in) - rtm, wprtp, thlm, wpthlp, & ! intent(inout) - err_code, & ! intent(inout) - sclrm, wpsclrp ) ! intent(inout) - end if - - ! 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, sclrm, & ! h1g, 2010-06-16 - sclrm_trsport_only, Kh_zm, cloud_frac, err_code ) -#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. - if ( l_use_ice_latent) then - ! calculate turbulence with terms including ice latent heating - call advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, thlm, & ! intent(in) - wpthlp, wpthvp_frz, 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) - else - 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) - end if - - !---------------------------------------------------------------- - ! 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 - !---------------------------------------------------------------- - - if ( l_use_ice_latent) then - 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_frz, wp2thvp_frz, um, vm, upwp, vpwp, & ! intent(in) - up2, vp2, Kh_zm, Kh_zt, tau_zm, tau_zt, & ! 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) - else - 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, & ! 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) - end if - - !---------------------------------------------------------------- - ! 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 - !---------------------------------------------------------------- - - call advance_windm_edsclrm( dt, wm_zt, Kh_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) - - !####################################################################### - !############# ACCUMULATE STATISTICS ############# - !####################################################################### - - if ( l_stats_samp ) then - - call stat_end_update( iwp2_bt, wp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( ivp2_bt, vp2 / real( dt , kind = core_rknd ),& ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( iup2_bt, up2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( iwprtp_bt, wprtp / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( iwpthlp_bt, wpthlp / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( irtp2_bt, rtp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( ithlp2_bt, thlp2 / real( dt , kind = core_rknd ), & ! Intent(in) - zm ) ! Intent(inout) - call stat_end_update( irtpthlp_bt, rtpthlp / real( dt , kind = core_rknd ), &! Intent(in) - zm ) ! Intent(inout) - - call stat_end_update( irtm_bt, rtm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_end_update( ithlm_bt, thlm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_end_update( ium_bt, um / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_end_update( ivm_bt, vm / real( dt , kind = core_rknd ), & ! Intent(in) - zt ) ! Intent(inout) - call stat_end_update( iwp3_bt, wp3 / real( dt , kind = core_rknd ), & ! Intent(in) - 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, thlp2, 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, & - real( dt , kind = core_rknd ) ) - - ! 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, & - real( dt , kind = core_rknd ) ) - 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, sfc ) - call stat_update_var_pt( ithlm_spur_src, 1, & - thlm_spur_src, sfc ) - end if - - return - end subroutine advance_clubb_core - - !----------------------------------------------------------------------- - subroutine setup_clubb_core & - ( nzmax, T0_in, ts_nudge_in, & ! In - hydromet_dim_in, sclr_dim_in, & ! In - sclr_tol_in, edsclr_dim_in, params, & ! In - l_host_applies_sfc_fluxes, & ! In - l_uv_nudge, saturation_formula, & ! In -#ifdef GFDL - I_sat_sphum, & ! intent(in) h1g, 2010-06-16 -#endif - l_implemented, grid_type, deltaz, zm_init, zm_top, & ! In - momentum_heights, thermodynamic_heights, & ! In - host_dx, host_dy, sfc_elevation, & ! In -#ifdef GFDL - cloud_frac_min , & ! intent(in) h1g, 2010-06-16 -#endif - err_code ) ! Out - ! - ! Description: - ! Subroutine to set up the model for execution. - ! - ! References: - ! None - !------------------------------------------------------------------------- - use crmx_grid_class, only: & - setup_grid, & ! Procedure - gr ! Variable(s) - - use crmx_parameter_indices, only: & - nparams ! Variable(s) - - use crmx_parameters_tunable, only: & - setup_parameters ! Procedure - - use crmx_parameters_model, only: & - setup_parameters_model ! Procedure - - use crmx_variables_diagnostic_module, only: & - setup_diagnostic_variables ! Procedure - - use crmx_variables_prognostic_module, only: & - setup_prognostic_variables ! Procedure - - use crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_error_code, only: & - clubb_no_error ! Constant(s) - - use crmx_model_flags, only: & - setup_model_flags, & ! Subroutine - l_gmres ! Variable - -#ifdef MKL - use crmx_csr_matrix_class, only: & - initialize_csr_class, & ! Subroutine - intlc_5d_5d_ja_size ! Variable - - use crmx_gmres_wrap, only: & - gmres_init ! Subroutine - - use crmx_gmres_cache, only: & - gmres_cache_temp_init, & ! Subroutine - gmres_idx_wp2wp3 ! Variable -#endif /* MKL */ - - use crmx_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] - - ! 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] - - ! 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 - real( kind = core_rknd ) :: Lscale_max - 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 - - ! 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) - - ! Define model constant parameters -#ifdef GFDL - call setup_parameters_model( T0_in, ts_nudge_in, & ! In - hydromet_dim_in, & ! in - sclr_dim_in, sclr_tol_in, edsclr_dim_in, &! In - Lscale_max, cloud_frac_min ) ! In h1g, 2010-06-16 -#else - call setup_parameters_model( T0_in, ts_nudge_in, & ! In - hydromet_dim_in, & ! in - sclr_dim_in, sclr_tol_in, edsclr_dim_in, &! In - Lscale_max ) ! 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 ) - -#ifdef MKL - ! Initialize the CSR matrix class. - if ( l_gmres ) then - call initialize_csr_class - end if - - if ( l_gmres ) then - call gmres_cache_temp_init( gr%nz ) - call gmres_init( (2 * gr%nz), intlc_5d_5d_ja_size ) - 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 crmx_parameters_model, only: sclr_tol ! Variable - - use crmx_variables_diagnostic_module, only: & - cleanup_diagnostic_variables ! Procedure - - use crmx_variables_prognostic_module, only: & - cleanup_prognostic_variables ! Procedure - - use crmx_grid_class, only: & - cleanup_grid ! Procedure - - use crmx_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 crmx_stats_variables, only: & - iwprtp2, & ! Varibles - iwprtpthlp, & - iwpthlp2, & - iwprtp2, & - iwpsclrp2, & - iwpsclrprtp, & - iwpsclrpthlp, & - l_stats - - use crmx_grid_class, only: & - gr, & ! Variable - zt2zm ! Procedure - - use crmx_parameters_model, only: & - sclr_dim ! Number of passive scalar variables - - use crmx_pdf_parameter_module, only: & - pdf_parameter ! Derived data type - - use crmx_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) :: & - w1_zt, & ! Mean of w for 1st normal distribution [m/s] - w1_zm, & ! Mean of w for 1st normal distribution [m/s] - w2_zm, & ! Mean of w for 2nd normal distribution [m/s] - w2_zt, & ! Mean of w for 2nd normal distribution [m/s] - varnce_w1_zm, & ! Variance of w for 1st normal distribution [m^2/s^2] - varnce_w1_zt, & ! Variance of w for 1st normal distribution [m^2/s^2] - varnce_w2_zm, & ! Variance of w for 2nd normal distribution [m^2/s^2] - varnce_w2_zt, & ! Variance of w for 2nd normal distribution [m^2/s^2] - rt1_zm, & ! Mean of r_t for 1st normal distribution [kg/kg] - rt1_zt, & ! Mean of r_t for 1st normal distribution [kg/kg] - rt2_zm, & ! Mean of r_t for 2nd normal distribution [kg/kg] - rt2_zt, & ! Mean of r_t for 2nd normal distribution [kg/kg] - varnce_rt1_zm, & ! Variance of r_t for 1st normal distribution [kg^2/kg^2] - varnce_rt1_zt, & ! Variance of r_t for 1st normal distribution [kg^2/kg^2] - varnce_rt2_zm, & ! Variance of r_t for 2nd normal distribution [kg^2/kg^2] - varnce_rt2_zt, & ! Variance of r_t for 2nd normal distribution [kg^2/kg^2] - crt1_zm, & ! Coefficient for s' [-] - crt1_zt, & ! Coefficient for s' [-] - crt2_zm ! Coefficient for s' [-] - - real( kind = core_rknd ), dimension(gr%nz) :: & - crt2_zt, & ! Coefficient for s' [-] - cthl1_zm, & ! Coefficient for s' [1/K] - cthl1_zt, & ! Coefficient for s' [1/K] - cthl2_zm, & ! Coefficient for s' [1/K] - cthl2_zt, & ! Coefficient for s' [1/K] - thl1_zm, & ! Mean of th_l for 1st normal distribution [K] - thl1_zt, & ! Mean of th_l for 1st normal distribution [K] - thl2_zm, & ! Mean of th_l for 2nd normal distribution [K] - thl2_zt, & ! Mean of th_l for 2nd normal distribution - varnce_thl1_zm, & ! Variance of th_l for 1st normal distribution [K^2] - varnce_thl1_zt, & ! Variance of th_l for 1st normal distribution [K^2] - varnce_thl2_zm, & ! Variance of th_l for 2nd normal distribution [K^2] - varnce_thl2_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) [-] - rc1_zm, & ! Mean of r_c for 1st normal distribution [kg/kg] - rc1_zt, & ! Mean of r_c for 1st normal distribution [kg/kg] - rc2_zm, & ! Mean of r_c for 2nd normal distribution [kg/kg] - rc2_zt, & ! Mean of r_c for 2nd normal distribution [kg/kg] - rsl1_zm, & ! Mean of r_sl for 1st normal distribution [kg/kg] - rsl1_zt, & ! Mean of r_sl for 1st normal distribution [kg/kg] - rsl2_zm, & ! Mean of r_sl for 2nd normal distribution [kg/kg] - rsl2_zt, & ! Mean of r_sl for 2nd normal distribution [kg/kg] - cloud_frac1_zm, & ! Cloud fraction for 1st normal distribution [-] - cloud_frac1_zt, & ! Cloud fraction for 1st normal distribution [-] - cloud_frac2_zm, & ! Cloud fraction for 2nd normal distribution [-] - cloud_frac2_zt, & ! Cloud fraction for 2nd normal distribution [-] - s1_zm, & ! Mean of s for 1st normal distribution [kg/kg] - s1_zt, & ! Mean of s for 1st normal distribution [kg/kg] - s2_zm, & ! Mean of s for 2nd normal distribution [kg/kg] - s2_zt, & ! Mean of s for 2nd normal distribution [kg/kg] - stdev_s1_zm ! Standard deviation of s for 1st normal distribution [kg/kg] - - real( kind = core_rknd ), dimension(gr%nz) :: & - stdev_s1_zt, & ! Standard deviation of s for 1st normal distribution [kg/kg] - stdev_s2_zm, & ! Standard deviation of s for 2nd normal distribution [kg/kg] - stdev_s2_zt, & ! Standard deviation of s for 2nd normal distribution [kg/kg] - stdev_t1_zm, & ! Standard deviation of t for 1st normal distribution [kg/kg] - stdev_t1_zt, & ! Standard deviation of t for 1st normal distribution [kg/kg] - stdev_t2_zm, & ! Standard deviation of t for 2nd normal distribution [kg/kg] - stdev_t2_zt, & ! Standard deviation of 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 - w1_zt = pdf_params%w1 - w2_zt = pdf_params%w2 - varnce_w1_zt = pdf_params%varnce_w1 - varnce_w2_zt = pdf_params%varnce_w2 - rt1_zt = pdf_params%rt1 - rt2_zt = pdf_params%rt2 - varnce_rt1_zt = pdf_params%varnce_rt1 - varnce_rt2_zt = pdf_params%varnce_rt2 - crt1_zt = pdf_params%crt1 - crt2_zt = pdf_params%crt2 - cthl1_zt = pdf_params%cthl1 - cthl2_zt = pdf_params%cthl2 - thl1_zt = pdf_params%thl1 - thl2_zt = pdf_params%thl2 - varnce_thl1_zt = pdf_params%varnce_thl1 - varnce_thl2_zt = pdf_params%varnce_thl2 - mixt_frac_zt = pdf_params%mixt_frac - rc1_zt = pdf_params%rc1 - rc2_zt = pdf_params%rc2 - rsl1_zt = pdf_params%rsl1 - rsl2_zt = pdf_params%rsl2 - cloud_frac1_zt = pdf_params%cloud_frac1 - cloud_frac2_zt = pdf_params%cloud_frac2 - s1_zt = pdf_params%s1 - s2_zt = pdf_params%s2 - stdev_s1_zt = pdf_params%stdev_s1 - stdev_s2_zt = pdf_params%stdev_s2 - stdev_t1_zt = pdf_params%stdev_t1 - stdev_t2_zt = pdf_params%stdev_t2 - 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 - w1_zm = pdf_params_zm%w1 - w2_zm = pdf_params_zm%w2 - varnce_w1_zm = pdf_params_zm%varnce_w1 - varnce_w2_zm = pdf_params_zm%varnce_w2 - rt1_zm = pdf_params_zm%rt1 - rt2_zm = pdf_params_zm%rt2 - varnce_rt1_zm = pdf_params_zm%varnce_rt1 - varnce_rt2_zm = pdf_params_zm%varnce_rt2 - crt1_zm = pdf_params_zm%crt1 - crt2_zm = pdf_params_zm%crt2 - cthl1_zm = pdf_params_zm%cthl1 - cthl2_zm = pdf_params_zm%cthl2 - thl1_zm = pdf_params_zm%thl1 - thl2_zm = pdf_params_zm%thl2 - varnce_thl1_zm = pdf_params_zm%varnce_thl1 - varnce_thl2_zm = pdf_params_zm%varnce_thl2 - mixt_frac_zm = pdf_params_zm%mixt_frac - rc1_zm = pdf_params_zm%rc1 - rc2_zm = pdf_params_zm%rc2 - rsl1_zm = pdf_params_zm%rsl1 - rsl2_zm = pdf_params_zm%rsl2 - cloud_frac1_zm = pdf_params_zm%cloud_frac1 - cloud_frac2_zm = pdf_params_zm%cloud_frac2 - s1_zm = pdf_params_zm%s1 - s2_zm = pdf_params_zm%s2 - stdev_s1_zm = pdf_params_zm%stdev_s1 - stdev_s2_zm = pdf_params_zm%stdev_s2 - stdev_t1_zm = pdf_params_zm%stdev_t1 - stdev_t2_zm = pdf_params_zm%stdev_t2 - 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 - w1_zm = zt2zm( pdf_params%w1 ) - w1_zm(gr%nz) = 0.0_core_rknd - w2_zm = zt2zm( pdf_params%w2 ) - w2_zm(gr%nz) = 0.0_core_rknd - varnce_w1_zm = zt2zm( pdf_params%varnce_w1 ) - varnce_w1_zm(gr%nz) = 0.0_core_rknd - varnce_w2_zm = zt2zm( pdf_params%varnce_w2 ) - varnce_w2_zm(gr%nz) = 0.0_core_rknd - rt1_zm = zt2zm( pdf_params%rt1 ) - rt1_zm(gr%nz) = 0.0_core_rknd - rt2_zm = zt2zm( pdf_params%rt2 ) - rt2_zm(gr%nz) = 0.0_core_rknd - varnce_rt1_zm = zt2zm( pdf_params%varnce_rt1 ) - varnce_rt1_zm(gr%nz) = 0.0_core_rknd - varnce_rt2_zm = zt2zm( pdf_params%varnce_rt2 ) - varnce_rt2_zm(gr%nz) = 0.0_core_rknd - crt1_zm = zt2zm( pdf_params%crt1 ) - crt1_zm(gr%nz) = 0.0_core_rknd - crt2_zm = zt2zm( pdf_params%crt2 ) - crt2_zm(gr%nz) = 0.0_core_rknd - cthl1_zm = zt2zm( pdf_params%cthl1 ) - cthl1_zm(gr%nz) = 0.0_core_rknd - cthl2_zm = zt2zm( pdf_params%cthl2 ) - cthl2_zm(gr%nz) = 0.0_core_rknd - thl1_zm = zt2zm( pdf_params%thl1 ) - thl1_zm(gr%nz) = 0.0_core_rknd - thl2_zm = zt2zm( pdf_params%thl2 ) - thl2_zm(gr%nz) = 0.0_core_rknd - varnce_thl1_zm = zt2zm( pdf_params%varnce_thl1 ) - varnce_thl1_zm(gr%nz) = 0.0_core_rknd - varnce_thl2_zm = zt2zm( pdf_params%varnce_thl2 ) - varnce_thl2_zm(gr%nz) = 0.0_core_rknd - mixt_frac_zm = zt2zm( pdf_params%mixt_frac ) - mixt_frac_zm(gr%nz) = 0.0_core_rknd - rc1_zm = zt2zm( pdf_params%rc1 ) - rc1_zm(gr%nz) = 0.0_core_rknd - rc2_zm = zt2zm( pdf_params%rc2 ) - rc2_zm(gr%nz) = 0.0_core_rknd - rsl1_zm = zt2zm( pdf_params%rsl1 ) - rsl1_zm(gr%nz) = 0.0_core_rknd - rsl2_zm = zt2zm( pdf_params%rsl2 ) - rsl2_zm(gr%nz) = 0.0_core_rknd - cloud_frac1_zm = zt2zm( pdf_params%cloud_frac1 ) - cloud_frac1_zm(gr%nz) = 0.0_core_rknd - cloud_frac2_zm = zt2zm( pdf_params%cloud_frac2 ) - cloud_frac2_zm(gr%nz) = 0.0_core_rknd - s1_zm = zt2zm( pdf_params%s1 ) - s1_zm(gr%nz) = 0.0_core_rknd - s2_zm = zt2zm( pdf_params%s2 ) - s2_zm(gr%nz) = 0.0_core_rknd - stdev_s1_zm = zt2zm( pdf_params%stdev_s1 ) - stdev_s1_zm(gr%nz) = 0.0_core_rknd - stdev_s2_zm = zt2zm( pdf_params%stdev_s2 ) - stdev_s2_zm(gr%nz) = 0.0_core_rknd - stdev_t1_zm = zt2zm( pdf_params%stdev_t1 ) - stdev_t1_zm(gr%nz) = 0.0_core_rknd - stdev_t2_zm = zt2zm( pdf_params%stdev_t2 ) - stdev_t2_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 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 - pdf_params%w1 = trapezoid_zt( w1_zt, w1_zm ) - pdf_params%w2 = trapezoid_zt( w2_zt, w2_zm ) - pdf_params%varnce_w1 = trapezoid_zt( varnce_w1_zt, varnce_w1_zm ) - pdf_params%varnce_w2 = trapezoid_zt( varnce_w2_zt, varnce_w2_zm ) - pdf_params%rt1 = trapezoid_zt( rt1_zt, rt1_zm ) - pdf_params%rt2 = trapezoid_zt( rt2_zt, rt2_zm ) - pdf_params%varnce_rt1 = trapezoid_zt( varnce_rt1_zt, varnce_rt1_zm ) - pdf_params%varnce_rt2 = trapezoid_zt( varnce_rt2_zt, varnce_rt2_zm ) - pdf_params%crt1 = trapezoid_zt( crt1_zt, crt1_zm ) - pdf_params%crt2 = trapezoid_zt( crt2_zt, crt2_zm ) - pdf_params%cthl1 = trapezoid_zt( cthl1_zt, cthl1_zm ) - pdf_params%cthl2 = trapezoid_zt( cthl2_zt, cthl2_zm ) - pdf_params%thl1 = trapezoid_zt( thl1_zt, thl1_zm ) - pdf_params%thl2 = trapezoid_zt( thl2_zt, thl2_zm ) - pdf_params%varnce_thl1 = trapezoid_zt( varnce_thl1_zt, varnce_thl1_zm ) - pdf_params%varnce_thl2 = trapezoid_zt( varnce_thl2_zt, varnce_thl2_zm ) - pdf_params%mixt_frac = trapezoid_zt( mixt_frac_zt, mixt_frac_zm ) - pdf_params%rc1 = trapezoid_zt( rc1_zt, rc1_zm ) - pdf_params%rc2 = trapezoid_zt( rc2_zt, rc2_zm ) - pdf_params%rsl1 = trapezoid_zt( rsl1_zt, rsl1_zm ) - pdf_params%rsl2 = trapezoid_zt( rsl2_zt, rsl2_zm ) - pdf_params%cloud_frac1 = trapezoid_zt( cloud_frac1_zt, cloud_frac1_zm ) - pdf_params%cloud_frac2 = trapezoid_zt( cloud_frac2_zt, cloud_frac2_zm ) - pdf_params%s1 = trapezoid_zt( s1_zt, s1_zm ) - pdf_params%s2 = trapezoid_zt( s2_zt, s2_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_s1 = trapezoid_zt( stdev_s1_zt, stdev_s1_zm ) - pdf_params%stdev_s2 = trapezoid_zt( stdev_s2_zt, stdev_s2_zm ) - pdf_params%stdev_t1 = trapezoid_zt( stdev_t1_zt, stdev_t1_zm ) - pdf_params%stdev_t2 = trapezoid_zt( stdev_t2_zt, stdev_t2_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 crmx_grid_class, only: gr ! Variable - - use crmx_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 crmx_grid_class, only: gr ! Variable - - use crmx_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 crmx_grid_class, only: gr ! Variable - - use crmx_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 crmx_constants_clubb, only: & - rc_tol, & ! Variable(s) - fstderr - - use crmx_grid_class, only: gr ! Variable - - use crmx_pdf_parameter_module, only: & - pdf_parameter ! Derived data type - - use crmx_error_code, only: & - clubb_at_least_debug_level ! Procedure - - use crmx_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) :: & - s_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 - - s_mean(k) = pdf_params(k)%mixt_frac * pdf_params(k)%s1 + & - (1.0_core_rknd-pdf_params(k)%mixt_frac) * pdf_params(k)%s2 - - 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( s_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( s_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)%s1 = ", pdf_params(k)%s1 - write(fstderr,*) "pdf_params(k)%s2 = ", pdf_params(k)%s2 - 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 crmx_grid_class, only: gr ! Variable - - use crmx_error_code, only : & - clubb_at_least_debug_level ! Procedure(s) - - use crmx_constants_clubb, only: & - fstderr, & ! Variable(s) - zero_threshold - - use crmx_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 crmx_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 - -!=============================================================================== - - end module crmx_clubb_core -! vim: set expandtab tabstop=2 shiftwidth=2 textwidth=100 autoindent: diff --git a/src/physics/spcam/crm/CLUBB/crmx_clubb_precision.F90 b/src/physics/spcam/crm/CLUBB/crmx_clubb_precision.F90 deleted file mode 100644 index b594d17061..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_clubb_precision.F90 +++ /dev/null @@ -1,24 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: clubb_precision.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_clubb_precision - - implicit none - - public :: stat_nknd, stat_rknd, time_precision, dp, sp, core_rknd - - private ! Default scope - - ! 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 ), & - dp = selected_real_kind( p=12 ), & ! double precision - sp = selected_real_kind( p=5 ), & ! single precision - core_rknd = CLUBB_REAL_TYPE ! Value from the preprocessor directive - -end module crmx_clubb_precision -!------------------------------------------------------------------------------- diff --git a/src/physics/spcam/crm/CLUBB/crmx_constants_clubb.F90 b/src/physics/spcam/crm/CLUBB/crmx_constants_clubb.F90 deleted file mode 100644 index a6108f6419..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_constants_clubb.F90 +++ /dev/null @@ -1,375 +0,0 @@ -!----------------------------------------------------------------------------- -! $Id: constants_clubb.F90 6132 2013-03-28 13:09:40Z vlarson@uwm.edu $ -!============================================================================= -module crmx_constants_clubb - - ! Description: - ! Contains frequently occuring model constants - - ! References: - ! None - !--------------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - dp, & - core_rknd - -!#ifdef CLUBB_CAM /* Set constants as they're set in CAM */ -#if defined(CLUBB_CAM) || defined(CRM) /* set constants as they' are set in CAM for CLUBB_CAM or MMF */ - 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 = 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 -#if defined(CLUBB_CAM) || defined(CRM) /* set constants as they' are set in CAM for CLUBB_CAM or MMF */ - - 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 - - ! 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] - s_mellor_tol = 1.e-8_core_rknd, & ! [kg/kg] - t_mellor_tol = s_mellor_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, & ! [kg/kg] - Nc_tol = 1.0E-10_core_rknd, & ! [#/kg] - rr_tol = 1.0E-10_core_rknd, & ! [kg/kg] - Nr_tol = 1.0E-10_core_rknd ! [#/kg] - - ! 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=time_precision), parameter, public :: & - sec_per_day = 86400.0_time_precision, & ! Seconds in a day. - sec_per_hr = 3600.0_time_precision, & ! Seconds in an hour. - sec_per_min = 60.0_time_precision, & ! Seconds in a minute. - min_per_hr = 60.0_time_precision ! 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 - -!============================================================================= - -end module crmx_constants_clubb diff --git a/src/physics/spcam/crm/CLUBB/crmx_corr_matrix_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_corr_matrix_module.F90 deleted file mode 100644 index 1a9eaafd0b..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_corr_matrix_module.F90 +++ /dev/null @@ -1,181 +0,0 @@ -!$Id: corr_matrix_module.F90 5997 2012-12-18 20:47:09Z raut@uwm.edu $ -!--------------------------------------------------------------------------------------------------- -module crmx_corr_matrix_module - - implicit none - - ! Latin hypercube indices / Correlation array indices - integer, public :: & - iiLH_s_mellor = -1, & - iiLH_t_mellor = -1, & - iiLH_w = -1 -!$omp threadprivate(iiLH_s_mellor, iiLH_t_mellor, iiLH_w) - - integer, public :: & - iiLH_rrain = -1, & - iiLH_rsnow = -1, & - iiLH_rice = -1, & - iiLH_rgraupel = -1 -!$omp threadprivate(iiLH_rrain, iiLH_rsnow, iiLH_rice, iiLH_rgraupel) - - integer, public :: & - iiLH_Nr = -1, & - iiLH_Nsnow = -1, & - iiLH_Ni = -1, & - iiLH_Ngraupel = -1, & - iiLH_Nc = -1 -!$omp threadprivate(iiLH_Nr, iiLH_Nsnow, iiLH_Ni, iiLH_Ngraupel, iiLH_Nc) - - public :: read_correlation_matrix - - private :: get_corr_var_index - - private - - contains - - !----------------------------------------------------------------------------- - subroutine read_correlation_matrix( iunit, input_file, d_variables, & - corr_array ) - - ! Description: - ! Reads a correlation variance array from a file and stores it in an array. - !----------------------------------------------------------------------------- - - use crmx_input_reader, only: & - one_dim_read_var, & ! Variable(s) - read_one_dim_file, deallocate_one_dim_vars, count_columns ! Procedure(s) - - use crmx_matrix_operations, only: set_lower_triangular_matrix ! Procedure(s) - - use crmx_constants_clubb, only: fstderr ! Variable(s) - - use crmx_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 ! Correlation variance 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 - ! (e.g. Nc and any variable other than s_mellor ) are assumed to be 0. - corr_array(:,:) = 0.0_core_rknd - - ! Set main diagonal to 1 - do i=1, d_variables - corr_array(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 ) - 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( "s" ) - i = iiLH_s_mellor - - case( "t" ) - i = iiLH_t_mellor - - case( "w" ) - i = iiLH_w - - case( "Nc" ) - i = iiLH_Nc - - case( "rrain" ) - i = iiLH_rrain - - case( "Nr" ) - i = iiLH_Nr - - case( "rice" ) - i = iiLH_rice - - case( "Ni" ) - i = iiLH_Ni - - case( "rsnow" ) - i = iiLH_rsnow - - case( "Nsnow" ) - i = iiLH_Nsnow - - end select - - return - - end function get_corr_var_index -end module crmx_corr_matrix_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_csr_matrix_class_3array.F90 b/src/physics/spcam/crm/CLUBB/crmx_csr_matrix_class_3array.F90 deleted file mode 100644 index 1891bd6945..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_csr_matrix_class_3array.F90 +++ /dev/null @@ -1,522 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: csr_matrix_class_3array.F90 5529 2011-11-29 19:49:15Z connork@uwm.edu $ -!=============================================================================== -module crmx_csr_matrix_class - - ! 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_class, & - 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, pointer, 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. - - contains - - !============================================================================ - subroutine initialize_csr_class - - ! 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 crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_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_class - -end module crmx_csr_matrix_class diff --git a/src/physics/spcam/crm/CLUBB/crmx_diagnose_correlation_module.f90 b/src/physics/spcam/crm/CLUBB/crmx_diagnose_correlation_module.f90 deleted file mode 100644 index 1160134ab3..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_diagnose_correlation_module.f90 +++ /dev/null @@ -1,489 +0,0 @@ -! $Id$ -module crmx_diagnose_correlations_module - - use crmx_clubb_precision, only: & - core_rknd - - implicit none - - public :: diagnose_KK_corr, diagnose_LH_corr, & - calc_mean, calc_varnce, calc_w_corr - - - private :: diagnose_corr - - - contains - -!----------------------------------------------------------------------- - subroutine diagnose_KK_corr( Ncm, rrainm, Nrm, & ! intent(in) - Ncp2_on_Ncm2, rrp2_on_rrm2, Nrp2_on_Nrm2, & - corr_ws, corr_wrr, corr_wNr, corr_wNc, & - pdf_params, & - corr_rrNr_p, corr_srr_p, corr_sNr_p, corr_sNc_p, & - corr_rrNr, corr_srr, corr_sNr, corr_sNc ) ! intent(inout) - - ! Description: - ! This subroutine diagnoses the correlation matrix in order to feed it - ! into KK microphysics. - - ! References: - ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 - ! (see CLUBB-Trac:ticket:514) - !----------------------------------------------------------------------- - - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_pdf_parameter_module, only: & - pdf_parameter ! Type - - use crmx_constants_clubb, only: & - w_tol, & ! [m/s] - s_mellor_tol, & ! [kg/kg] - Nc_tol, & ! [num/kg] - rr_tol, & ! [kg/kg] - Nr_tol ! [num/kg] - - use crmx_stats_type, only: & - stat_update_var_pt ! Procedure(s) - - implicit none - - intrinsic :: sqrt - - ! Local Constants - integer, parameter :: & - n_variables = 5 - - ! Input Variables - - real( kind = core_rknd ), intent(in) :: & - Ncm, & ! Cloud droplet number conc. [num/kg] - rrainm, & ! rain water mixing ratio [kg/kg] - Nrm, & ! Mean rain drop concentration [num/kg] - Ncp2_on_Ncm2, & ! Variance of Nc divided by Ncm^2 [-] - rrp2_on_rrm2, & ! Variance of rrain divided by rrainm^2 [-] - Nrp2_on_Nrm2, & ! Variance of Nr divided by Nrm^2 [-] - corr_ws, & ! Correlation between s_mellor and w [-] - corr_wrr, & ! Correlation between rrain and w [-] - corr_wNr, & ! Correlation between Nr and w [-] - corr_wNc, & ! Correlation between Nc and w [-] - corr_rrNr_p, & ! Prescribed correlation between rrain and Nr [-] - corr_srr_p, & ! Prescribed correlation between s and rrain [-] - corr_sNr_p, & ! Prescribed correlation between s and Nr [-] - corr_sNc_p ! Prescribed correlation between s and Nc [-] - - type(pdf_parameter), intent(in) :: & - pdf_params ! PDF parameters [units vary] - - ! Input/Output Variables - real( kind = core_rknd ), intent(inout) :: & - corr_rrNr, & ! Correlation between rrain and Nr [-] - corr_srr, & ! Correlation between s and rrain [-] - corr_sNr, & ! Correlation between s and Nr [-] - corr_sNc ! Correlation between s and Nc [-] - - - - ! Local Variables - real( kind = core_rknd ), dimension(n_variables, n_variables) :: & - corr_matrix_approx, & ! [-] - corr_matrix_prescribed ! [-] - - real( kind = core_rknd ), dimension(n_variables) :: & - sqrt_xp2_on_xm2, & ! sqrt of x_variance / x_mean^2 [units vary] - xm ! means of the hydrometeors [units vary] - - ! Indices of the hydrometeors - integer :: & - ii_w = 1, & - ii_s = 2, & - ii_rrain = 3, & - ii_Nr = 4, & - ii_Nc = 5 - - integer :: i, j ! Loop Iterators - - - !-------------------- Begin code -------------------- - - ! set up xp2_on_xm2 - - ! TODO Why is wp2_on_wm2=1 - ! S_i is set to 1 for s_mellor and w, because s_mellorm could be 0 - sqrt_xp2_on_xm2(ii_w) = 1._core_rknd - sqrt_xp2_on_xm2(ii_s) = 1._core_rknd - - sqrt_xp2_on_xm2(ii_rrain) = sqrt(rrp2_on_rrm2) - sqrt_xp2_on_xm2(ii_Nr) = sqrt(Nrp2_on_Nrm2) - sqrt_xp2_on_xm2(ii_Nc) = sqrt(Ncp2_on_Ncm2) - - ! initialize the correlation matrix with 0 - do i=1, n_variables - do j=1, n_variables - corr_matrix_approx(i,j) = 0._core_rknd - corr_matrix_prescribed(i,j) = 0._core_rknd - end do - end do - - ! set diagonal of the correlation matrix to 1 - do i = 1, n_variables - corr_matrix_approx(i,i) = 1._core_rknd - corr_matrix_prescribed(i,i) = 1._core_rknd - end do - - - ! set the first row to the corresponding prescribed correlations - corr_matrix_approx(ii_s,1) = corr_ws - corr_matrix_approx(ii_rrain,1) = corr_wrr - corr_matrix_approx(ii_Nr,1) = corr_wNr - corr_matrix_approx(ii_Nc,1) = corr_wNc - - !corr_matrix_prescribed = corr_matrix_approx - - ! set up the prescribed correlation matrix - if( ii_rrain > ii_Nr ) then - corr_matrix_prescribed(ii_rrain, ii_Nr) = corr_rrNr_p - else - corr_matrix_prescribed(ii_Nr, ii_rrain) = corr_rrNr_p - end if - - if ( ii_s > ii_rrain ) then - corr_matrix_prescribed(ii_s, ii_rrain) = corr_srr_p - else - corr_matrix_prescribed(ii_rrain, ii_s) = corr_srr_p - end if - - if ( ii_s > ii_Nr ) then - corr_matrix_prescribed(ii_s, ii_Nr) = corr_sNr_p - else - corr_matrix_prescribed(ii_Nr, ii_s) = corr_sNr_p - end if - - if ( ii_s > ii_Nc ) then - corr_matrix_prescribed(ii_s, ii_Nc) = corr_sNc_p - else - corr_matrix_prescribed(ii_Nc, ii_s) = corr_sNc_p - end if - - call diagnose_corr( n_variables, sqrt_xp2_on_xm2, corr_matrix_prescribed, & !intent(in) - corr_matrix_approx ) ! intent(inout) - - if( ii_rrain > ii_Nr ) then - corr_rrNr = corr_matrix_approx(ii_rrain, ii_Nr) - else - corr_rrNr = corr_matrix_approx(ii_Nr, ii_rrain) - end if - - if ( ii_s > ii_rrain ) then - corr_srr = corr_matrix_approx(ii_s, ii_rrain) - else - corr_srr = corr_matrix_approx(ii_rrain, ii_s) - end if - - if ( ii_s > ii_Nr ) then - corr_sNr = corr_matrix_approx(ii_s, ii_Nr) - else - corr_sNr = corr_matrix_approx(ii_Nr, ii_s) - end if - - if ( ii_s > ii_Nc ) then - corr_sNc = corr_matrix_approx(ii_s, ii_Nc) - else - corr_sNc = corr_matrix_approx(ii_Nc, ii_s) - end if - - end subroutine diagnose_KK_corr - -!----------------------------------------------------------------------- - subroutine diagnose_LH_corr( xp2_on_xm2, d_variables, corr_matrix_prescribed, & !intent(in) - corr_array ) ! intent(inout) - - ! 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_corr_matrix_module, only: & - iiLH_w ! Variable(s) - - implicit none - - intrinsic :: max, sqrt, transpose - - ! Input Variables - integer, intent(in) :: d_variables - - real( kind = core_rknd ), dimension(d_variables, d_variables), intent(in) :: & - corr_matrix_prescribed - - real( kind = core_rknd ), dimension(d_variables), intent(in) :: & - xp2_on_xm2 ! ratios of x_variance over x_mean^2 - - ! Input/Output variables - real( kind = core_rknd ), dimension(d_variables, d_variables), intent(inout) :: & - corr_array - - ! Local Variables - real( kind = core_rknd ), dimension(d_variables, d_variables) :: & - corr_matrix_pre_swapped - - real( kind = core_rknd ), dimension(d_variables) :: & - swap_array - - !-------------------- Begin code -------------------- - - ! Swap the w-correlations to the first row - swap_array = corr_array(:, 1) - corr_array(1:iiLH_w, 1) = corr_array(iiLH_w, iiLH_w:1:-1) - corr_array((iiLH_w+1):d_variables, 1) = corr_array((iiLH_w+1):d_variables, iiLH_w) - corr_array(iiLH_w, 1:iiLH_w) = swap_array(iiLH_w:1:-1) - corr_array((iiLH_w+1):d_variables, iiLH_w) = swap_array((iiLH_w+1):d_variables) - - corr_matrix_pre_swapped = corr_matrix_prescribed - swap_array = corr_matrix_pre_swapped (:,1) - corr_matrix_pre_swapped(1:iiLH_w, 1) = corr_matrix_pre_swapped(iiLH_w, iiLH_w:1:-1) - corr_matrix_pre_swapped((iiLH_w+1):d_variables, 1) = corr_matrix_pre_swapped( & - (iiLH_w+1):d_variables, iiLH_w) - corr_matrix_pre_swapped(iiLH_w, 1:iiLH_w) = swap_array(iiLH_w:1:-1) - corr_matrix_pre_swapped((iiLH_w+1):d_variables, iiLH_w) = swap_array((iiLH_w+1):d_variables) - - ! diagnose correlations - call diagnose_corr( d_variables, sqrt(xp2_on_xm2), corr_matrix_pre_swapped, & - corr_array) - - ! Swap rows back - swap_array = corr_array(:, 1) - corr_array(1:iiLH_w, 1) = corr_array(iiLH_w, iiLH_w:1:-1) - corr_array((iiLH_w+1):d_variables, 1) = corr_array((iiLH_w+1):d_variables, iiLH_w) - corr_array(iiLH_w, 1:iiLH_w) = swap_array(iiLH_w:1:-1) - corr_array((iiLH_w+1):d_variables, iiLH_w) = swap_array((iiLH_w+1):d_variables) - - end subroutine diagnose_LH_corr - -!----------------------------------------------------------------------- - subroutine diagnose_corr( n_variables, sqrt_xp2_on_xm2, 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_parameters_tunable, only: & - alpha_corr ! Constant(s) - - use crmx_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_xp2_on_xm2 ! sqrt of x_variance / x_mean^2 [units vary] - - 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 -------------------- - - ! 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_xp2_on_xm2(i) * sqrt_xp2_on_xm2(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 - - !----------------------------------------------------------------------- - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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 crmx_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 crmx_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 - -end module crmx_diagnose_correlations_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_diffusion.F90 b/src/physics/spcam/crm/CLUBB/crmx_diffusion.F90 deleted file mode 100644 index 75956e82d6..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_diffusion.F90 +++ /dev/null @@ -1,800 +0,0 @@ -! $Id: diffusion.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module crmx_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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_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 crmx_diffusion diff --git a/src/physics/spcam/crm/CLUBB/crmx_endian.F90 b/src/physics/spcam/crm/CLUBB/crmx_endian.F90 deleted file mode 100644 index 6886f158a1..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_endian.F90 +++ /dev/null @@ -1,173 +0,0 @@ -!---------------------------------------------------------------------- -! $Id: endian.F90 3784 2009-07-14 21:29:16Z dschanen@uwm.edu $ - -!---------------------------------------------------------------------- -module crmx_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 - - REAL(KIND=4), 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=4) :: i_element - INTEGER(KIND=4) :: 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 -!------------------------------------------------------------------------------- - - implicit none - - ! External - intrinsic :: mvbits, transfer - - real(kind=8), intent(inout) :: realInOut ! a single 64 bit, 8 byte - ! REAL data element - ! Local variables (generic 64 bit INTEGER spaces): - - integer(kind=8) :: i_element - integer(kind=8) :: 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 crmx_endian - -!------------------------------------------------------------------------------- diff --git a/src/physics/spcam/crm/CLUBB/crmx_error_code.F90 b/src/physics/spcam/crm/CLUBB/crmx_error_code.F90 deleted file mode 100644 index bddf1c39b2..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_error_code.F90 +++ /dev/null @@ -1,227 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: error_code.F90 5906 2012-08-10 23:20:05Z dschanen@uwm.edu $ -!------------------------------------------------------------------------------- - -module crmx_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 :: & - reportError, & - 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 reportError( err_code ) -! -! Description: -! Reports meaning of error code to console. -! -!------------------------------------------------------------------------------- - - use crmx_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 reportError -!------------------------------------------------------------------------------- - 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 crmx_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 crmx_error_code -!------------------------------------------------------------------------------- diff --git a/src/physics/spcam/crm/CLUBB/crmx_extrapolation.F90 b/src/physics/spcam/crm/CLUBB/crmx_extrapolation.F90 deleted file mode 100644 index 38c4837bd9..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_extrapolation.F90 +++ /dev/null @@ -1,90 +0,0 @@ -!$Id: extrapolation.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_extrapolation - - implicit none - - public :: lin_ext_zm_bottom, lin_ext_zt_bottom - - private ! Default scope - - contains -!=============================================================================== - pure function lin_ext_zm_bottom( var_zmp2, var_zmp1, & - zmp2, zmp1, zm ) & - result( var_zm ) - - ! Description: - ! This function computes the value of a momentum-level variable at a bottom - ! grid level by using a linear extension of the values of the variable at - ! the two levels immediately above the level where the result value is - ! needed. - - ! References: - ! None - !----------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - var_zmp2, & ! Momentum level variable at level (k+2) [units vary] - var_zmp1, & ! Momentum level variable at level (k+1) [units vary] - zmp2, & ! Altitude at momentum level (k+2) [m] - zmp1, & ! Altitude at momentum level (k+1) [m] - zm ! Altitude at momentum level (k) [m] - - ! Return Variable - real( kind = core_rknd ) :: var_zm ! Momentum level variable at level (k) [units vary] - - ! ---- Begin Code ----- - - var_zm = ( ( var_zmp2 - var_zmp1 ) / ( zmp2 - zmp1 ) ) & - * ( zm - zmp1 ) + var_zmp1 - - return - end function lin_ext_zm_bottom - -!=============================================================================== - pure function lin_ext_zt_bottom( var_ztp2, var_ztp1, & - ztp2, ztp1, zt ) & - result( var_zt ) - - ! Description: - ! This function computes the value of a thermodynamic-level variable at a - ! bottom grid level by using a linear extension of the values of the - ! variable at the two levels immediately above the level where the result - ! value is needed. - ! - ! References: - ! None - !----------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - var_ztp2, & ! Thermodynamic level variable at level (k+2) [units vary] - var_ztp1, & ! Thermodynamic level variable at level (k+1) [units vary] - ztp2, & ! Altitude at thermodynamic level (k+2) [m] - ztp1, & ! Altitude at thermodynamic level (k+1) [m] - zt ! Altitude at thermodynamic level (k) [m] - - ! Return Variable - real( kind = core_rknd ) :: var_zt ! Thermodynamic level variable at level (k) [units vary] - - ! ---- Begin Code ----- - - var_zt = ( ( var_ztp2 - var_ztp1 ) / ( ztp2 - ztp1 ) ) & - * ( zt - ztp1 ) + var_ztp1 - - return - end function lin_ext_zt_bottom - -end module crmx_extrapolation diff --git a/src/physics/spcam/crm/CLUBB/crmx_file_functions.F90 b/src/physics/spcam/crm/CLUBB/crmx_file_functions.F90 deleted file mode 100644 index 82d1eb1d10..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_file_functions.F90 +++ /dev/null @@ -1,156 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: file_functions.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module crmx_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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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 ---- - - ! 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 ) - - 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 crmx_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 crmx_file_functions diff --git a/src/physics/spcam/crm/CLUBB/crmx_fill_holes.F90 b/src/physics/spcam/crm/CLUBB/crmx_fill_holes.F90 deleted file mode 100644 index 8e17d3bc53..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_fill_holes.F90 +++ /dev/null @@ -1,487 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: fill_holes.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module crmx_fill_holes - - implicit none - - public :: fill_holes_driver, & - vertical_avg, & - vertical_integral - - private :: fill_holes_multiplicative - - private ! Set Default Scope - - contains - - !============================================================================= - subroutine fill_holes_driver( num_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 crmx_grid_class, only: & - gr ! Variable - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - 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 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_pts, upper_hf_level-num_pts, 1 - - begin_idx = k - num_pts - end_idx = k + num_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_driver - - !============================================================================= - 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 crmx_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 crmx_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 crmx_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 - -!=============================================================================== - -end module crmx_fill_holes diff --git a/src/physics/spcam/crm/CLUBB/crmx_gmres_cache.F90 b/src/physics/spcam/crm/CLUBB/crmx_gmres_cache.F90 deleted file mode 100644 index 008ce4925d..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_gmres_cache.F90 +++ /dev/null @@ -1,171 +0,0 @@ -!---------------------------------------------------------------------------- -! $Id: gmres_cache.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!============================================================================== -module crmx_gmres_cache - -#ifdef MKL - - use crmx_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, pointer, 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. - - real( kind = dp ), public, pointer, 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) - - 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 - - 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. - - 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 crmx_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 crmx_gmres_cache diff --git a/src/physics/spcam/crm/CLUBB/crmx_gmres_wrap.F90 b/src/physics/spcam/crm/CLUBB/crmx_gmres_wrap.F90 deleted file mode 100644 index bcab38cdb4..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_gmres_wrap.F90 +++ /dev/null @@ -1,391 +0,0 @@ -!---------------------------------------------------------------------------- -! $Id: gmres_wrap.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!============================================================================== - -module crmx_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 crmx_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 crmx_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 crmx_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_class 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_class - ! 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 = dble(csr_a) - dbl_rhs = dble(rhs) - - ! 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 crmx_gmres_wrap diff --git a/src/physics/spcam/crm/CLUBB/crmx_grid_class.F90 b/src/physics/spcam/crm/CLUBB/crmx_grid_class.F90 deleted file mode 100644 index 26d1a8c86a..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_grid_class.F90 +++ /dev/null @@ -1,2036 +0,0 @@ -!------------------------------------------------------------------------ -! $Id: grid_class.F90 6116 2013-03-22 00:37:40Z bmg2@uwm.edu $ -!=============================================================================== -module crmx_grid_class - - ! Description: - ! - ! Definition of a grid class and associated functions - ! - ! The grid specification is as follows: - ! - ! + ================== zm(nzmax) =========GP======= - ! | - ! | - ! 1/dzt(nzmax) + ------------------ zt(nzmax) ---------GP------- - ! | | - ! | | - ! + 1/dzm(nzmax-1) ================== zm(nzmax-1) ================ - ! | - ! | - ! + ------------------ zt(nzmax-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 - - ! 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 crmx_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, zt2zm_linear, zm2zt_linear - - 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, a pointer can be used in the same - ! manner as an allocatable array, as we have done here (the grid - ! pointers are always allocated rather than assigned and nullified - ! like real pointers). Note that these must be de-allocated to prevent - ! memory leaks. - real( kind = core_rknd ), pointer, dimension(:) :: & - zm, & ! Momentum grid - zt ! Thermo grid - real( kind = core_rknd ), pointer, 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 ), pointer, 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 ), pointer, 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) gr - -! Modification for using CLUBB in a host model (i.e. one grid per column) -!$omp threadprivate(gr) - - ! Interfaces provided for function overloading - - ! Interpolation/extension functions - interface zt2zm_linear - ! 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 linear_interpolated_azmk, linear_interpolated_azm - end interface - - interface zm2zt_linear - ! 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 linear_interpolated_azt, linear_interpolated_aztk - end interface - - interface zt2zm - ! This version uses cublic spline interpolation of Stefen (1990). - module procedure cubic_interpolated_azmk, cubic_interpolated_azm - end interface - - interface zm2zt - ! As above, but for interpolating zm to zt levels. - module procedure cubic_interpolated_aztk, cubic_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 crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_error_code, only: & - clubb_at_least_debug_level ! Procedure(s) - - use crmx_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 ! 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 crmx_constants_clubb, only: & - fstderr ! Constant - - 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 crmx_constants_clubb, only: fstderr ! Constant - - use crmx_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 crmx_constants_clubb, only: & - fstderr ! Variable(s) - use crmx_file_functions, only: & - file_read_1d ! Procedure(s) - use crmx_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 - - ! 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 ) - - ! 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 - - !============================================================================= - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_interpolation, only: linear_interp_factor - - implicit none - - ! Input Variable - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azt - - ! Return Variable - real( kind = core_rknd ), dimension(gr%nz) :: linear_interpolated_azm - - ! Local Variable - integer :: k - - ! ---- Begin Code ---- - - ! Do the actual interpolation. - ! Use 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 - -! ! 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(gr%nz) = 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_azm(gr%nz) = & - ( ( 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) - - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_interpolation, only: linear_interp_factor - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azt - - integer, intent(in) :: k - - ! Return Variable - real( kind = core_rknd ) :: linear_interpolated_azmk - - ! ---- Begin Code ---- - - ! Do the actual interpolation. - ! Use a 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 - - !============================================================================= - pure 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 crmx_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 ---- - - forall( k = 1 : gr%nz ) - tmp(k) = cubic_interpolated_azmk( azt, k ) - end forall - - cubic_interpolated_azm = tmp - - return - - end function cubic_interpolated_azm - - !============================================================================= - pure 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 crmx_interpolation, only: mono_cubic_interp - - use crmx_clubb_precision, only: & - core_rknd ! Variable(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 crmx_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 - integer, intent(in) :: m_lev ! Momentum level index - - ! Output - real( kind = core_rknd ), dimension(2) :: azt_weight ! Weights of the thermodynamic levels. - - ! Local Variables - real( kind = core_rknd ) :: factor - integer :: k - - ! ---- Begin Code ---- - - ! 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) = 1.0_core_rknd - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_interpolation, only: linear_interp_factor - - implicit none - - ! Input Variable - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azm - - ! Output Variable - real( kind = core_rknd ), dimension(gr%nz) :: linear_interpolated_azt - - ! Local Variable - integer :: k ! Index - - ! ---- Begin Code ---- - - ! Do actual interpolation. - ! Use a 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 ! gr%nz .. 2 -! ! Set the value of azt at level 1 (the lowermost level in the model) to the -! ! value of azm at level 1. -! interpolated_azt(1) = 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_azt(1) = & - ( ( azm(2)-azm(1) ) / ( gr%zm(2)-gr%zm(1) ) ) & - * ( gr%zt(1)-gr%zm(1) ) + azm(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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_interpolation, only: linear_interp_factor - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azm - - integer, intent(in) :: k - - ! Return Variables - real( kind = core_rknd ) :: linear_interpolated_aztk - - ! ---- Begin Code ---- - - ! Do actual interpolation. - ! Use a 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 - - !============================================================================= - pure 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 crmx_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 ---- - - forall ( k = 1 : gr%nz ) - tmp(k) = cubic_interpolated_aztk( azm, k ) - end forall - - cubic_interpolated_azt = tmp - - return - - end function cubic_interpolated_azt - - - !============================================================================= - pure 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 crmx_interpolation, only: mono_cubic_interp - - use crmx_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 crmx_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 - integer, intent(in) :: t_lev ! Thermodynamic level index. - - ! Output - real( kind = core_rknd ), dimension(2) :: azm_weight ! Weights of the momentum levels. - - ! Local Variables - real( kind = core_rknd ) :: factor - integer :: k - - ! ---- Begin Code ---- - - ! 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) = 1.0_core_rknd - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variable - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azm - - ! Return Variable - real( kind = core_rknd ), dimension(gr%nz) :: gradzm - - ! Local Variable - integer :: k - - ! ---- Begin Code ---- - - ! Compute vertical derivatives. - 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 ! gr%nz .. 2 -! ! 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(1) = 0. - ! 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(1) = gradzm(2) - - 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variable - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azt - - ! Output Variable - real( kind = core_rknd ), dimension(gr%nz) :: gradzt - - ! Local Variable - integer :: k - - ! ---- Begin Code ---- - - ! Compute vertical derivative. - 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 ! 1 .. gr%nz-1 -! ! 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(gr%nz) = 0. - ! 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(gr%nz) = gradzt(gr%nz-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 crmx_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 - - ! ---- Begin Code ---- - - forall ( indx = 1 : xdim ) - tmp(indx) = x((xdim+1) - (indx)) - end forall - - flip = tmp - - return - end function flip - -!=============================================================================== - -end module crmx_grid_class diff --git a/src/physics/spcam/crm/CLUBB/crmx_hydrostatic_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_hydrostatic_module.F90 deleted file mode 100644 index 48231ba015..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_hydrostatic_module.F90 +++ /dev/null @@ -1,746 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: hydrostatic_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module crmx_hydrostatic_module - - implicit none - - private ! Default Scope - - public :: hydrostatic, & - inverse_hydrostatic - - private :: calc_exner_const_thvm, & - calc_exner_linear_thvm, & - calc_z_linear_thvm - - contains - -!=============================================================================== - subroutine hydrostatic( thvm, p_sfc, & - p_in_Pa, p_in_Pa_zm, & - exner, exner_zm, & - rho, rho_zm ) - - ! Description: - ! This subroutine integrates the hydrostatic equation. - ! - ! The hydrostatic equation is of the form: - ! - ! dp/dz = - rho * grav. - ! - ! This equation can be re-written in terms of d(exner)/dz, such that: - ! - ! [ { p0^(R_d/C_p) * p^(C_v/C_p) } / { R_d * rho } ] * d(exner)/dz - ! = - grav / C_p; - ! - ! which can also be expressed as: - ! - ! [ { p0^(R_d/C_p) * p^(C_v/C_p) } / { R_d * rho_d * ( 1 + r_v + r_c ) } ] - ! * d(exner)/dz - ! = - grav / C_p. - ! - ! Furthermore, the moist equation of state can be written as: - ! - ! theta = - ! [ { p0^(R_d/C_p) * p^(C_v/C_p) } - ! / { R_d * rho_d * ( 1 + (R_v/R_d)*r_v ) } ]. - ! - ! The relationship between theta and theta_v (including water vapor and - ! cloud water) is: - ! - ! theta_v = theta * [ ( 1 + (R_v/R_d)*r_v ) / ( 1 + r_v + r_c ) ]; - ! - ! which, when substituted into the above equation, changes the equation of - ! state to: - ! - ! theta_v = - ! [ { p0^(R_d/C_p) * p^(C_v/C_p) } - ! / { R_d * rho_d * ( 1 + r_v + r_c ) } ]. - ! - ! This equation is substituted into the d(exner)/dz form of the hydrostatic - ! equation, resulting in: - ! - ! theta_v * d(exner)/dz = - grav / C_p; - ! - ! which can be re-written as: - ! - ! d(exner)/dz = - grav / ( C_p * theta_v ). - ! - ! This subroutine integrates the above equation to solve for exner, such - ! that: - ! - ! INT(exner_1:exner_2) d(exner) = - ! - ( grav / C_p ) * INT(z_1:z_2) ( 1 / theta_v ) dz. - ! - ! - ! The resulting value of exner is used to calculate pressure. Then, the - ! values of pressure, exner, and theta_v can be used to calculate density. - - ! References: - ! - !------------------------------------------------------------------------ - - use crmx_constants_clubb, only: & - kappa, & ! Variable(s) - p0, & - Rd, & - zero_threshold - - use crmx_grid_class, only: & - gr, & ! Variable(s) - zm2zt, & ! Procedure(s) - zt2zm - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - p_sfc ! Pressure at the surface [Pa] - - real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & - thvm ! Virtual potential temperature [K] - - ! Output Variables - real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & - p_in_Pa, & ! Pressure (thermodynamic levels) [Pa] - p_in_Pa_zm, & ! Pressure on momentum levels [Pa] - exner, & ! Exner function (thermodynamic levels) [-] - exner_zm, & ! Exner function on momentum levels [-] - rho, & ! Density (thermodynamic levels) [kg/m^3] - rho_zm ! Density on momentum levels [kg/m^3] - - ! Local Variables - real( kind = core_rknd ), dimension(gr%nz) :: & - thvm_zm ! Theta_v interpolated to momentum levels [K] - - real( kind = core_rknd ) :: & - dthvm_dz ! Constant d(thvm)/dz between successive levels [K/m] - - integer :: k - - ! Interpolate thvm from thermodynamic to momentum levels. Linear - ! interpolation is used, except for the uppermost momentum level, where a - ! linear extension is used. Since thvm is considered to either be constant - ! or vary linearly over the depth of a grid level, this interpolation is - ! consistent with the rest of this code. - thvm_zm = zt2zm( thvm ) - - ! Exner is defined on thermodynamic grid levels except for the value at - ! index 1. Since thermodynamic level 1 is below the surface, it is - ! disregarded, and the value of exner(1) corresponds to surface value, which - ! is actually at momentum level 1. - exner(1) = ( p_sfc/p0 )**kappa - exner_zm(1) = ( p_sfc/p0 )**kappa - - ! Consider the value of exner at thermodynamic level (2) to be based on - ! a constant thvm between thermodynamic level (2) and momentum level (1), - ! which is the surface or model lower boundary. Since thlm(1) is set equal - ! to thlm(2), the values of thvm are considered to be basically constant - ! near the ground. - exner(2) & - = calc_exner_const_thvm( thvm(2), gr%zt(2), gr%zm(1), exner(1) ) - - ! Given the value of exner at thermodynamic level k-1, and considering - ! thvm to vary linearly between its values at thermodynamic levels k - ! and k-1, the value of exner can be found at thermodynamic level k, - ! as well as at intermediate momentum level k-1. - do k = 3, gr%nz - - dthvm_dz = gr%invrs_dzm(k-1) * ( thvm(k) - thvm(k-1) ) - - if ( dthvm_dz /= 0.0_core_rknd ) then - - exner(k) & - = calc_exner_linear_thvm( thvm(k-1), dthvm_dz, & - gr%zt(k-1), gr%zt(k), exner(k-1) ) - - exner_zm(k-1) & - = calc_exner_linear_thvm( thvm(k-1), dthvm_dz, & - gr%zt(k-1), gr%zm(k-1), exner(k-1) ) - - else ! dthvm_dz = 0 - - exner(k) & - = calc_exner_const_thvm & - ( thvm(k), gr%zt(k), gr%zt(k-1), exner(k-1) ) - - exner_zm(k-1) & - = calc_exner_const_thvm & - ( thvm(k), gr%zm(k-1), gr%zt(k-1), exner(k-1) ) - - endif - - enddo ! k = 3, gr%nz - - ! Find the value of exner_zm at momentum level gr%nz by using a linear - ! extension of thvm from the two thermodynamic level immediately below - ! momentum level gr%nz. - dthvm_dz = ( thvm_zm(gr%nz) - thvm(gr%nz) ) & - / ( gr%zm(gr%nz) - gr%zt(gr%nz) ) - - if ( dthvm_dz /= 0.0_core_rknd ) then - - exner_zm(gr%nz) & - = calc_exner_linear_thvm & - ( thvm(gr%nz), dthvm_dz, & - gr%zt(gr%nz), gr%zm(gr%nz), exner(gr%nz) ) - - else ! dthvm_dz = 0 - - exner_zm(gr%nz) & - = calc_exner_const_thvm & - ( thvm(gr%nz), gr%zm(gr%nz), gr%zt(gr%nz), exner(gr%nz) ) - - endif - - ! Calculate pressure based on the values of exner. - - do k = 1, gr%nz - p_in_Pa(k) = p0 * exner(k)**( 1._core_rknd/kappa ) - p_in_Pa_zm(k) = p0 * exner_zm(k)**( 1._core_rknd/kappa ) - enddo - - ! Calculate density based on pressure, exner, and thvm. - - do k = 1, gr%nz - rho(k) = p_in_Pa(k) / ( Rd * thvm(k) * exner(k) ) - rho_zm(k) = p_in_Pa_zm(k) / ( Rd * thvm_zm(k) * exner_zm(k) ) - enddo - - - return - end subroutine hydrostatic - -!=============================================================================== - subroutine inverse_hydrostatic( p_sfc, zm_init, nlevels, thvm, exner, & - z ) - - ! Description: - ! Subprogram to integrate the inverse of hydrostatic equation - - ! References: - ! - !------------------------------------------------------------------------ - - use crmx_constants_clubb, only: & - p0, & ! Constant(s) - kappa, & - fstderr - - use crmx_interpolation, only: & - binary_search ! Procedure(s) - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - p_sfc, & ! Pressure at the surface [Pa] - zm_init ! Altitude at the surface [m] - - integer, intent(in) :: & - nlevels ! Number of levels in the sounding [-] - - real( kind = core_rknd ), intent(in), dimension(nlevels) :: & - thvm, & ! Virtual potential temperature [K] - exner ! Exner function [-] - - ! Output Variables - real( kind = core_rknd ), intent(out), dimension(nlevels) :: & - z ! Height [m] - - ! Local Variables - integer :: k - - real( kind = core_rknd ), dimension(nlevels) :: & - ref_z_snd ! Altitude minus altitude of the lowest sounding level [m] - - real( kind = core_rknd ), dimension(nlevels) :: & - exner_reverse_array ! Array of exner snd. values in reverse order [-] - - real( kind = core_rknd ) :: & - exner_sfc, & ! Value of exner at the surface [-] - ref_z_sfc, & ! Alt. diff between surface and lowest snd. level [m] - z_snd_bottom, & ! Altitude of the bottom of the input sounding [m] - dthvm_dexner ! Constant rate of change of thvm with respect to - ! exner between sounding levels k-1 and k [K] - - integer :: & - rev_low_idx, & - low_idx, & - high_idx - - - ! Variable ref_z_sfc is initialized to 0.0 to avoid a compiler warning. - ref_z_sfc = 0.0_core_rknd - - ! The variable ref_z_snd is the altitude of each sounding level compared to - ! the altitude of the lowest sounding level. Thus, the value of ref_z_snd - ! at sounding level 1 is 0. The lowest sounding level may or may not be - ! right at the surface, and therefore an adjustment may be required to find - ! the actual altitude above ground. - ref_z_snd(1) = 0.0_core_rknd - - do k = 2, nlevels - - ! The value of thvm is given at two successive sounding levels. For - ! purposes of achieving a quality estimate of altitude at each pressure - ! sounding level, the value of thvm is considered to vary linearly - ! with respect to exner between two successive sounding levels. Thus, - ! there is a constant d(thvm)/d(exner) between the two successive - ! sounding levels. If thvm is constant, then d(thvm)/d(exner) is 0. - dthvm_dexner = ( thvm(k) - thvm(k-1) ) / ( exner(k) - exner(k-1) ) - - ! Calculate the value of the reference height at sounding level k, based - ! the value of thvm at sounding level k-1, the constant value of - ! d(thvm)/d(exner), the value of exner at sounding levels k-1 and k, and - ! the reference altitude at sounding level k-1. - ref_z_snd(k) & - = calc_z_linear_thvm( thvm(k-1), dthvm_dexner, & - exner(k-1), exner(k), ref_z_snd(k-1) ) - - enddo - - ! Find the actual (above ground) altitude of the sounding levels from the - ! reference altitudes. - - ! The pressure at the surface (or model lower boundary), p_sfc, is found at - ! the altitude of the surface (or model lower boundary), zm_init. - - ! Find the value of exner at the surface from the pressure at the surface. - exner_sfc = ( p_sfc / p0 )**kappa - - ! Find the value of exner_sfc compared to the values of exner in the exner - ! sounding profile. - - if ( exner_sfc < exner(nlevels) ) then - - ! Since the values of exner decrease monotonically with height (and thus - ! with sounding level), the value of exner_sfc is less than all the - ! values of exner in the sounding (and thus the surface is located above - ! all the levels of the sounding), then there is insufficient information - ! to run the model. Stop the run. - - write(fstderr,*) "The entire sounding is below the model surface." - stop - - elseif ( exner_sfc > exner(1) ) then - - ! Since the values of exner decrease monotonically with height (and thus - ! with sounding level), the value of exner_sfc is greater than all the - ! values of exner in the sounding (and thus the surface is located below - ! all the levels of the sounding), use a linear extension of thvm to find - ! thvm at the surface. Thus, d(thvm)/d(exner) is the same as its value - ! between sounding levels 1 and 2. If the surface is so far below the - ! sounding that gr%zt(2) is below the first sounding level, the code in - ! subroutine read_sounding (found in sounding.F90) will stop the run. - - ! Calculate the appropriate d(thvm)/d(exner). - dthvm_dexner = ( thvm(2) - thvm(1) ) / ( exner(2) - exner(1) ) - - ! Calculate the difference between the altitude of the surface (or model - ! lower boundary) and the altitude of the lowest level of the sounding. - ref_z_sfc & - = calc_z_linear_thvm( thvm(1), dthvm_dexner, & - exner(1), exner_sfc, ref_z_snd(1) ) - - else ! exner(nlevels) < exner_sfc < exner(1) - - ! Since the values of exner decrease monotonically with height (and thus - ! with sounding level), the value of exner_sfc is between two values of - ! exner (at some levels k-1 and k) in the sounding, and the value of - ! d(thvm)/d(exner) is the same as between those two levels in the above - ! calculation. - - ! The value of exner_sfc is between two levels of the exner sounding. - ! Find the index of the lower level. - - ! In order to use the binary search, the array must be sorted from least - ! value to greatest value. Since exner decreases with altitude (and - ! vertical level), the array that is sent to function binary_search must - ! be the exact reverse of exner. - ! Thus, exner(1) becomes exner_reverse_array(nlevels), exner(nlevels) - ! becomes exner_reverse_array(1), etc. - do k = 1, nlevels, 1 - exner_reverse_array(k) = exner(nlevels-k+1) - enddo - ! The output from the binary search yields the first value in the - ! exner_reverse_array that is greater than or equal to exner_sfc. Thus, - ! in regards to the regular exner array, this is the reverse index of - ! the lower sounding level for exner_sfc. For example, if exner_sfc - ! is found between exner(1) and exner(2), the binary search for exner_sfc - ! in regards to exner_reverse_index will return a value of nlevels. - ! Once the actual lower level index is calculated, the result will be 1. - rev_low_idx = binary_search( nlevels, exner_reverse_array, exner_sfc ) - - ! Find the lower level index for the regular exner profile from the - ! lower level index for the reverse exner profile. - low_idx = nlevels - rev_low_idx + 1 - - ! Find the index of the upper level. - high_idx = low_idx + 1 - - ! Calculate the appropriate d(thvm)/d(exner). - dthvm_dexner = ( thvm(high_idx) - thvm(low_idx) ) & - / ( exner(high_idx) - exner(low_idx) ) - - ! Calculate the difference between the altitude of the surface (or model - ! lower boundary) and the altitude of the lowest level of the sounding. - ref_z_sfc & - = calc_z_linear_thvm( thvm(low_idx), dthvm_dexner, & - exner(low_idx), exner_sfc, ref_z_snd(low_idx) ) - - endif ! exner_sfc - - ! Find the altitude of the bottom of the sounding. - z_snd_bottom = zm_init - ref_z_sfc - - ! Calculate the sounding altitude profile based - ! on z_snd_bottom and ref_z_snd. - do k = 1, nlevels, 1 - z(k) = z_snd_bottom + ref_z_snd(k) - enddo - - - return - end subroutine inverse_hydrostatic - -!=============================================================================== - pure function calc_exner_const_thvm( thvm, z_2, z_1, exner_1 ) & - result( exner_2 ) - - ! Description: - ! This function solves for exner at a level, given exner at another level, - ! the altitudes of both levels, and a constant thvm over the depth of the - ! level. - ! - ! The derivative of exner is given by the following equation: - ! - ! d(exner)/dz = - grav / (Cp * thvm). - ! - ! This equation is integrated to solve for exner, such that: - ! - ! INT(exner_1:exner_2) d(exner) - ! = - ( grav / Cp ) INT(z_1:z_2) (1/thvm) dz. - ! - ! Since thvm is considered to be a constant over the depth of the layer - ! between z_1 and z_2, the equation can be written as: - ! - ! INT(exner_1:exner_2) d(exner) = - grav / ( Cp * thvm ) INT(z_1:z_2) dz. - ! - ! Solving the integral: - ! - ! exner_2 = exner_1 - [ grav / ( Cp * thvm ) ] * ( z_2 - z_1 ). - - ! References: - !------------------------------------------------------------------- - - use crmx_constants_clubb, only: & - grav, & ! Gravitational acceleration [m/s^2] - Cp ! Specific heat of dry air at const. pressure [J/(kg*K)] - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - thvm, & ! Constant value of thvm over the layer [K] - z_2, & ! Altitude at the top of the layer [m] - z_1, & ! Altitude at the bottom of the layer [m] - exner_1 ! Exner at the bottom of the layer [-] - - ! Return Variable - real( kind = core_rknd ) :: exner_2 ! Exner at the top of the layer [-] - - ! Calculate exner at top of the layer. - exner_2 = exner_1 - ( grav / ( Cp * thvm ) ) * ( z_2 - z_1 ) - - return - end function calc_exner_const_thvm - -!=============================================================================== - pure function calc_exner_linear_thvm( thvm_km1, dthvm_dz, & - z_km1, z_2, exner_km1 ) & - result( exner_2 ) - - ! Description: - ! This function solves for exner at a level, given exner at another level, - ! the altitudes of both levels, and a value of thvm that is considered to - ! vary linearly over the depth of the level. - ! - ! The derivative of exner is given by the following equation: - ! - ! d(exner)/dz = - grav / (Cp * thvm). - ! - ! This equation is integrated to solve for exner, such that: - ! - ! INT(exner_1:exner_2) d(exner) - ! = - ( grav / Cp ) INT(z_1:z_2) (1/thvm) dz. - ! - ! The value of thvm is considered to vary linearly (with respect to height) - ! over the depth of the level (resulting in a constant d(thvm)/dz over the - ! depth of the level). The entire level between z_1 and z_2 must be - ! encompassed between two levels with two known values of thvm. The value - ! of thvm at the upper level (z_up) is called thvm_up, and the value of thvm - ! at the lower level (z_low) is called thvm_low. Again, the values of thvm - ! at all interior altitudes, z_low <= z_1 < z <= z_2 <= z_up, behave - ! linearly between thvm_low and thvm_up, such that: - ! - ! thvm(z) - ! = [ ( thvm_up - thvm_low ) / ( z_up - z_low ) ] * ( z - z_low) - ! + thvm_low - ! = [ d(thvm)/dz ] * ( z - z_low ) + thvm_low - ! = C_a*z + C_b; - ! - ! where: - ! - ! C_a - ! = ( thvm_up - thvm_low ) / ( z_up - z_low ) - ! = d(thvm)/dz; - ! - ! and: - ! - ! C_b - ! = thvm_low - [ ( thvm_up - thvm_low ) / ( z_up - z_low ) ] * z_low - ! = thvm_low - [ d(thvm)/dz ] * z_low. - ! - ! The integral becomes: - ! - ! INT(exner_1:exner_2) d(exner) - ! = - ( grav / Cp ) INT(z_1:z_2) [ 1 / ( C_a*z + C_b ) ] dz. - ! - ! Performing a u-substitution ( u = C_a*z + C_b ), the equation becomes: - ! - ! INT(exner_1:exner_2) d(exner) - ! = - ( grav / Cp ) * ( 1 / C_a ) INT(z=z_1:z=z_2) (1/u) du. - ! - ! Solving the integral, and then re-substituting for u: - ! - ! exner_2 = exner_1 - ! - ( grav / Cp ) * ( 1 / C_a ) - ! * ln [ ( C_a*z_2 + C_b ) / ( C_a*z_1 + C_b ) ]. - ! - ! Re-substituting for C_a and C_b: - ! - ! exner_2 - ! = exner_1 - ! - ( grav / Cp ) * ( 1 / {d(thvm)/dz} ) - ! * ln [ ( {d(thvm)/dz}*z_2 + thvm_low - {d(thvm)/dz}*z_low ) - ! / ( {d(thvm)/dz}*z_1 + thvm_low - {d(thvm)/dz}*z_low ) ]. - ! - ! This equation is used to calculate exner_2 using exner_1, which is at the - ! same level as z_1. Furthermore, thvm_low and z_low are taken from the - ! same level as z_1 and exner_1. Thus, z_1 = z_low. Therefore: - ! - ! exner_2 - ! = exner_low - ! - ( grav / Cp ) * ( 1 / {d(thvm)/dz} ) - ! * ln [ ( thvm_low + {d(thvm)/dz}*(z_2-z_low) ) / thvm_low ]. - ! - ! Considering either a thermodynamic or sounding level k-1 as the low level - ! in the integration, and that thvm varies linearly between level k-1 and - ! level k: - ! - ! exner_2 - ! = exner(k-1) - ! - ( grav / Cp ) * ( 1 / {d(thvm)/dz} ) - ! * ln [ ( thvm(k-1) + {d(thvm)/dz}*(z_2-z(k-1)) ) / thvm(k-1) ]; - ! - ! where: - ! - ! d(thvm)/dz = ( thvm(k) - thvm(k-1) ) / ( z(k) - z(k-1) ); - ! - ! and where z(k-1) < z_2 <= z(k); and {d(thvm)/dz} /= 0. If the value of - ! {d(thvm)/dz} is 0, then thvm is considered to be a constant over the depth - ! of the level. The appropriate equation is found in pure function - ! calc_exner_const_thvm. - - ! References: - !------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_constants_clubb, only: & - grav, & ! Gravitational acceleration [m/s^2] - Cp ! Specific heat of dry air at const. pressure [J/(kg*K)] - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - thvm_km1, & ! Value of thvm at level k-1 [K] - dthvm_dz, & ! Constant d(thvm)/dz between levels k-1 and k [K/m] - z_km1, & ! Altitude at level k-1 [m] - z_2, & ! Altitude at the top of the layer [m] - exner_km1 ! Exner at level k-1 [-] - - ! Return Variable - real( kind = core_rknd ) :: exner_2 ! Exner at the top of the layer [-] - - ! Calculate exner at the top of the layer. - exner_2 & - = exner_km1 & - - ( grav / Cp ) * ( 1.0_core_rknd / dthvm_dz ) & - * log( ( thvm_km1 + dthvm_dz * ( z_2 - z_km1 ) ) / thvm_km1 ) - - return - end function calc_exner_linear_thvm - -!=============================================================================== - pure function calc_z_linear_thvm( thvm_km1, dthvm_dexner, & - exner_km1, exner_2, z_km1 ) & - result( z_2 ) - - ! Description: - ! This function solves for z (altitude) at a level, given altitude at - ! another level, the values of exner at both levels, and a value of thvm - ! that is considered to vary linearly over the depth of the level. - ! - ! The derivative of exner is given by the following equation: - ! - ! d(exner)/dz = - grav / (Cp * thvm). - ! - ! This equation is integrated to solve for z, such that: - ! - ! INT(exner_1:exner_2) thvm d(exner) = - ( grav / Cp ) INT(z_1:z_2) dz. - ! - ! The value of thvm is considered to vary linearly (with respect to exner) - ! over the depth of the level (resulting in a constant d(thvm)/d(exner) over - ! the depth of the level). The entire level between exner_1 and exner_2 - ! must be encompassed between two levels with two known values of thvm. The - ! value of thvm at the upper level (exner_up) is called thvm_up, and the - ! value of thvm at the lower level (exner_low) is called thvm_low. Again, - ! the values of thvm at all interior exner levels, - ! exner_low >= exner_1 > exner >= exner_2 >= exner_up, behave linearly - ! between thvm_low and thvm_up, such that: - ! - ! thvm(exner) - ! = [ ( thvm_up - thvm_low ) / ( exner_up - exner_low ) ] - ! * ( exner - exner_low ) - ! + thvm_low - ! = [ d(thvm)/d(exner) ] * ( exner - exner_low ) + thvm_low - ! = C_a*z + C_b; - ! - ! where: - ! - ! C_a - ! = ( thvm_up - thvm_low ) / ( exner_up - exner_low ) - ! = d(thvm)/d(exner); - ! - ! and: - ! - ! C_b - ! = thvm_low - ! - [ ( thvm_up - thvm_low ) / ( exner_up - exner_low ) ] * exner_low - ! = thvm_low - [ d(thvm)/d(exner) ] * exner_low. - ! - ! The integral becomes: - ! - ! INT(exner_1:exner_2) ( C_a*exner + C_b ) d(exner) - ! = - ( grav / Cp ) INT(z_1:z_2) dz. - ! - ! Solving the integral: - ! - ! z_2 - ! = z_1 - ! - ( Cp / grav ) - ! * [ (1/2) * {d(thvm)/d(exner)} * ( {exner_2}^2 - {exner_1}^2 ) - ! + ( thvm_low - {d(thvm)/d(exner)} * exner_low ) - ! * ( exner_2 - exner_1 ) ]. - ! - ! This equation is used to calculate z_2 using z_1, which is at the same - ! level as exner_1. Furthermore, thvm_low and exner_low are taken from the - ! same level as exner_1 and z_1. Thus, exner_1 = exner_low. Therefore: - ! - ! z_2 - ! = z_low - ! - ( Cp / grav ) - ! * [ (1/2) * {d(thvm)/d(exner)} * ( {exner_2}^2 - {exner_low}^2 ) - ! + ( thvm_low - {d(thvm)/d(exner)} * exner_low ) - ! * ( exner_2 - exner_low ) ]. - ! - ! Considering a sounding level k-1 as the low level in the integration, and - ! that thvm varies linearly (with respect to exner) between level k-1 and - ! level k: - ! - ! z_2 - ! = z(k-1) - ! - ( Cp / grav ) - ! * [ (1/2) * {d(thvm)/d(exner)} * ( {exner_2}^2 - {exner(k-1)}^2 ) - ! + ( thvm(k-1) - {d(thvm)/d(exner)} * exner(k-1) ) - ! * ( exner_2 - exner(k-1) ) ]; - ! - ! where: - ! - ! d(thvm)/d(exner) - ! = ( thvm(k) - thvm(k-1) ) / ( exner(k) - exner(k-1) ); - ! - ! and where exner(k-1) > exner_2 >= exner(k). If the value of - ! d(thvm)/d(exner) is 0, then thvm is considered to be a constant over the - ! depth of the level, and the equation will reduce to: - ! - ! z_2 = z(k-1) - ( Cp / grav ) * thvm(k-1) * ( exner_2 - exner(k-1) ). - ! - ! - ! IMPORTANT NOTE: - ! - ! CLUBB is an altitude-based model. All linear interpolations (and - ! extensions) are based on considering a variable to change linearly with - ! respect to altitude, rather than with respect to exner. An exception is - ! made here to calculate the altitude of a sounding level based on a - ! sounding given in terms of a pressure coordinate rather than a height - ! coordinate. After the altitude of the sounding level has been calculated, - ! the values of the sounding variables are interpolated onto the model grid - ! linearly with respect to altitude. Therefore, considering a variable to - ! change linearly with respect to exner is not consistent with the rest of - ! the model code, but provides for a better estimation of the altitude of - ! the sounding levels (than simply considering thvm to be constant over the - ! depth of the sounding level). - - ! References: - !------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_constants_clubb, only: & - grav, & ! Gravitational acceleration [m/s^2] - Cp ! Specific heat of dry air at const. pressure [J/(kg*K)] - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - thvm_km1, & ! Value of thvm at sounding level k-1 [K] - dthvm_dexner, & ! Constant d(thvm)/d(exner) between levels k-1 and k [K] - exner_km1, & ! Value of exner at sounding level k-1 [-] - exner_2, & ! Value of exner at the top of the layer [-] - z_km1 ! Altitude at sounding level k-1 [m] - - ! Return Variable - real( kind = core_rknd ) :: z_2 ! Altitude at the top of the layer [m] - - ! Calculate z_2 at the top of the layer. - z_2 & - = z_km1 & - - ( Cp / grav ) & - * ( 0.5_core_rknd * dthvm_dexner * ( exner_2**2 - exner_km1**2 ) & - + ( thvm_km1 - dthvm_dexner * exner_km1 ) & - * ( exner_2 - exner_km1 ) & - ) - - return - end function calc_z_linear_thvm - -!=============================================================================== - -end module crmx_hydrostatic_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_hyper_diffusion_4th_ord.F90 b/src/physics/spcam/crm/CLUBB/crmx_hyper_diffusion_4th_ord.F90 deleted file mode 100644 index a59714a42b..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_hyper_diffusion_4th_ord.F90 +++ /dev/null @@ -1,1685 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: hyper_diffusion_4th_ord.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module crmx_hyper_diffusion_4th_ord - - ! Description: - ! Module hyper_diffusion_4th_ord computes the 4th-order numerical diffusion - ! for any equation to which it is applied. Hyper-diffusion will only be - ! called if the model flag l_hyper_dfsn is set to true. Function - ! hyper_dfsn_4th_ord_zt_lhs handles 4th-order hyper-diffusion for variables - ! that reside on thermodynamic levels. Function hyper_dfsn_4th_ord_zm_lhs - ! handles 4th-order hyper-diffusion for variables that reside on momentum - ! levels. A special constant coefficient of 4th-order numerical diffusion, - ! nu_hd (which is sent in this module as nu), is used and has units of m^4/s. - - implicit none - - private ! Default Scope - - public :: hyper_dfsn_4th_ord_zt_lhs, & - hyper_dfsn_4th_ord_zm_lhs - - contains - - !============================================================================= - pure function hyper_dfsn_4th_ord_zt_lhs( boundary_cond, nu, invrs_dzt, & - invrs_dzm, invrs_dzmm1, & - invrs_dztp1, invrs_dztm1, & - invrs_dzmp1, invrs_dzmm2, level ) & - result( lhs ) - - ! Note: In the "Description" section of this function, 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: - ! Vertical 4th-order numerical diffusion of var_zt: implicit portion of the - ! code. - ! - ! Fourth-order numerical diffusion, or fourth-order hyper-diffusion, is used - ! to help eliminate small-scale noise without altering larger-scale - ! features. - ! - ! The variable "var_zt" stands for a variable that is located at - ! thermodynamic grid levels. - ! - ! The d(var_zt)/dt equation contains a 4th-order numerical diffusion term: - ! - ! - nu * d^4(var_zt)/dz^4. - ! - ! This term is solved for completely implicitly, such that: - ! - ! - nu * d^4( var_zt(t+1) )/dz^4. - ! - ! 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. - ! - ! The term is discretized as follows: - ! - ! The five values of var_zt are found on the thermodynamic levels. All four - ! derivatives (d/dz) of var_zt are taken over all the intermediate momentum - ! levels. Then, all three derivatives (d/dz) of d(var_zt)/dz are taken over - ! all the intermediate thermodynamic levels, which results in the second - ! derivatives. Then, both derivatives (d/dz) of d^2(var_zt)/dz^2 are taken - ! over the intermediate momentum levels, which results in the third - ! derivatives. Finally, the derivative (d/dz) of d^3(var_zt)/dz^3 is taken - ! over the intermediate (central) thermodynamic level, which results in the - ! fourth derivative. At the central thermodynamic level, d^4(var_zt)/dz^4 - ! is multiplied by constant coefficient nu. - ! - ! --var_ztp2----------------------------------------------- t(k+2) - ! - ! ======d(var_zt)/dz======================================= m(k+1) - ! - ! --var_ztp1----d^2(var_zt)/dz^2--------------------------- t(k+1) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(k) - ! - ! --var_zt------d^2(var_zt)/dz^2--------d^4(var_zt)/dz^4--- t(k) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(k-1) - ! - ! --var_ztm1----d^2(var_zt)/dz^2--------------------------- t(k-1) - ! - ! ======d(var_zt)/dz======================================= m(k-2) - ! - ! --var_ztm2----------------------------------------------- t(k-2) - ! - ! The vertical indices t(k+2), m(k+1), t(k+1), m(k), t(k), m(k-1), t(k-1), - ! m(k-2), and t(k-2) correspond with altitudes zt(k+2), zm(k+1), zt(k+1), - ! zm(k), zt(k), zm(k-1), zt(k-1), zm(k-2), and zt(k-2) 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) ) - ! dzt(k+1) = 1 / ( zm(k+1) - zm(k) ) - ! dzt(k-1) = 1 / ( zm(k-1) - zm(k-2) ) - ! dzm(k+1) = 1 / ( zt(k+2) - zt(k+1) ) - ! dzm(k-2) = 1 / ( zt(k-1) - zt(k-2) ) - ! - ! The discretization of -nu*d^4(var_zt)/dz^4 at thermodynamic level (k) - ! is written out as follows: - ! - ! -nu - ! *dzt(k)*[ dzm(k)*{ dzt(k+1)*( dzm(k+1)*(var_zt(k+2)-var_zt(k+1)) - ! -dzm(k)*(var_zt(k+1)-var_zt(k)) ) - ! -dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) } - ! -dzm(k-1)*{ dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) - ! -dzt(k-1)*( dzm(k-1)*(var_zt(k)-var_zt(k-1)) - ! -dzm(k-2)*(var_zt(k-1)-var_zt(k-2)) ) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" sign - ! changes to a "+" sign when the term is brought over to the left-hand side, - ! and var_zt is considered to be at timestep (t+1). - ! - ! - ! 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 4th-order numerical diffusion term, -nu*d^4(var_zt)/dz^4 (which - ! is actually -d[nu*d^3(var_zt)/dz^3]/dz with a constant coefficient, - ! nu), the flux is: - ! - ! F = +nu*d^3(var_zt)/dz^3. - ! - ! In order to have zero-flux boundary conditions, the third derivative of - ! var_zt, d^3(var_zt)/dz^3, needs to equal 0 at both the lower boundary - ! and the upper boundary. - ! - ! Fourth-order numerical diffusion is used in conjunction with - ! second-order eddy diffusion, +d[(K_zm+nu)*d(var_zt)/dz]/dz, where the - ! coefficient of eddy diffusivity, (K_zm+nu), varies in the vertical. - ! Both 4th-order numerical diffusion and 2nd-order eddy diffusion use the - ! same boundary condition type at all times, which in this case is - ! zero-flux boundary conditions. For 2nd-order eddy diffusion, 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. - ! - ! Thus, the boundary conditions used for 4th-order numerical diffusion - ! are: d^3(var_zt)/dz^3 = 0 and d(var_zt)/dz = 0 at both the upper - ! boundary and the lower boundary, resulting in four boundary conditions, - ! which is the number of boundary conditions needed for a 4th-order term. - ! - ! 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 one of the boundary conditions. The - ! boundary condition d^3(var_zt)/dz^3 = 0 is also set at this level. The - ! rest of the levels involved are discretized normally, as listed above. - ! - ! Since the normal discretization includes two levels on either side of - ! the central level, the lower boundary begins to effect the - ! discretization at thermodynamic level 2. - ! - ! -var_zt(4)----------------------------------------------- t(4) - ! - ! ======d(var_zt)/dz======================================= m(3) - ! - ! -var_zt(3)----d^2(var_zt)/dz^2--------------------------- t(3) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(2) - ! - ! -var_zt(2)----d^2(var_zt)/dz^2--------d^4(var_zt)/dz^4--- t(2) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(1) - ! - ! -var_zt(1)----d^2(var_zt)/dz^2--------------------------- t(1) Boundary - ! - ! ======[d(var_zt)/dz = 0]================================= m(0) - ! - ! -[var_zt(0) = var_zt(1)]-----(level outside model)------- t(0) - ! - ! The discretization of -nu*d^4(var_zt)/dz^4 at thermodynamic level (k=2) - ! is written out as follows: - ! - ! -nu - ! *dzt(k)*[ dzm(k)*{ dzt(k+1)*( dzm(k+1)*(var_zt(k+2)-var_zt(k+1)) - ! -dzm(k)*(var_zt(k+1)-var_zt(k)) ) - ! -dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) } - ! -dzm(k-1)*{ dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) - ! -dzt(k-1)*dzm(k-1)*(var_zt(k)-var_zt(k-1)) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zt is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zt found at thermodynamic - ! levels 1, 2, 3, and 4. Thus, it only affects 4 diagonals on the - ! left-hand side matrix. - ! - ! The lower boundary also effects the discretization at thermodynamic - ! level 1. - ! - ! -var_zt(3)----------------------------------------------- t(3) - ! - ! ======d(var_zt)/dz======================================= m(2) - ! - ! -var_zt(2)----d^2(var_zt)/dz^2--------------------------- t(2) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(1) - ! - ! -var_zt(1)----d^2(var_zt)/dz^2--------d^4(var_zt)/dz^4--- t(1) Boundary - ! - ! ======[d(var_zt)/dz = 0]==[d^3(var_zt)/dz^3 = 0]========= m(0) - ! - ! -[var_zt(0) = var_zt(1)]-----(level outside model)------- t(0) - ! - ! The discretization of -nu*d^4(var_zt)/dz^4 at thermodynamic level (k=1) - ! is written out as follows: - ! - ! -nu - ! *dzt(k)*[ dzm(k)*{ dzt(k+1)*( dzm(k+1)*(var_zt(k+2)-var_zt(k+1)) - ! -dzm(k)*(var_zt(k+1)-var_zt(k)) ) - ! -dzt(k)*dzm(k)*(var_zt(k+1)-var_zt(k)) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zt is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zt found at thermodynamic - ! levels 1, 2, and 3. Thus, it only affects 3 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. - ! - ! For a 4th-order term, four boundary conditions are needed. Two - ! boundary conditions are applied at each boundary. For the case of - ! fixed-point boundary conditions, one of those two conditions is setting - ! var_zt = A, where A is a constant value. One more condition is needed. - ! Setting the values of d(var_zt)/dz and d^3(var_zt)/dz^3 are inherently - ! used for zero-flux (or perhaps fixed-flux) boundary conditions. - ! Fixed-point and zero-flux boundary conditions inherently should not be - ! invoked at the same time. The only remaining choice for a second - ! boundary condition for the fixed-point case is setting - ! d^2(var_zt)/dz^2. As it turns out, setting d^2(var_zt)/dz^2 = 0 is the - ! appropriate condition to use because it prevents values of var_zt at - ! levels outside the model from being involved in the discretization of - ! -nu*d^4(var_zt)/dz^4 at thermodynamic level 2. Setting - ! d^3(var_zt)/dz^3 = 0 does not accomplish the same thing for the - ! discretization of -nu*d^4(var_zt)/dz^4 at thermodynamic level 2. Also, - ! as stated above, fourth-order numerical diffusion is used in - ! conjunction with second-order eddy diffusion, - ! +d[(K_zm+nu)*d(var_zt)/dz]/dz, where the coefficient of eddy - ! diffusivity, (K_zm+nu), varies in the vertical. Both 4th-order - ! numerical diffusion and 2nd-order eddy diffusion use the same boundary - ! condition type at all times, which in this case is fixed-point boundary - ! conditions. For 2nd-order eddy diffusion, fixed-point boundary - ! conditions set var_zt = A, and do not set d(var_zt)/dz. Thus, - ! d(var_zt)/dz cannot be set for fixed-point boundary conditions. As - ! previously stated, the only other boundary condition that can be - ! invoked for a fixed-point boundary case is d^2(var_zt)/dz^2 = 0. - ! - ! Since the normal discretization includes two levels on either side of - ! the central level, the lower boundary begins to effect the - ! discretization at thermodynamic level 2. - ! - ! -var_zt(4)----------------------------------------------- t(4) - ! - ! ======d(var_zt)/dz======================================= m(3) - ! - ! -var_zt(3)----d^2(var_zt)/dz^2--------------------------- t(3) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(2) - ! - ! -var_zt(2)----d^2(var_zt)/dz^2--------d^4(var_zt)/dz^4--- t(2) - ! - ! ======d(var_zt)/dz========d^3(var_zt)/dz^3=============== m(1) - ! - ! -var_zt(1)----[d^2(var_zt)/dz^2 = 0]--------------------- t(1) Boundary - ! - ! ======d(var_zt)/dz======================================= m(0) - ! - ! -var_zt(0)-------------------(level outside model)------- t(0) - ! - ! The discretization of -nu*d^4(var_zt)/dz^4 at thermodynamic level (k=2) - ! is written out as follows: - ! - ! -nu - ! *dzt(k)*[ dzm(k)*{ dzt(k+1)*( dzm(k+1)*(var_zt(k+2)-var_zt(k+1)) - ! -dzm(k)*(var_zt(k+1)-var_zt(k)) ) - ! -dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) } - ! -dzm(k-1)*{ dzt(k)*( dzm(k)*(var_zt(k+1)-var_zt(k)) - ! -dzm(k-1)*(var_zt(k)-var_zt(k-1)) ) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zt is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zt found at thermodynamic - ! levels 1, 2, 3, and 4. Thus, it only affects 4 diagonals on the - ! left-hand side matrix. - ! - ! The same method can be used to discretize -nu*d^4(var_zt)/dz^4 at the - ! second-highest thermodynamic level (k=top-1) by setting - ! d^2(var_zt)/dz^2 = 0 at the highest thermodynamic level. - ! - ! The discretization at thermodynamic level (k=1) is written to simply - ! set the value var_zt(1) = A. Likewise, the discretization at - ! thermodynamic level (k=top) is written to simply set the value - ! var_zt(top) = B. In order to discretize the boundary conditions at the - ! lowest and highest vertical levels 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 lowest and highest levels. Then set - ! the values at the lowest and highest 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 lowest and highest levels. - ! - ! Either way, at the lowest and highest 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 4th-order numerical 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 4th-order - ! numerical 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 4th-order - ! numerical 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/dzt )_i ( nu*dzt*dzm*dzt*dzm )_ij (var_zt)_j. - ! - ! The left-hand side matrix, ( nu*dzt*dzm*dzt*dzm )_ij, is partially written - ! below. The sum over i in the above equation removes the first dzt(k) - ! everywhere from the matrix below. The sum over j leaves the column totals - ! that are desired. - ! - ! Left-hand side matrix contributions from 4th-order numerical diffusion - ! (or hyper-diffusion) term; first five vertical levels: - ! - ! column 1 || column 2 || column 3 || column 4 || column 5 - ! ------------------------------------------------------------------------------------------> - ! | +nu -nu +nu - ! | *dzt(k) *dzt(k) *dzt(k) - ! | *[ dzm(k) *[ dzm(k) *dzm(k) - !k=1| *{ dzt(k+1) *{ dzt(k+1) *dzt(k+1) 0 0 - ! | *dzm(k) *( dzm(k+1) *dzm(k+1) - ! | +dzt(k) +dzm(k) ) - ! | *dzm(k) } ] +dzt(k) - ! | *dzm(k) } ] - ! | - ! | -nu +nu -nu +nu - ! | *dzt(k) *dzt(k) *dzt(k) *dzt(k) - ! | *[ dzm(k) *[ dzm(k) *[ dzm(k) *dzm(k) - ! | *dzt(k) *{ dzt(k+1) *{ dzt(k+1) *dzt(k+1) - ! | *dzm(k-1) *dzm(k) *( dzm(k+1) *dzm(k+1) - ! | +dzm(k-1) +dzt(k) +dzm(k) ) - ! | *{ dzt(k) *( dzm(k) +dzt(k) - !k=2| *dzm(k-1) +dzm(k-1) ) *dzm(k) } 0 - ! | +dzt(k-1) } +dzm(k-1) - ! | *dzm(k-1) +dzm(k-1) *dzt(k) - ! | } ] *{ dzt(k) *dzm(k) ] - ! | *( dzm(k) - ! | +dzm(k-1) ) - ! | +dzt(k-1) - ! | *dzm(k-1) } ] - ! | - ! | +nu -nu +nu -nu +nu - ! | *dzt(k) *dzt(k) *dzt(k) *dzt(k) *dzt(k) - ! | *dzm(k-1) *[ dzm(k) *[ dzm(k) *[ dzm(k) *dzm(k) - ! | *dzt(k-1) *dzt(k) *{ dzt(k+1) *{ dzt(k+1) *dzt(k+1) - ! | *dzm(k-2) *dzm(k-1) *dzm(k) *( dzm(k+1) *dzm(k+1) - ! | +dzm(k-1) +dzt(k) +dzm(k) ) - ! | *{ dzt(k) *( dzm(k) +dzt(k) - !k=3| *dzm(k-1) +dzm(k-1) ) *dzm(k) } - ! | +dzt(k-1) } +dzm(k-1) - ! | *( dzm(k-1) +dzm(k-1) *dzt(k) - ! | +dzm(k-2) ) *{ dzt(k) *dzm(k) ] - ! | } ] *( dzm(k) - ! | +dzm(k-1) ) - ! | +dzt(k-1) - ! | *dzm(k-1) } ] - ! | - ! | +nu -nu +nu -nu - ! | *dzt(k) *dzt(k) *dzt(k) *dzt(k) - ! | *dzm(k-1) *[ dzm(k) *[ dzm(k) *[ dzm(k) - ! | *dzt(k-1) *dzt(k) *{ dzt(k+1) *{ dzt(k+1) - ! | *dzm(k-2) *dzm(k-1) *dzm(k) *( dzm(k+1) - ! | +dzm(k-1) +dzt(k) +dzm(k) ) - ! | *{ dzt(k) *( dzm(k) +dzt(k) - !k=4| 0 *dzm(k-1) +dzm(k-1) ) *dzm(k) } - ! | +dzt(k-1) } +dzm(k-1) - ! | *( dzm(k-1) +dzm(k-1) *dzt(k) - ! | +dzm(k-2) ) *{ dzt(k) *dzm(k) ] - ! | } ] *( dzm(k) - ! | +dzm(k-1) ) - ! | +dzt(k-1) - ! | *dzm(k-1) } ] - ! | - ! | +nu -nu +nu - ! | *dzt(k) *dzt(k) *dzt(k) - ! | *dzm(k-1) *[ dzm(k) *[ dzm(k) - ! | *dzt(k-1) *dzt(k) *{ dzt(k+1) - ! | *dzm(k-2) *dzm(k-1) *dzm(k) - ! | +dzm(k-1) +dzt(k) - ! | *{ dzt(k) *( dzm(k) - !k=5| 0 0 *dzm(k-1) +dzm(k-1) ) - ! | +dzt(k-1) } - ! | *( dzm(k-1) +dzm(k-1) - ! | +dzm(k-2) ) *{ dzt(k) - ! | } ] *( dzm(k) - ! | +dzm(k-1) ) - ! | +dzt(k-1) - ! | *dzm(k-1) } ] - ! \ / - ! - ! Note: The super-super diagonal term from level 4 and both the super - ! diagonal and super-super diagonal terms from level 5 are not shown - ! on this diagram. - ! - ! Note: The matrix shown is a five-diagonal matrix. For a nine-diagonal - ! matrix, 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 4th-order hyper-diffusion term, - ! those extra row and column values are all 0, and the conservation - ! properties of the matrix aren't effected. - ! - ! For the case of fixed-point boundary conditions, the contributions of the - ! 4th-order hyper-diffusion term are as follows (only the top 2 levels - ! differ from the matrix diagram above): - ! - ! column 1 || column 2 || column 3 || column 4 || column 5 - ! ------------------------------------------------------------------------------------------> - !k=1| 0 0 0 0 0 - ! | - ! | -nu +nu -nu +nu - ! | *dzt(k) *dzt(k) *dzt(k) *dzt(k) - ! | *[ dzm(k) *[ dzm(k) *[ dzm(k) *dzm(k) - ! | *dzt(k) *{ dzt(k+1) *{ dzt(k+1) *dzt(k+1) - ! | *dzm(k-1) *dzm(k) *( dzm(k+1) *dzm(k+1) - ! | +dzm(k-1) +dzt(k) +dzm(k) ) - !k=2| *dzt(k) *( dzm(k) +dzt(k) 0 - ! | *dzm(k-1) ] +dzm(k-1) ) *dzm(k) } - ! | } +dzm(k-1) - ! | +dzm(k-1) *dzt(k) - ! | *{ dzt(k) *dzm(k) ] - ! | *( dzm(k) - ! | +dzm(k-1) ) - ! | } ] - ! \ / - ! - ! For the left-hand side matrix as a whole, the matrix entries at level 1 - ! (k=1) read: 1 0 0 0 0. For the case of fixed-point boundary - ! conditions, 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. October 7, 2008. - - ! References: - ! None - !----------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_grid_class, only: & - gr ! Variable(s) gr%nz - - implicit none - - ! Constant parameters - integer, parameter :: & - kp2_tdiag = 1, & ! Thermodynamic super-super diagonal index. - kp1_tdiag = 2, & ! Thermodynamic super diagonal index. - k_tdiag = 3, & ! Thermodynamic main diagonal index. - km1_tdiag = 4, & ! Thermodynamic sub diagonal index. - km2_tdiag = 5 ! Thermodynamic sub-sub diagonal index. - - ! Input Variables - character (len=*), intent(in) :: & - boundary_cond ! Type of boundary conditions being used - ! ('zero-flux' or 'fixed-point'). - - real( kind = core_rknd ), intent(in) :: & - nu, & ! Constant coef. of 4th-order numerical diffusion [m^4/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] - invrs_dztp1, & ! Inverse of grid spacing over thermo. level (k+1) [1/m] - invrs_dztm1, & ! Inverse of grid spacing over thermo. level (k-1) [1/m] - invrs_dzmp1, & ! Inverse of grid spacing over momentum level (k+1) [1/m] - invrs_dzmm2 ! Inverse of grid spacing over momentum level (k-2) [1/m] - - integer, intent(in) :: & - level ! Thermodynamic level where calculation occurs. [-] - - ! Return Variable - real( kind = core_rknd ), dimension(5) :: lhs - - - if ( level == 1 ) then - - ! Lowest level - ! k = 1; lower boundery level at surface. - ! Only relevant if zero-flux boundary conditions are used. - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *invrs_dzm*(invrs_dztp1*invrs_dzm + invrs_dzt*invrs_dzm) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *invrs_dzm*( invrs_dztp1*(invrs_dzmp1 + invrs_dzm) & - +invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzm*invrs_dztp1*invrs_dzmp1 - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - ! The left-hand side matrix contributions from level 1 are - ! over-written or set in the parent subroutine. - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = 0.0_core_rknd - - endif - - - elseif ( level == 2 ) then - - ! Second-lowest level - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzmm1 & - +invrs_dzmm1*( invrs_dzt*invrs_dzmm1 & - +invrs_dztm1*invrs_dzmm1 ) ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*invrs_dzm & - +invrs_dzt*(invrs_dzm + invrs_dzmm1) ) & - +invrs_dzmm1*( invrs_dzt*(invrs_dzm + invrs_dzmm1) & - +invrs_dztm1*invrs_dzmm1 ) ) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*(invrs_dzmp1 + invrs_dzm) & - +invrs_dzt*invrs_dzm ) & - +invrs_dzmm1*invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzm*invrs_dztp1*invrs_dzmp1 - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzmm1 & - +invrs_dzmm1*invrs_dzt*invrs_dzmm1 ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*invrs_dzm & - +invrs_dzt*(invrs_dzm + invrs_dzmm1) ) & - +invrs_dzmm1*( invrs_dzt*(invrs_dzm + invrs_dzmm1) ) ) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*(invrs_dzmp1 + invrs_dzm) & - +invrs_dzt*invrs_dzm ) & - +invrs_dzmm1*invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzm*invrs_dztp1*invrs_dzmp1 - - endif - - - elseif ( level > 2 .and. level < gr%nz-1 ) then - - ! k > 2 and k < num_levels-1 - ! These interior level are not effected by boundary conditions. - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzmm1*invrs_dztm1*invrs_dzmm2 - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzmm1 & - +invrs_dzmm1*( invrs_dzt*invrs_dzmm1 & - +invrs_dztm1*(invrs_dzmm1 + invrs_dzmm2) ) ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*invrs_dzm & - +invrs_dzt*(invrs_dzm + invrs_dzmm1) ) & - +invrs_dzmm1*( invrs_dzt*(invrs_dzm + invrs_dzmm1) & - +invrs_dztm1*invrs_dzmm1 ) ) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*(invrs_dzmp1 + invrs_dzm) & - +invrs_dzt*invrs_dzm ) & - +invrs_dzmm1*invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzm*invrs_dztp1*invrs_dzmp1 - - - elseif ( level == gr%nz-1 ) then - - ! Second-highest level - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzmm1*invrs_dztm1*invrs_dzmm2 - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzmm1 & - +invrs_dzmm1*( invrs_dzt*invrs_dzmm1 & - +invrs_dztm1*(invrs_dzmm1 + invrs_dzmm2) ) ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*invrs_dzm & - +invrs_dzt*(invrs_dzm + invrs_dzmm1) ) & - +invrs_dzmm1*( invrs_dzt*(invrs_dzm + invrs_dzmm1) & - +invrs_dztm1*invrs_dzmm1 ) ) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*( invrs_dztp1*invrs_dzm & - +invrs_dzt*invrs_dzm ) & - +invrs_dzmm1*invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = 0.0_core_rknd - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzmm1*invrs_dztm1*invrs_dzmm2 - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzmm1 & - +invrs_dzmm1*( invrs_dzt*invrs_dzmm1 & - +invrs_dztm1*(invrs_dzmm1 + invrs_dzmm2) ) ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *( invrs_dzm*( invrs_dzt*(invrs_dzm + invrs_dzmm1) ) & - +invrs_dzmm1*( invrs_dzt*(invrs_dzm + invrs_dzmm1) & - +invrs_dztm1*invrs_dzmm1 ) ) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = -nu*invrs_dzt & - *( invrs_dzm*invrs_dzt*invrs_dzm & - +invrs_dzmm1*invrs_dzt*invrs_dzm ) - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = 0.0_core_rknd - - endif - - - elseif ( level == gr%nz ) then - - ! Highest level - ! k = gr%nz; upper boundery level at model top. - ! Only relevant if zero-flux boundary conditions are used. - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = +nu*invrs_dzt & - *invrs_dzmm1*invrs_dztm1*invrs_dzmm2 - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = -nu*invrs_dzt & - *invrs_dzmm1*( invrs_dzt*invrs_dzmm1 & - +invrs_dztm1*(invrs_dzmm1 + invrs_dzmm2) ) - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = +nu*invrs_dzt & - *invrs_dzmm1*(invrs_dzt*invrs_dzmm1 + invrs_dztm1*invrs_dzmm1) - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = 0.0_core_rknd - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - ! The left-hand side matrix contributions from level gr%nz are - ! over-written or set in the parent subroutine. - - ! Thermodynamic sub-sub diagonal: [ x var_zt(k-2,) ] - lhs(km2_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic sub diagonal: [ x var_zt(k-1,) ] - lhs(km1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic super diagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd - - ! Thermodynamic super-super diagonal: [ x var_zt(k+2,) ] - lhs(kp2_tdiag) & - = 0.0_core_rknd - - endif - - endif - - return - - end function hyper_dfsn_4th_ord_zt_lhs - - !============================================================================= - pure function hyper_dfsn_4th_ord_zm_lhs( boundary_cond, nu, invrs_dzm, & - invrs_dztp1, invrs_dzt, & - invrs_dzmp1, invrs_dzmm1, & - invrs_dztp2, invrs_dztm1, level ) & - result( lhs ) - - ! Note: In the "Description" section of this function, 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: - ! Vertical 4th-order numerical diffusion of var_zm: implicit portion of the - ! code. - ! - ! Fourth-order numerical diffusion, or fourth-order hyper-diffusion, is used - ! to help eliminate small-scale noise without altering larger-scale - ! features. - ! - ! The variable "var_zm" stands for a variable that is located at momentum - ! grid levels. - ! - ! The d(var_zm)/dt equation contains a 4th-order numerical diffusion term: - ! - ! - nu * d^4(var_zm)/dz^4. - ! - ! This term is solved for completely implicitly, such that: - ! - ! - nu * d^4( var_zm(t+1) )/dz^4. - ! - ! 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. - ! - ! The term is discretized as follows: - ! - ! The five values of var_zm are found on the momentum levels. All four - ! derivatives (d/dz) of var_zm are taken over all the intermediate - ! thermodynamic levels. Then, all three derivatives (d/dz) of d(var_zm)/dz - ! are taken over all the intermediate momentum levels, which results in the - ! second derivatives. Then, both derivatives (d/dz) of d^2(var_zm)/dz^2 are - ! taken over the intermediate thermodynamic levels, which results in the - ! third derivatives. Finally, the derivative (d/dz) of d^3(var_zm)/dz^3 is - ! taken over the intermediate (central) momentum level, which results in the - ! fourth derivative. At the central momentum level, d^4(var_zm)/dz^4 is - ! multiplied by constant coefficient nu. - ! - ! ==var_zmp2=============================================== m(k+2) - ! - ! ------d(var_zm)/dz--------------------------------------- t(k+2) - ! - ! ==var_zmp1====d^2(var_zm)/dz^2=========================== m(k+1) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(k+1) - ! - ! ==var_zm======d^2(var_zm)/dz^2========d^4(var_zm)/dz^4=== m(k) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(k) - ! - ! ==var_zmm1====d^2(var_zm)/dz^2=========================== m(k-1) - ! - ! ------d(var_zm)/dz--------------------------------------- t(k-1) - ! - ! ==var_zmm2=============================================== m(k-2) - ! - ! The vertical indices m(k+2), t(k+2), m(k+1), t(k+1), m(k), t(k), m(k-1), - ! t(k-1), and m(k-2) correspond with altitudes zm(k+2), zt(k+2), zm(k+1), - ! zt(k+1), zm(k), zt(k), zm(k-1), zt(k-1), and zm(k-2) respectively. The - ! letter "t" is used for thermodynamic levels and the letter "m" is used for - ! momentum levels. - ! - ! dzm(k) = 1 / ( zt(k+1) - zt(k) ) - ! dzt(k+1) = 1 / ( zm(k+1) - zm(k) ) - ! dzt(k) = 1 / ( zm(k) - zm(k-1) ) - ! dzm(k+1) = 1 / ( zt(k+2) - zt(k+1) ) - ! dzm(k-1) = 1 / ( zt(k) - zt(k-1) ) - ! dzt(k+2) = 1 / ( zm(k+2) - zm(k+1) ) - ! dzt(k-1) = 1 / ( zm(k-1) - zm(k-2) ) - ! - ! The discretization of -nu*d^4(var_zm)/dz^4 at momentum level (k) is - ! written out as follows: - ! - ! -nu*dzm(k)*[ dzt(k+1)*{ dzm(k+1)*( dzt(k+2)*(var_zm(k+2)-var_zm(k+1)) - ! -dzt(k+1)*(var_zm(k+1)-var_zm(k)) ) - ! -dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) } - ! -dzt(k)*{ dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) - ! -dzm(k-1)*( dzt(k)*(var_zm(k)-var_zm(k-1)) - ! -dzt(k-1)*(var_zm(k-1)-var_zm(k-2)) ) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" sign - ! changes to a "+" sign when the term is brought over to the left-hand side, - ! and var_zm is considered to be at timestep (t+1). - ! - ! - ! 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 4th-order numerical diffusion term, -nu*d^4(var_zm)/dz^4 (which - ! is actually -d[nu*d^3(var_zm)/dz^3]/dz with a constant coefficient, - ! nu), the flux is: - ! - ! F = +nu*d^3(var_zm)/dz^3. - ! - ! In order to have zero-flux boundary conditions, the third derivative of - ! var_zm, d^3(var_zm)/dz^3, needs to equal 0 at both the lower boundary - ! and the upper boundary. - ! - ! Fourth-order numerical diffusion is used in conjunction with - ! second-order eddy diffusion, +d[(K_zt+nu)*d(var_zm)/dz]/dz, where the - ! coefficient of eddy diffusivity, (K_zt+nu), varies in the vertical. - ! Both 4th-order numerical diffusion and 2nd-order eddy diffusion use the - ! same boundary condition type at all times, which in this case is - ! zero-flux boundary conditions. For 2nd-order eddy diffusion, 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. - ! - ! Thus, the boundary conditions used for 4th-order numerical diffusion - ! are: d^3(var_zm)/dz^3 = 0 and d(var_zm)/dz = 0 at both the upper - ! boundary and the lower boundary, resulting in four boundary conditions, - ! which is the number of boundary conditions needed for a 4th-order term. - ! - ! 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 one of the boundary conditions. The boundary - ! condition d^3(var_zm)/dz^3 = 0 is also set at this level. The rest of - ! the levels involved are discretized normally, as listed above. - ! - ! Since the normal discretization includes two levels on either side of - ! the central level, the lower boundary begins to effect the - ! discretization at momentum level 2. - ! - ! =var_zm(4)=============================================== m(4) - ! - ! ------d(var_zm)/dz--------------------------------------- t(4) - ! - ! =var_zm(3)====d^2(var_zm)/dz^2=========================== m(3) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(3) - ! - ! =var_zm(2)====d^2(var_zm)/dz^2========d^4(var_zm)/dz^4=== m(2) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(2) - ! - ! =var_zm(1)====d^2(var_zm)/dz^2=========================== m(1) Boundary - ! - ! ------[d(var_zm)/dz = 0]--------------------------------- t(1) - ! - ! =[var_zm(0) = var_zm(1)]=====(level outside model)======= m(0) - ! - ! The discretization of -nu*d^4(var_zm)/dz^4 at momentum level (k=2) is - ! written out as follows: - ! - ! -nu*dzm(k)*[ dzt(k+1)*{ dzm(k+1)*( dzt(k+2)*(var_zm(k+2)-var_zm(k+1)) - ! -dzt(k+1)*(var_zm(k+1)-var_zm(k)) ) - ! -dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) } - ! -dzt(k)*{ dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) - ! -dzm(k-1)*dzt(k)*(var_zm(k)-var_zm(k-1)) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zm is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zm found at momentum - ! levels 1, 2, 3, and 4. Thus, it only affects 4 diagonals on the - ! left-hand side matrix. - ! - ! The lower boundary also effects the discretization at momentum - ! level 1. - ! - ! =var_zm(3)=============================================== m(3) - ! - ! ------d(var_zm)/dz--------------------------------------- t(3) - ! - ! =var_zm(2)====d^2(var_zm)/dz^2=========================== m(2) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(2) - ! - ! =var_zm(1)====d^2(var_zm)/dz^2========d^4(var_zm)/dz^4=== m(1) Boundary - ! - ! ------[d(var_zm)/dz = 0]--[d^3(var_zm)/dz^3 = 0]--------- t(1) - ! - ! =[var_zm(0) = var_zm(1)]=====(level outside model)======= m(0) - ! - ! The discretization of -nu*d^4(var_zm)/dz^4 at momentum level (k=1) is - ! written out as follows: - ! - ! -nu*dzm(k)*[dzt(k+1)*{ dzm(k+1)*( dzt(k+2)*(var_zm(k+2)-var_zm(k+1)) - ! -dzt(k+1)*(var_zm(k+1)-var_zm(k)) ) - ! -dzm(k)*dzt(k+1)*(var_zm(k+1)-var_zm(k)) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zm is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zm found at momentum - ! levels 1, 2, and 3. Thus, it only affects 3 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. - ! - ! For a 4th-order term, four boundary conditions are needed. Two - ! boundary conditions are applied at each boundary. For the case of - ! fixed-point boundary conditions, one of those two conditions is setting - ! var_zm = A, where A is a constant value. One more condition is needed. - ! Setting the values of d(var_zm)/dz and d^3(var_zm)/dz^3 are inherently - ! used for zero-flux (or perhaps fixed-flux) boundary conditions. - ! Fixed-point and zero-flux boundary conditions inherently should not be - ! invoked at the same time. The only remaining choice for a second - ! boundary condition for the fixed-point case is setting - ! d^2(var_zm)/dz^2. As it turns out, setting d^2(var_zm)/dz^2 = 0 is the - ! appropriate condition to use because it prevents values of var_zm at - ! levels outside the model from being involved in the discretization of - ! -nu*d^4(var_zm)/dz^4 at momentum level 2. Setting d^3(var_zm)/dz^3 = 0 - ! does not accomplish the same thing for the discretization of - ! -nu*d^4(var_zm)/dz^4 at momentum level 2. Also, as stated above, - ! fourth-order numerical diffusion is used in conjunction with - ! second-order eddy diffusion, +d[(K_zt+nu)*d(var_zm)/dz]/dz, where the - ! coefficient of eddy diffusivity, (K_zt+nu), varies in the vertical. - ! Both 4th-order numerical diffusion and 2nd-order eddy diffusion use the - ! same boundary condition type at all times, which in this case is - ! fixed-point boundary conditions. For 2nd-order eddy diffusion, - ! fixed-point boundary conditions set var_zm = A, and do not set - ! d(var_zm)/dz. Thus, d(var_zm)/dz cannot be set for fixed-point - ! boundary conditions. As previously stated, the only other boundary - ! condition that can be invoked for a fixed-point boundary case is - ! d^2(var_zm)/dz^2 = 0. - ! - ! Since the normal discretization includes two levels on either side of - ! the central level, the lower boundary begins to effect the - ! discretization at momentum level 2. - ! - ! =var_zm(4)=============================================== m(4) - ! - ! ------d(var_zm)/dz--------------------------------------- t(4) - ! - ! =var_zm(3)====d^2(var_zm)/dz^2=========================== m(3) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(3) - ! - ! =var_zm(2)====d^2(var_zm)/dz^2========d^4(var_zm)/dz^4=== m(2) - ! - ! ------d(var_zm)/dz--------d^3(var_zm)/dz^3--------------- t(2) - ! - ! =var_zm(1)====[d^2(var_zm)/dz^2 = 0]===================== m(1) Boundary - ! - ! ------d(var_zm)/dz--------------------------------------- t(1) - ! - ! =var_zm(0)===================(level outside model)======= m(0) - ! - ! The discretization of -nu*d^4(var_zm)/dz^4 at momentum level (k=2) is - ! written out as follows: - ! - ! -nu*dzm(k)*[ dzt(k+1)*{ dzm(k+1)*( dzt(k+2)*(var_zm(k+2)-var_zm(k+1)) - ! -dzt(k+1)*(var_zm(k+1)-var_zm(k)) ) - ! -dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) } - ! -dzt(k)*{ dzm(k)*( dzt(k+1)*(var_zm(k+1)-var_zm(k)) - ! -dzt(k)*(var_zm(k)-var_zm(k-1)) ) } ]. - ! - ! Again, the term is treated completely implicitly, so the leading "-" - ! sign changes to a "+" sign when the term is brought over to the - ! left-hand side, and var_zm is considered to be at timestep (t+1). - ! - ! The result is dependent only on values of var_zm found at momentum - ! levels 1, 2, 3, and 4. Thus, it only affects 4 diagonals on the - ! left-hand side matrix. - ! - ! The same method can be used to discretize -nu*d^4(var_zm)/dz^4 at the - ! second-highest momentum level (k=top-1) by setting d^2(var_zm)/dz^2 = 0 - ! at the highest momentum level. - ! - ! The discretization at momentum level (k=1) is written to simply set the - ! value var_zm(1) = A. Likewise, the discretization at momentum level - ! (k=top) is written to simply set the value var_zm(top) = B. In order - ! to discretize the boundary conditions at the lowest and highest - ! vertical levels 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 lowest and highest levels. Then set - ! the values at the lowest and highest 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 lowest and highest levels. - ! - ! Either way, at the lowest and highest 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 4th-order numerical 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 4th-order - ! numerical 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 4th-order - ! numerical 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/dzm )_i ( nu*dzm*dzt*dzm*dzt )_ij (var_zm)_j. - ! - ! The left-hand side matrix, ( nu*dzm*dzt*dzm*dzt )_ij, is partially written - ! below. The sum over i in the above equation removes the first dzm(k) - ! everywhere from the matrix below. The sum over j leaves the column totals - ! that are desired. - ! - ! Left-hand side matrix contributions from 4th-order numerical diffusion - ! (or hyper-diffusion) term; first five vertical levels: - ! - ! column 1 || column 2 || column 3 || column 4 || column 5 - ! ------------------------------------------------------------------------------------------> - ! | +nu -nu +nu - ! | *dzm(k) *dzm(k) *dzm(k) - ! | *[ dzt(k+1) *[ dzt(k+1) *dzt(k+1) - ! | *{ dzm(k+1) *{ dzm(k+1) *dzm(k+1) - !k=1| *dzt(k+1) *( dzt(k+2) *dzt(k+2) 0 0 - ! | +dzm(k) +dzt(k+1) ) - ! | *dzt(k+1) } +dzm(k) - ! | ] *dzt(k+1) } ] - ! | - ! | -nu +nu -nu +nu - ! | *dzm(k) *dzm(k) *dzm(k) *dzm(k) - ! | *[ dzt(k+1) *[ dzt(k+1) *[ dzt(k+1) *dzt(k+1) - ! | *dzm(k) *{ dzm(k+1) *{ dzm(k+1) *dzm(k+1) - ! | *dzt(k) *dzt(k+1) *( dzt(k+2) *dzt(k+2) - ! | +dzt(k) +dzm(k) +dzt(k+1) ) - !k=2| *{ dzm(k) *( dzt(k+1) +dzm(k) 0 - ! | *dzt(k) +dzt(k) ) } *dzt(k+1) } - ! | +dzm(k-1) +dzt(k) +dzt(k) - ! | *dzt(k) } ] *{ dzm(k) *dzm(k) - ! | *( dzt(k+1) *dzt(k+1) ] - ! | +dzt(k) ) - ! | +dzm(k-1) - ! | *dzt(k) } ] - ! | - ! | +nu -nu +nu -nu +nu - ! | *dzm(k) *dzm(k) *dzm(k) *dzm(k) *dzm(k) - ! | *dzt(k) *[ dzt(k+1) *[ dzt(k+1) *[ dzt(k+1) *dzt(k+1) - ! | *dzm(k-1) *dzm(k) *{ dzm(k+1) *{ dzm(k+1) *dzm(k+1) - ! | *dzt(k-1) *dzt(k) *dzt(k+1) *( dzt(k+2) *dzt(k+2) - ! | +dzt(k) +dzm(k) +dzt(k+1) ) - !k=3| *{ dzm(k) *( dzt(k+1) +dzm(k) - ! | *dzt(k) +dzt(k) ) } *dzt(k+1) } - ! | +dzm(k-1) +dzt(k) +dzt(k) - ! | *( dzt(k) *{ dzm(k) *dzm(k) - ! | +dzt(k-1) ) *( dzt(k+1) *dzt(k+1) ] - ! | } ] +dzt(k) ) - ! | +dzm(k-1) - ! | *dzt(k) } ] - ! | - ! | +nu -nu +nu -nu - ! | *dzm(k) *dzm(k) *dzm(k) *dzm(k) - ! | *dzt(k) *[ dzt(k+1) *[ dzt(k+1) *[ dzt(k+1) - ! | *dzm(k-1) *dzm(k) *{ dzm(k+1) *{ dzm(k+1) - ! | *dzt(k-1) *dzt(k) *dzt(k+1) *( dzt(k+2) - ! | +dzt(k) +dzm(k) +dzt(k+1) ) - !k=4| 0 *{ dzm(k) *( dzt(k+1) +dzm(k) - ! | *dzt(k) +dzt(k) ) } *dzt(k+1) } - ! | +dzm(k-1) +dzt(k) +dzt(k) - ! | *( dzt(k) *{ dzm(k) *dzm(k) - ! | +dzt(k-1) ) *( dzt(k+1) *dzt(k+1) ] - ! | } ] +dzt(k) ) - ! | +dzm(k-1) - ! | *dzt(k) } ] - ! | - ! | +nu -nu +nu - ! | *dzm(k) *dzm(k) *dzm(k) - ! | *dzt(k) *[ dzt(k+1) *[ dzt(k+1) - ! | *dzm(k-1) *dzm(k) *{ dzm(k+1) - ! | *dzt(k-1) *dzt(k) *dzt(k+1) - ! | +dzt(k) +dzm(k) - !k=5| 0 0 *{ dzm(k) *( dzt(k+1) - ! | *dzt(k) +dzt(k) ) } - ! | +dzm(k-1) +dzt(k) - ! | *( dzt(k) *{ dzm(k) - ! | +dzt(k-1) ) *( dzt(k+1) - ! | } ] +dzt(k) ) - ! | +dzm(k-1) - ! | *dzt(k) } ] - ! \ / - ! - ! Note: The super-super diagonal term from level 4 and both the super - ! diagonal and super-super diagonal terms from level 5 are not shown - ! on this diagram. - ! - ! Note: The matrix shown is a five-diagonal matrix. For a nine-diagonal - ! matrix, 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 4th-order hyper-diffusion term, - ! those extra row and column values are all 0, and the conservation - ! properties of the matrix aren't effected. - ! - ! For the case of fixed-point boundary conditions, the contributions of the - ! 4th-order hyper-diffusion term are as follows (only the top 2 levels - ! differ from the matrix diagram above): - ! - ! column 1 || column 2 || column 3 || column 4 || column 5 - ! ------------------------------------------------------------------------------------------> - !k=1| 0 0 0 0 0 - ! | - ! | -nu +nu -nu +nu - ! | *dzm(k) *dzm(k) *dzm(k) *dzm(k) - ! | *[ dzt(k+1) *[ dzt(k+1) *[ dzt(k+1) *dzt(k+1) - ! | *dzm(k) *{ dzm(k+1) *{ dzm(k+1) *dzm(k+1) - ! | *dzt(k) *dzt(k+1) *( dzt(k+2) *dzt(k+2) - !k=2| +dzt(k) +dzm(k) +dzt(k+1) ) 0 - ! | *dzm(k) *( dzt(k+1) +dzm(k) - ! | *dzt(k) ] +dzt(k) ) } *dzt(k+1) } - ! | +dzt(k) +dzt(k) - ! | *dzm(k) *dzm(k) - ! | *( dzt(k+1) *dzt(k+1) ] - ! | +dzt(k) ) ] - ! \ / - ! - ! For the left-hand side matrix as a whole, the matrix entries at level 1 - ! (k=1) read: 1 0 0 0 0. For the case of fixed-point boundary - ! conditions, 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. September 28, 2008. - - ! References: - ! None - !----------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_grid_class, only: & - gr ! Variable(s) gr%nz - - implicit none - - ! Constant parameters - integer, parameter :: & - kp2_mdiag = 1, & ! Momentum super-super diagonal index. - kp1_mdiag = 2, & ! Momentum super diagonal index. - k_mdiag = 3, & ! Momentum main diagonal index. - km1_mdiag = 4, & ! Momentum sub diagonal index. - km2_mdiag = 5 ! Momentum sub-sub diagonal index. - - ! Input Variables - character (len=*), intent(in) :: & - boundary_cond ! Type of boundary conditions being used - ! ('zero-flux' or 'fixed-point'). - - real( kind = core_rknd ), intent(in) :: & - nu, & ! Constant coef. of 4th-order numerical diffusion [m^4/s] - invrs_dzm, & ! Inverse of grid spacing over momentum level (k) [1/m] - invrs_dztp1, & ! Inverse of grid spacing over thermo. level (k+1) [1/m] - invrs_dzt, & ! Inverse of grid spacing over thermo. level (k) [1/m] - invrs_dzmp1, & ! Inverse of grid spacing over momentum level (k+1) [1/m] - invrs_dzmm1, & ! Inverse of grid spacing over momentum level (k-1) [1/m] - invrs_dztp2, & ! Inverse of grid spacing over thermo. level (k+2) [1/m] - invrs_dztm1 ! Inverse of grid spacing over thermo. level (k-1) [1/m] - - integer, intent(in) :: & - level ! Momentum level where calculation occurs. [-] - - ! Return Variable - real( kind = core_rknd ), dimension(5) :: lhs - - - if ( level == 1 ) then - - ! Lowest level - ! k = 1; lower boundery level at surface. - ! Only relevant if zero-flux boundary conditions are used. - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = 0.0_core_rknd - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = 0.0_core_rknd - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *invrs_dztp1*(invrs_dzmp1*invrs_dztp1 + invrs_dzm*invrs_dztp1) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *invrs_dztp1*( invrs_dzmp1*(invrs_dztp2 + invrs_dztp1) & - +invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = +nu*invrs_dzm & - *invrs_dztp1*invrs_dzmp1*invrs_dztp2 - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - ! The left-hand side matrix contributions from level 1 are - ! over-written or set in the parent subroutine. - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = 0.0_core_rknd - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = 0.0_core_rknd - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = 0.0_core_rknd - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = 0.0_core_rknd - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = 0.0_core_rknd - - endif - - - elseif ( level == 2 ) then - - ! Second-lowest level - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = 0.0_core_rknd - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dzt & - +invrs_dzt*( invrs_dzm*invrs_dzt & - +invrs_dzmm1*invrs_dzt ) ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*invrs_dztp1 & - +invrs_dzm*(invrs_dztp1 + invrs_dzt) ) & - +invrs_dzt*( invrs_dzm*(invrs_dztp1 + invrs_dzt) & - +invrs_dzmm1*invrs_dzt ) ) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*(invrs_dztp2 + invrs_dztp1) & - +invrs_dzm*invrs_dztp1 ) & - +invrs_dzt*invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = +nu*invrs_dzm & - *invrs_dztp1*invrs_dzmp1*invrs_dztp2 - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = 0.0_core_rknd - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dzt & - +invrs_dzt*invrs_dzm*invrs_dzt ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*invrs_dztp1 & - +invrs_dzm*(invrs_dztp1 + invrs_dzt) ) & - +invrs_dzt*invrs_dzm*(invrs_dztp1 + invrs_dzt) ) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*(invrs_dztp2 + invrs_dztp1) & - +invrs_dzm*invrs_dztp1 ) & - +invrs_dzt*invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = +nu*invrs_dzm & - *invrs_dztp1*invrs_dzmp1*invrs_dztp2 - - endif - - - elseif ( level > 2 .and. level < gr%nz-1 ) then - - ! k > 2 and k < num_levels-1 - ! These interior level are not effected by boundary conditions. - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = +nu*invrs_dzm & - *invrs_dzt*invrs_dzmm1*invrs_dztm1 - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dzt & - +invrs_dzt*( invrs_dzm*invrs_dzt & - +invrs_dzmm1*(invrs_dzt + invrs_dztm1) ) ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*invrs_dztp1 & - +invrs_dzm*(invrs_dztp1 + invrs_dzt) ) & - +invrs_dzt*( invrs_dzm*(invrs_dztp1 + invrs_dzt) & - +invrs_dzmm1*invrs_dzt ) ) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*(invrs_dztp2 + invrs_dztp1) & - +invrs_dzm*invrs_dztp1 ) & - +invrs_dzt*invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = +nu*invrs_dzm & - *invrs_dztp1*invrs_dzmp1*invrs_dztp2 - - - elseif ( level == gr%nz-1 ) then - - ! Second-highest level - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = +nu*invrs_dzm & - *invrs_dzt*invrs_dzmm1*invrs_dztm1 - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dzt & - +invrs_dzt*( invrs_dzm*invrs_dzt & - +invrs_dzmm1*(invrs_dzt + invrs_dztm1) ) ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*invrs_dztp1 & - +invrs_dzm*(invrs_dztp1 + invrs_dzt) ) & - +invrs_dzt*( invrs_dzm*(invrs_dztp1 + invrs_dzt) & - +invrs_dzmm1*invrs_dzt ) ) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzmp1*invrs_dztp1 & - +invrs_dzm*invrs_dztp1 ) & - +invrs_dzt*invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = 0.0_core_rknd - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = +nu*invrs_dzm & - *invrs_dzt*invrs_dzmm1*invrs_dztm1 - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dzt & - +invrs_dzt*( invrs_dzm*invrs_dzt & - +invrs_dzmm1*(invrs_dzt + invrs_dztm1) ) ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *( invrs_dztp1*( invrs_dzm*(invrs_dztp1 + invrs_dzt) ) & - +invrs_dzt*( invrs_dzm*(invrs_dztp1 + invrs_dzt) & - +invrs_dzmm1*invrs_dzt ) ) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = -nu*invrs_dzm & - *( invrs_dztp1*invrs_dzm*invrs_dztp1 & - +invrs_dzt*invrs_dzm*invrs_dztp1 ) - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = 0.0_core_rknd - - endif - - - elseif ( level == gr%nz ) then - - ! Highest level - ! k = gr%nz; upper boundery level at model top. - ! Only relevant if zero-flux boundary conditions are used. - - if ( trim( boundary_cond ) == 'zero-flux' ) then - - ! Zero-flux boundary conditions - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = +nu*invrs_dzm & - *invrs_dzt*invrs_dzmm1*invrs_dztm1 - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = -nu*invrs_dzm & - *invrs_dzt*( invrs_dzm*invrs_dzt & - +invrs_dzmm1*(invrs_dzt + invrs_dztm1) ) - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = +nu*invrs_dzm & - *invrs_dzt*(invrs_dzm*invrs_dzt + invrs_dzmm1*invrs_dzt) - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = 0.0_core_rknd - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = 0.0_core_rknd - - elseif ( trim( boundary_cond ) == 'fixed-point' ) then - - ! Fixed-point boundary conditions - ! The left-hand side matrix contributions from level gr%nz are - ! over-written or set in the parent subroutine. - - ! Momentum sub-sub diagonal: [ x var_zm(k-2,) ] - lhs(km2_mdiag) & - = 0.0_core_rknd - - ! Momentum sub diagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = 0.0_core_rknd - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = 0.0_core_rknd - - ! Momentum super diagonal: [ x var_zm(k+1,) ] - lhs(kp1_mdiag) & - = 0.0_core_rknd - - ! Momentum super-super diagonal: [ x var_zm(k+2,) ] - lhs(kp2_mdiag) & - = 0.0_core_rknd - - endif - - - endif - - - return - - end function hyper_dfsn_4th_ord_zm_lhs - -!=============================================================================== - -end module crmx_hyper_diffusion_4th_ord diff --git a/src/physics/spcam/crm/CLUBB/crmx_input_names.F90 b/src/physics/spcam/crm/CLUBB/crmx_input_names.F90 deleted file mode 100644 index d628d09b6f..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_input_names.F90 +++ /dev/null @@ -1,81 +0,0 @@ -!$Id: input_names.F90 5378 2011-08-22 20:19:16Z connork@uwm.edu $ -module crmx_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 crmx_input_names diff --git a/src/physics/spcam/crm/CLUBB/crmx_input_reader.F90 b/src/physics/spcam/crm/CLUBB/crmx_input_reader.F90 deleted file mode 100644 index a516a90063..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_input_reader.F90 +++ /dev/null @@ -1,857 +0,0 @@ -!$Id: input_reader.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_input_reader -! -! 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. -! -!--------------------------------------------------------------------------------------------------- - - use crmx_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(:), pointer :: 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(:,:), pointer :: 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 crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_input_names, only: & - time_name ! Constant(s) - - use crmx_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 crmx_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 crmx_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 - !---------------------------------------------------------------------------------------------- - - use crmx_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), 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 ) & - ! - ! 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 - !----------------------------------------------------------------------------------------------- - result( var_out ) - - use crmx_interpolation, only: zlinterp_fnc - - use crmx_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 :: associated - - ! 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 ( associated( 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 :: associated - - ! 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 ( associated( two_dim_vars(i)%values ) ) then - - deallocate(two_dim_vars(i)%values) - - end if - - end do - - if ( associated( 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_constants_clubb, only: & - fstderr ! Constant(s) - - implicit none - - ! 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 crmx_constants_clubb, only: & - fstderr ! Variable for writing to error stream - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! External Functions - intrinsic :: present, size - - ! 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 - - ! 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 crmx_input_reader diff --git a/src/physics/spcam/crm/CLUBB/crmx_interpolation.F90 b/src/physics/spcam/crm/CLUBB/crmx_interpolation.F90 deleted file mode 100644 index 7a69a4e9f6..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_interpolation.F90 +++ /dev/null @@ -1,620 +0,0 @@ -!------------------------------------------------------------------------------- -!$Id: interpolation.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_interpolation - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - private ! Default Scope - - public :: lin_int, binary_search, zlinterp_fnc, & - linear_interpolation, linear_interp_factor, mono_cubic_interp, plinterp_fnc - - contains - -!------------------------------------------------------------------------------- - pure function lin_int( 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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - 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_int - - ! Compute linear interpolation - - lin_int = ( ( height_int - height_low )/( height_high - height_low ) ) & - * ( var_high - var_low ) + var_low - - return - end function lin_int - - !------------------------------------------------------------------------------------------------- - 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 crmx_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 - !------------------------------------------------------------------------------------------------- - pure 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 crmx_constants_clubb, only: & - three_halves, & ! Constant(s) - eps - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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_int( 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 crmx_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 crmx_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 crmx_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_int( 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 linear_interpolation & - ( 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 crmx_error_code, only: clubb_debug ! Procedure - - use crmx_constants_clubb, only: fstderr ! Constant - - use crmx_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 for bubble sort- number of the - ! lowest yet-unsorted data point. - j ! Loop control variable for bubble sort- index of value - ! currently being tested - integer :: & - bottombound, & ! Index of the smaller value in the linear interpolation - topbound, & ! Index of the larger value in the linear interpolation - smallest ! Index of the present smallest value, for bubble sort - - real( kind = core_rknd ) :: temp ! A temporary variable used for the bubble sort swap - -!------------------------------------------------------------------------------- -! -! Bubble Sort algorithm, assuring that the elements are in order so -! that the interpolation is between the two closest points to the -! point in question. -! -!------------------------------------------------------------------------------- - - do i=1,nparam - smallest = i - do j=i,nparam - if ( xlist(j) < xlist(smallest) ) then - smallest = j - end if - end do - - temp = xlist(i) - xlist(i) = xlist(smallest) - xlist(smallest) = temp - - temp = tlist(i) - tlist(i) = tlist(smallest) - tlist(smallest) = temp - end do - -!------------------------------------------------------------------------------- -! -! 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,*) "linear_interpolation: 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 linear_interpolation.") - end if - - tvalue = & - lin_int( xvalue, xlist(topbound), xlist(bottombound), & - tlist(topbound), tlist(bottombound) ) - - return - end subroutine linear_interpolation - -end module crmx_interpolation diff --git a/src/physics/spcam/crm/CLUBB/crmx_lapack_wrap.F90 b/src/physics/spcam/crm/CLUBB/crmx_lapack_wrap.F90 deleted file mode 100644 index c70a7876a0..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_lapack_wrap.F90 +++ /dev/null @@ -1,740 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: lapack_wrap.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_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 crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_error_code, only: & - clubb_singular_matrix, & ! Variable(s) - clubb_bad_lapack_arg, & - clubb_var_equals_NaN, & - clubb_no_error - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - 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 = selected_real_kind( precision( 0.0_core_rknd ) ), & - dp = selected_real_kind( precision( 0.d0 ) ) - - 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 crmx_error_code, only: & - clubb_at_least_debug_level ! Logical function - - use crmx_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 crmx_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 - - 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" - - 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 crmx_error_code, only: & - clubb_at_least_debug_level ! Logical function - - use crmx_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 crmx_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 - - 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(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 - - 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 crmx_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 crmx_lapack_wrap diff --git a/src/physics/spcam/crm/CLUBB/crmx_matrix_operations.F90 b/src/physics/spcam/crm/CLUBB/crmx_matrix_operations.F90 deleted file mode 100644 index ce8ef95a3c..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_matrix_operations.F90 +++ /dev/null @@ -1,540 +0,0 @@ -! $Id: matrix_operations.F90 5690 2012-02-02 02:53:16Z dschanen@uwm.edu $ -module crmx_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_dp, & - set_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 crmx_clubb_precision, only: & - dp ! double precision - - implicit none - - ! External - intrinsic :: sqrt - - ! Input Variables - integer, intent(in) :: ndim - - real( kind = dp ), dimension(ndim,ndim), intent(in) :: & - covar ! Covariance Matrix [units vary] - - ! Output Variables - real( kind = dp ), dimension(ndim,ndim), intent(out) :: & - corr ! Correlation Matrix [-] - - ! Local Variables - integer :: i, j - - ! ---- Begin Code ---- - - corr = 0._dp ! 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 crmx_clubb_precision, only: & - dp ! double precision - - implicit none - - - ! Input Variables - integer, intent(in) :: ndim - - real( kind = dp ), dimension(ndim), intent(in) :: & - xvector ! Factors to be multiplied across a row [units vary] - - ! Input Variables - real( kind = dp ), dimension(ndim,ndim), intent(inout) :: & - tmatrix_in ! nxn matrix (usually a correlation matrix) [units vary] - - ! Output Variables - real( kind = dp ), 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 crmx_error_code, only: & - clubb_at_least_debug_level ! Procedure - - use crmx_constants_clubb, only: & - fstderr ! Constant - - use crmx_clubb_precision, only: & - dp, & ! double precision - core_rknd - - implicit none - - ! External - external :: dpotrf, dpoequ, dlaqsy ! LAPACK subroutines - - ! 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 = dp ), dimension(ndim,ndim), intent(in) :: a_input - - ! Output Variables - real( kind = dp ), dimension(ndim), intent(out) :: a_scaling - - real( kind = dp ), dimension(ndim,ndim), intent(out) :: a_Cholesky - - logical, intent(out) :: l_scaled - - ! Local Variables - real( kind = dp ), dimension(ndim) :: a_eigenvalues - real( kind = dp ), dimension(ndim,ndim) :: a_corr, a_scaled - - real( kind = dp ) :: tau, d_smallest - - real( kind = dp ) :: amax, scond - integer :: info - integer :: i, j, iter - - character :: equed - - ! ---- 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' - - ! Compute scaling for a_input - call dpoequ( ndim, a_input, ndim, a_scaling, scond, amax, info ) - - if ( info == 0 ) then - ! Apply scaling to a_input - call dlaqsy( 'Lower', ndim, a_scaled, ndim, a_scaling, scond, amax, equed ) - 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 - call dpotrf( 'Lower', ndim, a_Cholesky, ndim, info ) - - 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 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 - 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 * real(d_coef, kind = dp) * real( iter, kind=dp ) - -! 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: -! References: -!----------------------------------------------------------------------- - - use crmx_constants_clubb, only: & - fstderr ! Constant - - use crmx_clubb_precision, only: & - dp ! double precision - - implicit none - - ! External - external :: dsyev ! LAPACK subroutine - - ! 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 = dp ), dimension(ndim,ndim), intent(in) :: a_input - - ! Output Variables - real( kind = dp ), dimension(ndim), intent(out) :: a_eigenvalues - - ! Local Variables - real( kind = dp ), dimension(ndim,ndim) :: a_scratch - - real( kind = dp ), 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 - - call dsyev( 'No eigenvectors', 'Lower', ndim, a_scratch, ndim, & - a_eigenvalues, work, lwork, info ) - - 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 crmx_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 set_lower_triangular_matrix_dp( d_variables, index1, index2, xpyp, & - matrix ) -! Description: -! Set a value for the lower triangular portion of a matrix. -! References: -! None -!------------------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - dp ! double 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 = dp ), intent(in) :: & - xpyp ! Value for the matrix (usually a correlation or covariance) [units vary] - - ! Input/Output Variables - real( kind = dp ), 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_dp - -!------------------------------------------------------------------------------- - 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 crmx_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 crmx_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 - -end module crmx_matrix_operations diff --git a/src/physics/spcam/crm/CLUBB/crmx_mean_adv.F90 b/src/physics/spcam/crm/CLUBB/crmx_mean_adv.F90 deleted file mode 100644 index 792ac5325f..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_mean_adv.F90 +++ /dev/null @@ -1,505 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: mean_adv.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module crmx_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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_model_flags, only: & - l_upwind_xm_ma ! Variable(s) - - use crmx_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) & - = 0.0_core_rknd - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = 0.0_core_rknd - - ! 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. - - 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 > 0._core_rknd ) then ! Wind is in upward direction - - ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] - lhs(kp1_tdiag) & - = 0.0_core_rknd - - ! 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 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) & - = 0.0_core_rknd - - end if ! wm_zt >0 - - end if ! l_upwind_xm_ma - - elseif ( level == gr%nz ) then - - ! k = gr%nz (top level); upper boundary level. - - 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) & - = 0.0_core_rknd - - ! 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) & - = 0.0_core_rknd - - ! Thermodynamic main diagonal: [ x var_zt(k,) ] - lhs(k_tdiag) & - = + wm_zt * invrs_dzt * ( 1.0_core_rknd - 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 - - - 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 crmx_grid_class, only: & - gr - - use crmx_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) & - = 0.0_core_rknd - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = 0.0_core_rknd - - ! 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) & - = + 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) & - = 0.0_core_rknd - - ! Momentum main diagonal: [ x var_zm(k,) ] - lhs(k_mdiag) & - = 0.0_core_rknd - - ! Momentum subdiagonal: [ x var_zm(k-1,) ] - lhs(km1_mdiag) & - = 0.0_core_rknd - - - endif - - return - end function term_ma_zm_lhs - -!=============================================================================== - -end module crmx_mean_adv diff --git a/src/physics/spcam/crm/CLUBB/crmx_mixing_length.F90 b/src/physics/spcam/crm/CLUBB/crmx_mixing_length.F90 deleted file mode 100644 index 1418835d6e..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_mixing_length.F90 +++ /dev/null @@ -1,817 +0,0 @@ -! $Id: mixing_length.F90 5779 2012-04-02 16:59:10Z dschanen@uwm.edu $ -!=============================================================================== -module crmx_mixing_length - - implicit none - - private ! Default Scope - - public :: compute_length - - contains - - !============================================================================= - subroutine compute_length( thvm, thlm, rtm, em, & - 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 crmx_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 crmx_parameters_tunable, only: & ! Variable(s) - lmin ! Minimum value for Lscale [m] - - use crmx_parameters_model, only: & - Lscale_max ! Maximum value for Lscale [m] - - use crmx_grid_class, only: & - gr, & ! Variable(s) - zm2zt ! Procedure(s) - - use crmx_numerical_check, only: & - length_check ! Procedure(s) - - use crmx_saturation, only: & - sat_mixrat_liq, & ! Procedure(s) - sat_mixrat_liq_lookup - - use crmx_error_code, only: & - clubb_at_least_debug_level, & ! Procedure(s) - fatal_error - - use crmx_error_code, only: & - clubb_no_error ! Constant - - use crmx_model_flags, only: & - l_sat_mixrat_lookup ! Variable(s) - - use crmx_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) :: & - 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, rsl_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 - rsl_par_j = sat_mixrat_liq_lookup( p_in_Pa(j), tl_par_j ) - else - rsl_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-rsl_par_j)/(1._core_rknd+beta_par_j*rsl_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 - rsl_par_j = sat_mixrat_liq_lookup( p_in_Pa(j), tl_par_j ) - else - rsl_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-rsl_par_j)/(1._core_rknd+beta_par_j*rsl_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 crmx_mixing_length diff --git a/src/physics/spcam/crm/CLUBB/crmx_model_flags.F90 b/src/physics/spcam/crm/CLUBB/crmx_model_flags.F90 deleted file mode 100644 index b3fdc118f7..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_model_flags.F90 +++ /dev/null @@ -1,401 +0,0 @@ -!=============================================================================== -! $Id: model_flags.F90 6148 2013-04-08 21:45:15Z storer@uwm.edu $ - -module crmx_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_hyper_dfsn = .false., & ! 4th-order hyper-diffusion - l_pos_def = .false., & ! Flux limiting pos. def. 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, parameter, public :: & - l_use_precip_frac = .false. ! Flag to use precipitation fraction in KK - ! microphysics. The precipitation fraction - ! is automatically set to 1 when this flag - ! is turned off. - - logical, parameter, public :: & - l_morr_xp2_mc_tndcy = .false. !Flag to include the effects of rain evaporation - !on rtp2 and thlp2. The moister (rt1 or rt2) - !and colder (thl1 or thl2) will be fed into - !the morrison micro, and rain evaporation will - !be allowed to increase variances - - - ! 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) -! OpenMP directives. -!$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, & ! Diagnose correlations instead of using fixed ones - l_calc_w_corr ! Calculate the correlations between w and the hydrometeors - -!$omp threadprivate(l_diagnose_correlations, l_calc_w_corr) - -#ifdef GFDL - logical, public :: & - I_sat_sphum ! h1g, 2010-06-15 -#endif - - namelist /configurable_model_flags/ & - 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 - - 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 -!------------------------------------------------------------------------------- - use crmx_constants_clubb, only: & - fstderr ! Variable(s) - - 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_model_flags) - - 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_model_flags) - - 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 ) - -! 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 - - ! ---- 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 - - 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 ) - -! 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 - - ! ---- 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 - - return - end subroutine get_configurable_model_flags - -end module crmx_model_flags diff --git a/src/physics/spcam/crm/CLUBB/crmx_mono_flux_limiter.F90 b/src/physics/spcam/crm/CLUBB/crmx_mono_flux_limiter.F90 deleted file mode 100644 index 6ce1f60ece..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_mono_flux_limiter.F90 +++ /dev/null @@ -1,1838 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: mono_flux_limiter.F90 5715 2012-02-14 00:36:17Z dschanen@uwm.edu $ -!=============================================================================== -module crmx_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 crmx_grid_class, only: & - gr, & ! Variable(s) - zm2zt ! Procedure(s) - - use crmx_constants_clubb, only: & - zero_threshold, & - eps, & - fstderr - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_error_code, only: & - fatal_error, & ! Procedure(s) - clubb_no_error ! Constant - - use crmx_fill_holes, only: & - vertical_integral ! Procedure(s) - - use crmx_stats_type, only: & - stat_begin_update, & ! Procedure(s) - stat_end_update, & - stat_update_var - - use crmx_stats_variables, only: & - zm, & ! Variable(s) - 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=time_precision), 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 / real( dt, kind = core_rknd ), zm ) - call stat_begin_update( ixm_mfl, xm / real( dt, kind = core_rknd ), zt ) - endif - if ( l_stats_samp .and. solve_type == mono_flux_thlm ) then - call stat_update_var( ithlm_enter_mfl, xm, zt ) - call stat_update_var( ithlm_old, xm_old, zt ) - call stat_update_var( iwpthlp_entermfl, xm, zm ) - elseif ( l_stats_samp .and. solve_type == mono_flux_rtm ) then - call stat_update_var( irtm_enter_mfl, xm, zt ) - call stat_update_var( irtm_old, xm_old, zt ) - call stat_update_var( iwprtp_enter_mfl, xm, 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) + real( dt, kind = core_rknd )*xm_forcing(k) & - + real( dt, kind = core_rknd )*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) / (real( dt, kind = core_rknd )*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) / (real( dt, kind = core_rknd )*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, zt ) - call stat_update_var( ithlm_mfl_min, min_x_allowable, zt ) - call stat_update_var( ithlm_mfl_max, max_x_allowable, zt ) - call stat_update_var( iwpthlp_mfl_min, wpxp_mfl_min, zm ) - call stat_update_var( iwpthlp_mfl_max, wpxp_mfl_max, zm ) - elseif ( l_stats_samp .and. solve_type == mono_flux_rtm ) then - call stat_update_var( irtm_without_ta, xm_without_ta, zt ) - call stat_update_var( irtm_mfl_min, min_x_allowable, zt ) - call stat_update_var( irtm_mfl_max, max_x_allowable, zt ) - call stat_update_var( iwprtp_mfl_min, wpxp_mfl_min, zm ) - call stat_update_var( iwprtp_mfl_max, wpxp_mfl_max, 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) * real( dt, kind = core_rknd ) - - 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 / real( dt, kind = core_rknd ), zm ) - - call stat_end_update( ixm_mfl, xm / real( dt, kind = core_rknd ), zt ) - - if ( solve_type == mono_flux_thlm ) then - call stat_update_var( ithlm_exit_mfl, xm, zt ) - call stat_update_var( iwpthlp_exit_mfl, xm, zm ) - elseif ( solve_type == mono_flux_rtm ) then - call stat_update_var( irtm_exit_mfl, xm, zt ) - call stat_update_var( iwprtp_exit_mfl, xm, 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_mean_adv, only: & - term_ma_zt_lhs ! Procedure(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - 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 - real(kind=time_precision), 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 / real( dt, kind = core_rknd ) - - 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - implicit none - - ! Input Variables - real(kind=time_precision), 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) / real( dt, kind = core_rknd ) - - ! 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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_lapack_wrap, only: & - tridag_solve ! Procedure(s) - - use crmx_error_code, only: & - fatal_error, & ! Procedure(s) - clubb_no_error ! Constant - - use crmx_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, w1_zm, w2_zm, varnce_w1_zm, varnce_w2_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 crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - 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=time_precision), intent(in) :: & - dt ! Model timestep length [s] - - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - w1_zm, & ! Mean w (1st PDF component) [m/s] - w2_zm, & ! Mean w (2nd PDF component) [m/s] - varnce_w1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] - varnce_w2_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=time_precision) :: & - 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( w1_zm, w2_zm, varnce_w1_zm, varnce_w2_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_time_precision - - 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 = real( (1.0_core_rknd/gr%invrs_dzm(j)) / vert_vel_up(j), & - kind=time_precision ) - - ! 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_time_precision - - 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 = real( -(1.0_core_rknd/gr%invrs_dzm(j-1)) / vert_vel_down(j-1), & - kind=time_precision ) - - ! Total time elapsed for crossing all grid levels that have been - ! passed, thus far. - dt_all_grid_levs = real( dt_all_grid_levs + dt_one_grid_lev, kind=time_precision ) - - ! 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( w1_zm, w2_zm, varnce_w1_zm, varnce_w2_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 w1, and the values of w that are part of the 2nd normal - ! distribution are referred to as w2. Note that these distributions - ! overlap, and there are many values of w that are found in both w1 and w2. - ! - ! The probability density function (PDF) for w, P(w), is: - ! - ! P(w) = mixt_frac*P(w1) + (1-mixt_frac)*P(w2); - ! - ! where "mixt_frac" is the weight of the 1st normal distribution, and P(w1) and - ! P(w2) are the equations for the 1st and 2nd normal distributions, - ! respectively: - ! - ! P(w1) = 1 / ( sigma_w1 * sqrt(2*PI) ) - ! * EXP[ -(w1-mu_w1)^2 / (2*sigma_w1^2) ]; and - ! - ! P(w2) = 1 / ( sigma_w2 * sqrt(2*PI) ) - ! * EXP[ -(w2-mu_w2)^2 / (2*sigma_w2^2) ]. - ! - ! The mean of the 1st normal distribution is mu_w1, and the standard - ! deviation of the 1st normal distribution is sigma_w1. The mean of the - ! 2nd normal distribution is mu_w2, and the standard deviation of the 2nd - ! normal distribution is sigma_w2. - ! - ! 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) w1 P(w1) dw1 - ! + (1-mixt_frac) * INT(-inf:w|_ref) w2 P(w2) dw2. - ! - ! 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_w1 / sqrt(2*PI) ) - ! * EXP[ -(w|_ref-mu_w1)^2 / (2*sigma_w1^2) ] - ! + mu_w1 * (1/2) - ! *[1 + erf( (w|_ref-mu_w1) / (sqrt(2)*sigma_w1) )] } - ! + (1-mixt_frac) * { - ( sigma_w2 / sqrt(2*PI) ) - ! * EXP[ -(w|_ref-mu_w2)^2 / (2*sigma_w2^2) ] - ! + mu_w2 * (1/2) - ! *[1 + erf( (w|_ref-mu_w2) / (sqrt(2)*sigma_w2) )] }. - ! - ! 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) w1 P(w1) dw1 - ! + (1-mixt_frac) * INT(w|_ref:inf) w2 P(w2) dw2. - ! - ! 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_w1 / sqrt(2*PI) ) - ! * EXP[ -(w|_ref-mu_w1)^2 / (2*sigma_w1^2) ] - ! + mu_w1 * (1/2) - ! *[1 - erf( (w|_ref-mu_w1) / (sqrt(2)*sigma_w1) )] } - ! + (1-mixt_frac) * { ( sigma_w2 / sqrt(2*PI) ) - ! * EXP[ -(w|_ref-mu_w2)^2 / (2*sigma_w2^2) ] - ! + mu_w2 * (1/2) - ! *[1 - erf( (w|_ref-mu_w2) / (sqrt(2)*sigma_w2) )] }. - ! - ! 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 crmx_grid_class, only: & - gr, & ! Variable(s) - zt2zm ! Procedure(s) - - use crmx_constants_clubb, only: & - sqrt_2pi, & - sqrt_2 - - use crmx_anl_erf, only: & - erf ! Procedure(s) - ! The error function - - use crmx_stats_type, only: & - stat_update_var_pt ! Procedure(s) - - use crmx_stats_variables, only: & - zm, & ! Variable(s) - imean_w_up, & - imean_w_down, & - l_stats_samp - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & - w1_zm, & ! Mean w (1st PDF component) [m/s] - w2_zm, & ! Mean w (2nd PDF component) [m/s] - varnce_w1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] - varnce_w2_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_w1, & ! Standard deviation of w for 1st normal distribution [m/s] - sigma_w2, & ! 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_w1 = sqrt( varnce_w1_zm(k) ) - - ! Standard deviation of w for the 2nd normal distribution. - sigma_w2 = sqrt( varnce_w2_zm(k) ) - - - ! Contributions from the 1st normal distribution. - if ( w1_zm(k) + 3._core_rknd*sigma_w1 <= w_ref ) then - - ! The entire 1st normal is on the negative side of w|_ref. - mean_w_down_1st = w1_zm(k) - mean_w_up_1st = 0.0_core_rknd - - elseif ( w1_zm(k) - 3._core_rknd*sigma_w1 >= 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 = w1_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-w1_zm(k))**2 ... etc. part of the formula. - ! ~~EIHoppe//20090618 - exp_cache = exp( -(w_ref-w1_zm(k))**2 / (2.0_core_rknd*sigma_w1**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-w1_zm(k)) / (sqrt_2*sigma_w1) ) - - ! The 1st normal has values on both sides of w_ref. - mean_w_down_1st = & - - (sigma_w1/sqrt_2pi) & -! * exp( -(w_ref-w1_zm(k))**2 / (2.0_core_rknd*sigma_w1**2) ) & - * exp_cache & -! + w1(k) * 0.5_core_rknd*( 1.0_core_rknd + erf( (w_ref-w1(k)) / (sqrt_2*sigma_w1) ) ) - + w1_zm(k) * 0.5_core_rknd*( 1.0_core_rknd + erf_cache) - - mean_w_up_1st = & - + (sigma_w1/sqrt_2pi) & -! * exp( -(w_ref-w1(k))**2 / (2.0_core_rknd*sigma_w1**2) ) & - * exp_cache & -! + w1(k) * 0.5_core_rknd*( 1.0_core_rknd - erf( (w_ref-w1(k)) / (sqrt_2*sigma_w1) ) ) - + w1_zm(k) * 0.5_core_rknd*( 1.0_core_rknd - erf_cache) - - ! /EIHoppe changes - - endif - - - ! Contributions from the 2nd normal distribution. - if ( w2_zm(k) + 3._core_rknd*sigma_w2 <= w_ref ) then - - ! The entire 2nd normal is on the negative side of w|_ref. - mean_w_down_2nd = w2_zm(k) - mean_w_up_2nd = 0.0_core_rknd - - elseif ( w2_zm(k) - 3._core_rknd*sigma_w2 >= 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 = w2_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-w1(k))**2 ... etc. part of the formula. - ! ~~EIHoppe//20090618 - exp_cache = exp( -(w_ref-w2_zm(k))**2 / (2.0_core_rknd*sigma_w2**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-w2_zm(k)) / (sqrt_2*sigma_w2) ) - - ! The 2nd normal has values on both sides of w_ref. - mean_w_down_2nd = & - - (sigma_w2/sqrt_2pi) & -! * exp( -(w_ref-w2_zm(k))**2 / (2.0_core_rknd*sigma_w2**2) ) & - * exp_cache & -! + w2_zm(k) * 0.5_core_rknd*( 1.0_core_rknd + erf( (w_ref-w2(k)) / (sqrt_2*sigma_w2) ) ) - + w2_zm(k) * 0.5_core_rknd*( 1.0_core_rknd + erf_cache) - - mean_w_up_2nd = & - + (sigma_w2/sqrt_2pi) & -! * exp( -(w_ref-w2(k))**2 / (2.0_core_rknd*sigma_w2**2) ) & - * exp_cache & -! + w2(k) * 0.5_core_rknd*( 1.0_core_rknd - erf( (w_ref-w2(k)) / (sqrt_2*sigma_w2) ) ) - + w2_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), zm ) - - call stat_update_var_pt( imean_w_down, k, mean_w_down(k), zm ) - - endif ! l_stats_samp - - enddo ! k = 2, gr%nz, 1 - - - return - end subroutine mean_vert_vel_up_down - -!=============================================================================== - -end module crmx_mono_flux_limiter diff --git a/src/physics/spcam/crm/CLUBB/crmx_mt95.f90 b/src/physics/spcam/crm/CLUBB/crmx_mt95.f90 deleted file mode 100644 index 7c2ff7d9db..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_mt95.f90 +++ /dev/null @@ -1,1317 +0,0 @@ -! A C-program for MT19937, with initialization improved 2002/1/26. -! Coded by Takuji Nishimura and Makoto Matsumoto. - -! Code converted to Fortran 95 by Jose Rui Faustino de Sousa -! Date: 2002-02-01 - -! Enhanced version by Jose 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 crmx_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 - - 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 Jose Sousa genrand_real[1-3] will not return exactely - ! the same values but should have the same properties and are faster - -end module crmx_mt95 - diff --git a/src/physics/spcam/crm/CLUBB/crmx_numerical_check.F90 b/src/physics/spcam/crm/CLUBB/crmx_numerical_check.F90 deleted file mode 100644 index c6650f4a99..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_numerical_check.F90 +++ /dev/null @@ -1,1072 +0,0 @@ -!------------------------------------------------------------------------ -! $Id: numerical_check.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_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 crmx_grid_class, only: & - gr ! Variable - - use crmx_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, & - crt1, crt2, cthl1, cthl2, pdf_params, & - err_code, & - sclrpthvp, sclrprcp, wpsclrp2, & - wpsclrprtp, wpsclrpthlp, wp2sclrp ) - -! 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 crmx_parameters_model, only: & - sclr_dim ! Variable - - use crmx_pdf_parameter_module, only: & - pdf_parameter ! type - - use crmx_stats_variables, only: & - iwp4, & ! Variables - ircp2, & - iwprtp2, & - iwprtpthlp, & - iwpthlp2 - - use crmx_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)] - crt1, crt2, & - cthl1, cthl2 - - 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( crt1, "crt1", proc_name, err_code ) - call check_nan( crt2, "crt2", proc_name, err_code ) - call check_nan( cthl1, "cthl1", proc_name, err_code ) - call check_nan( cthl2, "cthl2", proc_name, err_code ) - ! Check each PDF parameter at the grid level sent in. - call check_nan( pdf_params%w1, "pdf_params%w1", proc_name, err_code ) - call check_nan( pdf_params%w2, "pdf_params%w2", proc_name, err_code ) - call check_nan( pdf_params%varnce_w1, "pdf_params%varnce_w1", proc_name, err_code ) - call check_nan( pdf_params%varnce_w2, "pdf_params%varnce_w2", proc_name, err_code ) - call check_nan( pdf_params%rt1, "pdf_params%rt1", proc_name, err_code ) - call check_nan( pdf_params%rt2, "pdf_params%rt2", proc_name, err_code ) - call check_nan( pdf_params%varnce_rt1, "pdf_params%varnce_rt1", proc_name, err_code ) - call check_nan( pdf_params%varnce_rt2, "pdf_params%varnce_rt2", proc_name, err_code ) - call check_nan( pdf_params%thl1, "pdf_params%thl1", proc_name, err_code ) - call check_nan( pdf_params%thl2, "pdf_params%thl2", proc_name, err_code ) - call check_nan( pdf_params%varnce_thl1, "pdf_params%varnce_thl1", proc_name, err_code ) - call check_nan( pdf_params%varnce_thl2, "pdf_params%varnce_thl2", 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%rc1, "pdf_params%rc1", proc_name, err_code ) - call check_nan( pdf_params%rc2, "pdf_params%rc2", proc_name, err_code ) - call check_nan( pdf_params%rsl1, "pdf_params%rsl1", proc_name, err_code ) - call check_nan( pdf_params%rsl2, "pdf_params%rsl2", proc_name, err_code ) - call check_nan( pdf_params%cloud_frac1, "pdf_params%cloud_frac1", proc_name, err_code ) - call check_nan( pdf_params%cloud_frac2, "pdf_params%cloud_frac2", proc_name, err_code ) - call check_nan( pdf_params%s1, "pdf_params%s1", proc_name, err_code ) - call check_nan( pdf_params%s2, "pdf_params%s2", proc_name, err_code ) - call check_nan( pdf_params%stdev_s1, "pdf_params%stdev_s1", proc_name, err_code ) - call check_nan( pdf_params%stdev_s2, "pdf_params%stdev_s2", 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 crmx_grid_class, only: & - gr ! Variable - - use crmx_parameters_model, only: & - sclr_dim, & ! Variable - edsclr_dim - - use crmx_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, err_code, & - sclrp2_sfc, sclrprtp_sfc, sclrpthlp_sfc ) -! -! 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 crmx_parameters_model, only: & - sclr_dim ! Variable - - use crmx_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, ricem, & - cloud_frac, p_in_Pa, exner, rho_zm ) -! Description: -! Checks radiation input variables. If they are < 0 it reports -! to the console. -!------------------------------------------------------------------------ - - use crmx_constants_clubb, only: & - fstderr ! Variable - - use crmx_grid_class, only: & - gr ! Variable - - use crmx_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] - ricem, & ! 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( ricem, gr%nz ,"ricem", 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 crmx_variables_diagnostic_module, only: & - hydromet, & ! Variable(s) - wp2thvp, & - rtpthvp, & - thlpthvp - - use crmx_variables_prognostic_module, only: & - um, & ! Variable(s) - vm, & - wp2, & - wp3, & - rtm, & - thlm, & - rtp2, & - thlp2, & - wprtp, & - wpthlp, & - rtpthlp, & - sclrm, & - edsclrm - - use crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_parameters_model, only: & - sclr_dim, & ! Variable(s) - edsclr_dim, & - hydromet_dim - - use crmx_parameters_microphys, 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 crmx_parameters_model, only: & - PosInf ! Variable(s) -#endif - - use crmx_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 crmx_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 crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_error_code, only: & - clubb_var_less_than_zero ! Variable(s) - - use crmx_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 crmx_constants_clubb, only: & - fstderr ! Variable - - use crmx_error_code, only: & - clubb_var_less_than_zero ! Variable - - use crmx_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 crmx_constants_clubb, only: & - fstderr ! Variable(s) - use crmx_error_code, only: & - clubb_var_equals_NaN ! Variable(s) - use crmx_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 crmx_constants_clubb, only: & - fstderr ! Variable - use crmx_error_code, only: & - clubb_var_equals_NaN ! Variable - use crmx_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 crmx_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 crmx_numerical_check diff --git a/src/physics/spcam/crm/CLUBB/crmx_output_grads.F90 b/src/physics/spcam/crm/CLUBB/crmx_output_grads.F90 deleted file mode 100644 index af4f37e25c..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_output_grads.F90 +++ /dev/null @@ -1,754 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: output_grads.F90 5867 2012-07-03 21:06:44Z dschanen@uwm.edu $ -module crmx_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 crmx_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, 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 crmx_constants_clubb, only: & - fstderr, & ! Variable - fstdout - - use crmx_stat_file_module, only: & - stat_file ! Type - - use crmx_clubb_precision, only: & - time_precision ! Variable - - 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 [-] - iz ! Upper Bound of z [-] - - real( kind = core_rknd ), dimension(:), intent(in) :: z - - 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(1), intent(in) :: & - rlat, rlon ! Latitude and Longitude [Degrees N/E] - - real(kind=time_precision), intent(in) :: & - time, & ! Time since Model start [s] - 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 - - allocate( grads_file%rlat(1), grads_file%rlon(1) ) - - grads_file%rlat = rlat - grads_file%rlon = rlon - - grads_file%dtwrite = dtwrite - - grads_file%nvar = nvar - - ! 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 crmx_stat_file_module, only: & - variable ! Type - - use crmx_clubb_precision, only: & - time_precision ! Variable - - use crmx_constants_clubb, only: & - fstderr, & ! Variable - fstdout, & - 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=time_precision), 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=time_precision) :: dtwrite_in - - real( kind = core_rknd ), dimension(:), allocatable :: z_in - - type (variable), dimension(:), pointer :: 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 ) * sec_per_hr & - + real( imin, kind=time_precision ) * sec_per_min - 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 crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_model_flags, only: & - l_byteswap_io ! Variable - - use crmx_endian, only: & - big_endian, & ! Variable - little_endian - - use crmx_stat_file_module, only: & - stat_file ! Type - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - 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 :: & - i, & ! Loop indices - ios ! I/O status - - 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 ), & - 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 i=1,grads_file%nvar - write(grads_file%iounit,rec=grads_file%nrecord) & - real( grads_file%var(i)%ptr(1,1,grads_file%ia:grads_file%iz), kind=r4) - grads_file%nrecord = grads_file%nrecord + 1 - end do - - else - do i=1, grads_file%nvar - write(grads_file%iounit,rec=grads_file%nrecord) & - real( grads_file%var(i)%ptr(1,1,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,e11.5)') 'UNDEF ',undef - write(unit=grads_file%iounit,fmt='(a,f8.3,a)') 'XDEF 1 LINEAR ', grads_file%rlon, ' 1.' - write(unit=grads_file%iounit,fmt='(a,f8.3,a)') 'YDEF 1 LINEAR ', grads_file%rlat, ' 1.' - if ( grads_file%ia == grads_file%iz ) then - 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(i-grads_file%ia+1),i=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-i+1), & - i=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 i=1, grads_file%nvar, 1 - write(unit=grads_file%iounit,fmt='(a,i5,a,a)') & - grads_file%var(i)%name(1:len_trim(grads_file%var(i)%name)), & - abs(grads_file%iz-grads_file%ia)+1,' 99 ', & - grads_file%var(i)%description(1:len_trim(grads_file%var(i)%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 crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_calendar, only: & - compute_current_date ! Procedure(s) - - use crmx_calendar, only: & - month_names ! Variable(s) - - use crmx_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/sec_per_hr ) - 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 crmx_constants_clubb, only: & - sec_per_day, & ! Constants - sec_per_hr, & - sec_per_min - - use crmx_clubb_precision, only: & - time_precision ! Variable(s) - - implicit none - - ! External - intrinsic :: max, floor - - ! Input Variables - real(kind=time_precision), 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=time_precision) :: & - 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=time_precision ) - dtwrite_min = max( 1._time_precision, dtwrite_min ) - - if ( dtwrite_min <= 99._time_precision ) then - dtwrite_ctl = int( dtwrite_min ) - units = 'mn' - else - dtwrite_hrs = dtwrite_sec / sec_per_hr - if ( dtwrite_hrs <= 99._time_precision ) then - dtwrite_ctl = int( dtwrite_hrs ) - units = 'hr' - else - dtwrite_days = dtwrite_sec / sec_per_day - if ( dtwrite_days <= 99._time_precision ) 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 crmx_output_grads -!------------------------------------------------------------------------------- diff --git a/src/physics/spcam/crm/CLUBB/crmx_output_netcdf.F90 b/src/physics/spcam/crm/CLUBB/crmx_output_netcdf.F90 deleted file mode 100644 index cf5157e524..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_output_netcdf.F90 +++ /dev/null @@ -1,835 +0,0 @@ -! $Id: output_netcdf.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!------------------------------------------------------------------------------- -module crmx_output_netcdf -#ifdef NETCDF - -! Description: -! Functions and subroutines for writing NetCDF files - -! References: -! -!------------------------------------------------------------------------------- - - implicit none - - public :: open_netcdf, 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_kludge = .true. - - private ! Default scope - - contains -!------------------------------------------------------------------------------- - subroutine open_netcdf( 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 crmx_stat_file_module, only: & - stat_file ! Type - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_constants_clubb, only: & - fstderr ! Variable(s) - - 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=time_precision), 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 - - ! 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 - 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 - -!------------------------------------------------------------------------------- - - 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 crmx_stat_file_module, only: & - stat_file ! Variable - - use crmx_constants_clubb, only: & - fstderr, & ! Variable - sec_per_min - - use crmx_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_kludge ) then - time = real( nint( real( ncf%ntimes, kind=time_precision ) & - * ncf%dtwrite / sec_per_min ), kind=time_precision ) ! minutes(rounded) - else - time = real( ncf%ntimes, kind=time_precision ) * ncf%dtwrite ! 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 crmx_clubb_precision, only: & - time_precision ! Variable(s) - - use crmx_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_FLOAT, & - (/LongDimId/), LongVarId ) - - ! Latitude = deg_N = Y - stat = nf90_def_var( ncid, "latitude", NF90_FLOAT, & - (/LatDimId/), LatVarId ) - - ! Altitude = meters above the surfac3 = Z - stat = nf90_def_var( ncid, "altitude", NF90_FLOAT, & - (/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 crmx_stat_file_module, only: & - stat_file ! Type - - use netcdf, only: & - NF90_NOERR, & ! Variable - nf90_close, & ! Procedure(s) - nf90_strerror - - use crmx_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 - 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_GLOBAL, & - nf90_def_var, & ! Procedure(s) - nf90_strerror, & - nf90_put_att, & - nf90_enddef - - use crmx_stat_file_module, only: & - stat_file ! Derived type - - use crmx_constants_clubb, only: & - fstderr ! Variable - - use crmx_parameters_model, only: & - T0, & ! Real variables - ts_nudge, & - sclr_tol ! Real array variable - - use crmx_parameters_tunable, only: & - params_list ! Variable names (characters) - - use crmx_parameters_tunable, only: & - get_parameters ! Subroutine - - use crmx_parameter_indices, only: & - nparams ! Integer - - use crmx_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 crmx_parameters_microphys, only: & - micro_scheme, & ! Variable(s) - l_local_kk, & ! Logicals - l_cloud_sed - - use crmx_parameters_radiation, only: & - rad_scheme - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input/Output Variables - type (stat_file), intent(inout) :: ncf - - ! Local Variables - integer, dimension(:), allocatable :: stat - - 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=4), 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 - -! We use a 4 byte data model for NetCDF and GrADS to save disk space -!------------------------------------------------------------------------------- - 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. - - 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 ), & - NF90_FLOAT, 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 definition" - - deallocate( stat ) - - allocate( stat(5) ) - - ! 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" ) - - ! 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) ) - - stat(4) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "micro_scheme", & - trim( micro_scheme ) ) - - stat(5) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "rad_scheme", & - trim( rad_scheme ) ) - - 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(10) ) ! # of model flags - - stat(1) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_local_kk", lchar( l_local_kk ) ) - stat(2) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_pos_def", lchar( l_pos_def ) ) - stat(3) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_hole_fill", lchar( l_hole_fill ) ) - stat(4) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_clip_semi_implicit", & - lchar( l_clip_semi_implicit ) ) - stat(5) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_standard_term_ta", & - lchar( l_standard_term_ta ) ) - stat(6) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_single_C2_Skw", & - lchar( l_single_C2_Skw ) ) - stat(7) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_gamma_Skw", lchar( l_gamma_Skw ) ) - stat(8) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_cloud_sed", lchar( l_cloud_sed ) ) - stat(9) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_uv_nudge", lchar( l_uv_nudge ) ) - stat(10) = 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 crmx_stat_file_module, only: & - stat_file ! Type - use crmx_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 crmx_calendar, only: & - compute_current_date ! Procedure(s) - - use crmx_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_kludge ) 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 ) - - return - end subroutine format_date - -!=============================================================================== - character function lchar( l_input ) -! Description: -! Cast a logical to a character data type -! -! References: -! None -!------------------------------------------------------------------------------- - - implicit none - - 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 crmx_output_netcdf diff --git a/src/physics/spcam/crm/CLUBB/crmx_parameter_indices.F90 b/src/physics/spcam/crm/CLUBB/crmx_parameter_indices.F90 deleted file mode 100644 index a4aefca91f..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_parameter_indices.F90 +++ /dev/null @@ -1,108 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: parameter_indices.F90 5929 2012-09-07 18:09:59Z bmg2@uwm.edu $ -module crmx_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 initvars and initspread will need to -! have the parameter added to them. -!------------------------------------------------------------------------------- - - implicit none - - private ! Default Scope - - integer, parameter, public :: & - nparams = 61 ! 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_Krrainm = 47, & - inu_r = 48, & - inu_hd = 49 - - integer, parameter, public :: & - igamma_coef = 50, & - igamma_coefb = 51, & - igamma_coefc = 52, & - imu = 53, & - ibeta = 54, & - ilmin_coef = 55, & - imult_coef = 56, & - itaumin = 57, & - itaumax = 58, & - iLscale_mu_coef = 59, & - iLscale_pert_coef = 60, & - ialpha_corr = 61 - -end module crmx_parameter_indices -!----------------------------------------------------------------------- diff --git a/src/physics/spcam/crm/CLUBB/crmx_parameters_microphys.F90 b/src/physics/spcam/crm/CLUBB/crmx_parameters_microphys.F90 deleted file mode 100644 index e6fe31957b..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_parameters_microphys.F90 +++ /dev/null @@ -1,191 +0,0 @@ -! $Id: parameters_microphys.F90 6063 2013-02-12 18:01:12Z dschanen@uwm.edu $ -!=============================================================================== -module crmx_parameters_microphys - -! Description: -! Parameters for microphysical schemes - -! References: -! None -!------------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - time_precision, & - core_rknd - - use crmx_mt95, only: & - genrand_intg - - implicit none - - ! Constant Parameters - integer, parameter, public :: & - LH_microphys_interactive = 1, & ! Feed the samples into the microphysics and allow feedback - LH_microphys_non_interactive = 2, & ! Feed the samples into the microphysics with no feedback - LH_microphys_disabled = 3 ! Disable Latin hypercube entirely - - ! Morrison aerosol parameters - integer, parameter, public :: & - morrison_no_aerosol = 0, & - morrison_power_law = 1, & - morrison_lognormal = 2 - - ! Local Variables - logical, public :: & - l_cloud_sed, & ! Cloud water sedimentation (K&K/No microphysics) - l_ice_micro, & ! Compute ice (COAMPS/Morrison) - l_upwind_diff_sed, & ! Use upwind differencing approx. for sedimentation (K&K/COAMPS) - l_graupel, & ! Compute graupel (COAMPS/Morrison) - l_hail, & ! Assumption about graupel/hail? (Morrison) - l_seifert_beheng, & ! Use Seifert and Behneng warm drizzle (Morrison) - l_predictnc, & ! Predict cloud droplet conconcentration (Morrison) - l_const_Nc_in_cloud, & ! Use a constant cloud droplet conc. within cloud (K&K) - l_subgrid_w, & ! Use subgrid w (Morrison) - l_arctic_nucl, & ! Use MPACE observations (Morrison) - l_fix_pgam, & ! Fix pgam (Morrison) - l_in_cloud_Nc_diff, & ! Use in cloud values of Nc for diffusion - l_var_covar_src ! Flag for using upscaled microphysics source terms - ! for predictive variances and covariances (KK micro) - -!$omp threadprivate( l_cloud_sed, l_ice_micro, l_graupel, l_hail, & -!$omp l_upwind_diff_sed, l_seifert_beheng, l_predictnc, & -!$omp l_const_Nc_in_cloud, l_subgrid_w, l_arctic_nucl, & -!$omp l_fix_pgam, l_in_cloud_Nc_diff, l_var_covar_src ) - - logical, public :: & - l_cloud_edge_activation, & ! Activate on cloud edges (Morrison) - l_local_kk ! Local drizzle for Khairoutdinov & Kogan microphysics - -!$omp threadprivate(l_cloud_edge_activation, l_local_kk) - - character(len=30), public :: & - specify_aerosol ! Specify aerosol (Morrison) - - ! Flags for the Latin Hypercube sampling code - logical, public :: & - l_fix_s_t_correlations, & ! Use a fixed correlation for s and t Mellor - l_lh_cloud_weighted_sampling, & ! Limit noise by sampling in-cloud - l_lh_vert_overlap ! Assume maximum overlap for s_mellor - -!$omp threadprivate( l_fix_s_t_correlations, l_lh_cloud_weighted_sampling, & -!$omp l_lh_vert_overlap ) - - integer, public :: & - LH_microphys_calls, & ! Number of latin hypercube samples to call the microphysics with - LH_sequence_length ! Number of timesteps before the latin hypercube seq. repeats - - integer(kind=genrand_intg), public :: & - LH_seed ! Seed for the Mersenne - -!$omp threadprivate( LH_microphys_calls, LH_sequence_length, LH_seed ) - - ! Determines how the latin hypercube samples should be used with the microphysics - integer, public :: & - LH_microphys_type - -!$omp threadprivate( LH_microphys_type ) - - character(len=50), public :: & - micro_scheme ! khairoutdinv_kogan, simplified_ice, coamps, etc. - -!$omp threadprivate( micro_scheme ) - - character(len=10), dimension(:), allocatable, public :: & - hydromet_list - -!$omp threadprivate( hydromet_list ) - - real(kind=time_precision), public :: & - microphys_start_time ! When to start the microphysics [s] - -!$omp threadprivate( microphys_start_time ) - - real( kind = core_rknd ), public :: & - Ncm_initial ! Initial cloud droplet number concentration [#/m^3] - -!$omp threadprivate( Ncm_initial ) - - real( kind = core_rknd ), public :: & - sigma_g ! Geometric std. dev. of cloud droplets falling in a stokes regime. - -!$omp threadprivate( sigma_g ) - - ! Statistical rain parameters . - - ! Parameters for in-cloud (from SAM RF02 DO). - real( kind = core_rknd ), public :: & ! RF02 value - rrp2_on_rrm2_cloud, & ! 0.766 - Nrp2_on_Nrm2_cloud, & ! 0.429 - Ncp2_on_Ncm2_cloud ! 0.003 - -!$omp threadprivate( rrp2_on_rrm2_cloud, Nrp2_on_Nrm2_cloud, & -!$omp Ncp2_on_Ncm2_cloud ) - - ! Parameters for below-cloud (from SAM RF02 DO). - real( kind = core_rknd ), public :: & ! RF02 value - rrp2_on_rrm2_below, & ! 8.97 - Nrp2_on_Nrm2_below, & ! 12.03 - Ncp2_on_Ncm2_below ! 0.00 ! Not applicable below cloud. - -!$omp threadprivate( rrp2_on_rrm2_below, Nrp2_on_Nrm2_below, & -!$omp Ncp2_on_Ncm2_below ) - - ! Other needed parameters - real( kind = core_rknd ), public :: C_evap ! 0.86 ! Khairoutdinov and Kogan (2000) ratio of - ! drizzle drop mean geometric radius to - ! drizzle drop mean volume radius. - ! Khairoutdinov and Kogan (2000); p. 233. - !real, public :: C_evap = 0.86*0.2 ! COAMPS value of KK C_evap - !real, public :: C_evap = 0.55 ! KK 2000, Marshall-Palmer (1948) value. - - real( kind = core_rknd ), public :: r_0 ! 25.0e-6 ! Assumed radius of all new drops; m. - ! Value specified in KK (2000); p. 235. - ! Vince Larson set r_0=28mum to agree with COAMPS-LES formula. 15 April 2005 - !REAL, PARAMETER:: r_0 = 28.0e-6 ! Assumed radius of all new drops; m. - ! ! Value that COAMPS LES has in it. - !REAL, PARAMETER:: r_0 = 30.0e-6 ! Assumed radius of all new drops; m. - ! ! Khairoutdinov said it was okay! - ! End Vince Larson's change. - -!$omp threadprivate( C_evap, r_0 ) - - ! Values of exponents in KK microphysics - real( kind = core_rknd ), public :: & - KK_evap_Supersat_exp, & ! Exponent on Supersaturation (S) in KK evap. eq.; 1 - KK_evap_rr_exp, & ! Exponent on r_r in KK evaporation eq.; 1/3 - KK_evap_Nr_exp, & ! Exponent on N_r in KK evaporation eq.; 2/3 - KK_auto_rc_exp, & ! Exponent on r_c in KK autoconversion eq.; 2.47 - KK_auto_Nc_exp, & ! Exponent on N_c in KK autoconversion eq.; -1.79 - KK_accr_rc_exp, & ! Exponent on r_c in KK accretion eq.; 1.15 - KK_accr_rr_exp, & ! Exponent on r_r in KK accretion eq.; 1.15 - KK_mvr_rr_exp, & ! Exponent on r_r in KK mean volume radius eq.; 1/3 - KK_mvr_Nr_exp ! Exponent on N_r in KK mean volume radius eq.; -1/3 - -!$omp threadprivate( KK_evap_Supersat_exp, KK_evap_rr_exp, KK_evap_Nr_exp, & -!$omp KK_auto_rc_exp, KK_auto_Nc_exp, KK_accr_rc_exp, & -!$omp KK_accr_rr_exp, KK_mvr_rr_exp, KK_mvr_Nr_exp ) - - ! Parameters added for ice microphysics and latin hypercube sampling - - real( kind = core_rknd ), public :: & - rsnowp2_on_rsnowm2_cloud, & - Nsnowp2_on_Nsnowm2_cloud, & - ricep2_on_ricem2_cloud, & - Nicep2_on_Nicem2_cloud - -!$omp threadprivate( rsnowp2_on_rsnowm2_cloud, Nsnowp2_on_Nsnowm2_cloud, & -!$omp ricep2_on_ricem2_cloud, Nicep2_on_Nicem2_cloud ) - - real( kind = core_rknd ), public :: & - rsnowp2_on_rsnowm2_below, & - Nsnowp2_on_Nsnowm2_below, & - ricep2_on_ricem2_below, & - Nicep2_on_Nicem2_below - -!$omp threadprivate( rsnowp2_on_rsnowm2_below, Nsnowp2_on_Nsnowm2_below, & -!$omp ricep2_on_ricem2_below, Nicep2_on_Nicem2_below ) - - private ! Default Scope - - -end module crmx_parameters_microphys diff --git a/src/physics/spcam/crm/CLUBB/crmx_parameters_model.F90 b/src/physics/spcam/crm/CLUBB/crmx_parameters_model.F90 deleted file mode 100644 index 4af1f55c36..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_parameters_model.F90 +++ /dev/null @@ -1,160 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: parameters_model.F90 5723 2012-02-15 17:20:44Z meyern@uwm.edu $ -!=============================================================================== -module crmx_parameters_model - -! Description: -! Contains model parameters that are determined at run time rather than -! compile time. -! -! References: -! None -!------------------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd - - implicit none - - private ! Default scope - - ! Maximum allowable value for Lscale [m]. - ! Value depends on whether the model is run by itself or as part of a - ! host model. - real( kind = core_rknd ), public :: Lscale_max - -!$omp threadprivate(Lscale_max) - - ! 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, & ! Reference temperature (usually 300) [K] - ts_nudge ! 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 # -#endif - - -!$omp threadprivate(T0, ts_nudge) - - real( kind = core_rknd), public :: & - rtm_min, & ! Value below which rtm will be nudged [kg/kg] - rtm_nudge_max_altitude ! Highest altitude at which to nudge rtm [m] - - integer, public :: & - sclr_dim, & ! Number of passive scalars - edsclr_dim, & ! Number of eddy-diff. passive scalars - hydromet_dim ! 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 = 4 ), 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, & - Lscale_max_in & - -#ifdef GFDL - , cloud_frac_min_in & ! hlg, 2010-6-15 -#endif - - ) - -! Description: -! Sets parameters to their initial values -! -! References: -! None -!------------------------------------------------------------------------------- - use crmx_constants_clubb, only: Skw_max_mag, Skw_max_mag_sqd - - use crmx_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] - Lscale_max_in ! Largest value for Lscale [m] - -#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 - - Lscale_max = Lscale_max_in - - 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 crmx_parameters_model diff --git a/src/physics/spcam/crm/CLUBB/crmx_parameters_radiation.F90 b/src/physics/spcam/crm/CLUBB/crmx_parameters_radiation.F90 deleted file mode 100644 index 7ade0432e1..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_parameters_radiation.F90 +++ /dev/null @@ -1,78 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: parameters_radiation.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_parameters_radiation - -! Description: -! Parameters for radiation schemes - -! References: -! None -!------------------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - dp, & ! double precision - core_rknd - - implicit none - - character(len=20), public :: & - rad_scheme ! Either BUGSrad, simplified, or simplied_bomex - - real( kind = dp ), dimension(1), public :: & - sol_const ! Solar constant - - real( kind = core_rknd ), public :: & - radiation_top ! The top of the atmosphere fed into a radiation scheme. - ! The computational grid should be extended to reach this - ! altitude. - - ! Albedo values (alvdr is used in the simplifed schemes as well) - real( kind = dp ), public :: & - alvdr, & !Visible direct surface albedo [-] - alndr, & !Near-IR direct surface albedo [-] - alvdf, & !Visible diffuse surface albedo [-] - alndf !Near-IR diffuse surface albedo [-] - - - ! Long-wave constants (simplified radiation) - real( kind = core_rknd ), public :: & - kappa, & ! A constant (Duynkerke eqn. 5) [m^2/kg] - F0, & ! Coefficient for cloud top heating (see Stevens) [W/m^2] - F1 ! Coefficient for cloud base heating (see Stevens)[W/m^2] - - ! Short-wave constants - real( kind = core_rknd ), public :: & - eff_drop_radius, & ! Effective droplet radius [m] - gc, & ! Asymmetry parameter, "g" in Duynkerke [-] - omega ! Single-scattering albedo [-] - - real( kind = dp ), public :: & - slr ! Fraction of daylight - - real( kind = core_rknd ), public, dimension(20) :: & - Fs_values, & ! List of Fs0 values for simplified radiation - cos_solar_zen_times, & ! List of cosine of the solar zenith angle times - cos_solar_zen_values ! List of cosine of the solar zenith angle values - - logical, public :: & - l_fix_cos_solar_zen, l_sw_radiation - - logical, public :: & - l_rad_above_cloud ! Use DYCOMS II RF02 heaviside step function - - integer, public :: & - nparam - - ! Flag to signal the use of the U.S. Standard Atmosphere Profile, 1976 - logical, public :: l_use_default_std_atmosphere - - private ! Default Scope - -! OpenMP directives. The first column of these cannot be indented. -!$omp threadprivate(rad_scheme, sol_const, alvdr, alvdf, alndr, alndf, & -!$omp kappa, F0, F1, eff_drop_radius, gc, omega, radiation_top, Fs_values, & -!$omp l_rad_above_cloud, cos_solar_zen_times, cos_solar_zen_values, & -!$omp l_fix_cos_solar_zen, nparam, & -!$omp l_sw_radiation, l_use_default_std_atmosphere) - -end module crmx_parameters_radiation diff --git a/src/physics/spcam/crm/CLUBB/crmx_parameters_tunable.F90 b/src/physics/spcam/crm/CLUBB/crmx_parameters_tunable.F90 deleted file mode 100644 index 818985e39d..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_parameters_tunable.F90 +++ /dev/null @@ -1,1246 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: parameters_tunable.F90 5997 2012-12-18 20:47:09Z raut@uwm.edu $ -!=============================================================================== -module crmx_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 - !----------------------------------------------------------------------- - - use crmx_parameter_indices, only: nparams ! Variable(s) - - use crmx_grid_class, only: gr ! Variable(s) - - use crmx_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 - - ! Model constant parameters - real( kind = core_rknd ), public :: & - C1 = 2.500000_core_rknd, & ! Low Skewness in C1 Skewness Function. - C1b = 2.500000_core_rknd, & ! High Skewness in C1 Skewness Function. - C1c = 1.000000_core_rknd, & ! Degree of Slope of C1 Skewness Function. - C2 = 1.300000_core_rknd, & ! Low Skewness in C2 Skewness Function. - C2rt = 1.500000_core_rknd, & ! C2 coefficient for the rtp2_dp1 term. - C2thl = 1.000000_core_rknd, & ! C2 coefficient for the thlp2_dp1 term. - C2rtthl = 2.000000_core_rknd, & ! C2 coefficient for the rtpthlp_dp1 term. - C2b = 1.300000_core_rknd, & ! High Skewness in C2 Skewness Function. - C2c = 5.000000_core_rknd, & ! Degree of Slope of C2 Skewness Function. - C4 = 5.200000_core_rknd, & ! Used only when l_tke_aniso is true. - C5 = 0.300000_core_rknd, & ! Coefficient in pressure terms in the w'^2 eqn. - C6rt = 2.300000_core_rknd, & ! Low Skewness in C6rt Skewness Function. - C6rtb = 6.000000_core_rknd, & ! High Skewness in C6rt Skewness Function. - C6rtc = 1.000000_core_rknd, & ! Degree of Slope of C6rt Skewness Function. - C6thl = 4.000000_core_rknd, & ! Low Skewness in C6thl Skewness Function. - C6thlb = 6.000000_core_rknd, & ! High Skewness in C6thl Skewness Function. - C6thlc = 1.000000_core_rknd, & ! Degree of Slope of C6thl Skewness Function. - C7 = 0.320000_core_rknd, & ! Low Skewness in C7 Skewness Function. - C7b = 0.800000_core_rknd, & ! High Skewness in C7 Skewness Function. - C7c = 0.500000_core_rknd, & ! Degree of Slope of C7 Skewness Function. - C8 = 3.000000_core_rknd, & ! Coefficient #1 in C8 Skewness Equation. - C8b = 0.000000_core_rknd, & ! Coefficient #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 Skewness Function. - C11b = 0.350000_core_rknd, & ! High Skewness in C11 Skewness Function. - C11c = 0.500000_core_rknd, & ! Degree of Slope of C11 Skewness Function. - C12 = 1.000000_core_rknd, & ! Constant in w'^3 Crank-Nicholson diffusional term. - 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 - - real( kind = core_rknd ), public :: & - C6rt_Lscale0 = 14.0_core_rknd, & ! Damp C6rt as a function of Lscale - C6thl_Lscale0 = 14.0_core_rknd, & ! Damp C6thl as a function of Lscale - C7_Lscale0 = 0.8500000_core_rknd, & ! Damp C7 as a function of Lscale - wpxp_L_thresh = 60.0_core_rknd ! Lscale threshold for damping C6 and C7 coefficients - - real( kind = core_rknd ), public :: & - c_K = 0.200000_core_rknd, & ! Constant C_mu^(1/4) in Duynkerke & Driedonks 1987. - c_K1 = 0.750000_core_rknd, & ! Coefficient of Eddy Diffusion for wp2. - c_K2 = 0.125000_core_rknd, & ! Coefficient of Eddy Diffusion for xp2. - c_K6 = 0.375000_core_rknd, & ! Coefficient of Eddy Diffusion for wpthlp and wprtp. - c_K8 = 1.250000_core_rknd, & ! Coefficient of Eddy Diffusion for wp3. - c_K9 = 0.250000_core_rknd, & ! Coefficient of Eddy Diffusion for up2 and vp2. - c_Krrainm = 0.200000_core_rknd, & ! Coefficient of Eddy Diffusion for hydrometeors. - gamma_coef = 0.320000_core_rknd, & ! Low Skewness in gamma coefficient Skewness Function. - gamma_coefb = 0.320000_core_rknd, & ! High Skewness in gamma coefficient Skewness Function. - gamma_coefc = 5.000000_core_rknd, & ! Degree of Slope of gamma coefficient Skewness Function. - mu = 1.000E-3_core_rknd, & ! Fractional entrainment rate per unit altitude. - mult_coef = 1.500000_core_rknd, & ! Coefficient applied to log( avg dz / threshold ) - taumin = 90.00000_core_rknd, & ! Minimum allowable value of time-scale tau. - taumax = 3600.000_core_rknd, & ! Maximum allowable value of time-scale tau. - lmin ! Minimum value for the length scale. - - real( kind = core_rknd ), public :: & - Lscale_mu_coef = 2.0_core_rknd, & ! Coefficient to perturb mu for an avg calculation of Lscale - Lscale_pert_coef = 0.1_core_rknd ! Coeff to perturb thlm and rtm for an avg calc of Lscale. - - real( kind = core_rknd ), public :: & - alpha_corr = 0.15_core_rknd ! Coefficient for the correlation diagnosis algoritm - - real( kind = core_rknd ), private :: & - nu1 = 20.00000_core_rknd, & ! Background Coefficient of Eddy Diffusion for wp2. - nu2 = 5.000000_core_rknd, & ! Background Coefficient of Eddy Diffusion for xp2. - nu6 = 5.000000_core_rknd, & ! Background Coefficient of Eddy Diffusion for wpxp. - nu8 = 20.00000_core_rknd, & ! Background Coefficient of Eddy Diffusion for wp3. - nu9 = 20.00000_core_rknd, & ! Background Coefficient of Eddy Diffusion for up2 and vp2. - nu10 = 0.00000_core_rknd,&! Background Coef of Eddy Dfsn for edsclrm, um, vm, upwp, vpwp - nu_r = 1.500000_core_rknd,& ! Background Coefficient of Eddy Diffusion for hydrometeors. - nu_hd = 20000.00_core_rknd ! Constant coefficient for 4th-order hyper-diffusion. - -!$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, & -!$omp c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & -!$omp c_K8, nu8, c_K9, nu9, nu10, c_Krrainm, nu_r, nu_hd, & -!$omp gamma_coef, gamma_coefb, gamma_coefc, mult_coef, & -!$omp taumin, taumax, mu, lmin, Lscale_mu_coef, Lscale_pert_coef) - - real( kind = core_rknd ), public, allocatable, dimension(:) :: & - nu1_vert_res_dep, & ! Background Coefficient of Eddy Diffusion for wp2. - nu2_vert_res_dep, & ! Background Coefficient of Eddy Diffusion for xp2. - nu6_vert_res_dep, & ! Background Coefficient of Eddy Diffusion for wpxp. - nu8_vert_res_dep, & ! Background Coefficient of Eddy Diffusion for wp3. - nu9_vert_res_dep, & ! Background Coefficient of Eddy Diffusion for up2 and vp2. - nu10_vert_res_dep, & ! Background Coef of Eddy Dfsn for edsclrm,um,vm,upwp,vpwp. - nu_r_vert_res_dep ! Background Coefficient of Eddy Diffusion for hydrometeors. - - real( kind = core_rknd ), public :: & - nu_hd_vert_res_dep ! Constant coefficient for 4th-order hyper-diffusion. - -!$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_r_vert_res_dep, & -!$omp nu_hd_vert_res_dep ) - - ! Vince Larson added a constant to set plume widths for theta_l and rt - ! beta should vary between 0 and 3, with 1.5 the standard value - - real( kind = core_rknd ), public :: beta = 1.750000_core_rknd - -!$omp threadprivate(beta) - - real( kind = core_rknd ), private :: lmin_coef = 0.500000_core_rknd ! Coefficient of lmin - -!$omp threadprivate(lmin_coef) - - ! 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 /initvars/ & - 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_Krrainm, nu_r, & - nu_hd, beta, gamma_coef, gamma_coefb, gamma_coefc, lmin_coef, & - mult_coef, taumin, taumax, mu, Lscale_mu_coef, Lscale_pert_coef, & - alpha_corr - - ! 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=16), 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_Krrainm ", "nu_r ", & - "nu_hd ", "gamma_coef ", "gamma_coefb ", "gamma_coefc ", & - "mu ", "beta ", "lmin_coef ", "mult_coef ", & - "taumin ", "taumax ", "Lscale_mu_coef ", "Lscale_pert_coef", & - "alpha_corr " /) - - real( kind = core_rknd ), parameter :: & - 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 crmx_constants_clubb, only: & - fstderr ! Variable(s) - - use crmx_error_code, only: & - clubb_var_out_of_bounds, & ! Variable(s) - clubb_no_error - - use crmx_clubb_precision, only: & - core_rknd ! 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 - - ! Local Variables - real( kind = core_rknd ), parameter :: & - lmin_deltaz = 40.0_core_rknd ! Fixed value for minimum value for the length scale. - - !-------------------- 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_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, mult_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, alpha_corr ) - - - ! 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 - 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 - - else 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 - - else 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 - - else - - err_code = clubb_no_error - - end if ! A parameter is outside the acceptable range - -! write(*,nml=initvars) ! %% 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 crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_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_r_vert_res_dep ) ) then - allocate( nu_r_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_r_vert_res_dep = nu_r * mult_factor_zt - - ! The value of nu_hd is based on an average grid box spacing of - ! 40 m. The value of nu_hd should be adjusted proportionally to - ! the average grid box size, whether the average grid box size is - ! less than 40 m. or greater than 40 m. - ! Since nu_hd should be very large for large grid boxes, but - ! substantially smaller for small grid boxes, the grid spacing - ! adjuster is squared. - - nu_hd_vert_res_dep = nu_hd * ( avg_deltaz / grid_spacing_thresh )**2 - - 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_r_vert_res_dep = nu_r - nu_hd_vert_res_dep = nu_hd - - 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 crmx_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=initvars) - - 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_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, mult_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, alpha_corr, 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 crmx_constants_clubb, only: fstderr ! Constant - - use crmx_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 ! 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 initvars 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_Krrainm, nu_r, & - nu_hd, beta, gamma_coef, gamma_coefb, gamma_coefc, & - lmin_coef, mult_coef, taumin, taumax, mu, Lscale_mu_coef, & - Lscale_pert_coef, alpha_corr - - ! 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_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, mult_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, alpha_corr, 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_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, mult_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, alpha_corr, 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 crmx_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 crmx_parameter_indices, only: & - iC6rt_Lscale0, & - iC6thl_Lscale0, & - iC7_Lscale0, & - iwpxp_L_thresh - - use crmx_parameter_indices, only: & - ic_K, & - ic_K1, & - inu1, & - ic_K2, & - inu2, & - ic_K6, & - inu6, & - ic_K8, & - inu8, & - ic_K9, & - inu9, & - inu10, & - ic_Krrainm, & - inu_r, & - inu_hd, & - igamma_coef, & - igamma_coefb, & - igamma_coefc, & - imu, & - ibeta, & - ilmin_coef, & - imult_coef, & - itaumin, & - itaumax, & - iLscale_mu_coef, & - iLscale_pert_coef, & - ialpha_corr, & - 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_Krrainm, nu_r, nu_hd, gamma_coef, & - gamma_coefb, gamma_coefc, mu, beta, lmin_coef, mult_coef, & - taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, alpha_corr - - ! 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_Krrainm) = c_Krrainm - params(inu_r) = nu_r - params(inu_hd) = nu_hd - - 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(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 - - 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_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, mult_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, alpha_corr ) - - ! 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 crmx_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 crmx_parameter_indices, only: & - iC6rt_Lscale0, & - iC6thl_Lscale0, & - iC7_Lscale0, & - iwpxp_L_thresh - - use crmx_parameter_indices, only: & - ic_K, & - ic_K1, & - inu1, & - ic_K2, & - inu2, & - ic_K6, & - inu6, & - ic_K8, & - inu8, & - ic_K9, & - inu9, & - inu10, & - ic_Krrainm, & - inu_r, & - inu_hd, & - igamma_coef, & - igamma_coefb, & - igamma_coefc, & - imu, & - ibeta, & - ilmin_coef, & - imult_coef, & - itaumin, & - itaumax, & - iLscale_mu_coef, & - iLscale_pert_coef, & - ialpha_corr, & - 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_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, mult_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, alpha_corr - - 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_Krrainm = params(ic_Krrainm) - nu_r = params(inu_r) - nu_hd = params(inu_hd) - - 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) - 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) - - 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_Krrainm, nu_r, & - nu_hd, gamma_coef, gamma_coefb, gamma_coefc, & - mu, beta, lmin_coef, mult_coef, taumin, taumax, Lscale_mu_coef, & - Lscale_pert_coef, alpha_corr, params ) - - return - - end subroutine get_parameters - - !============================================================================= - subroutine init_parameters_999( ) - - ! Description: - ! Set all tunable parameters to NaN - - ! References: - ! None - !----------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - 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_Krrainm = init_value - nu_r = init_value - nu_hd = 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 - mu = init_value - Lscale_mu_coef = init_value - Lscale_pert_coef = init_value - alpha_corr = init_value - nu_hd_vert_res_dep = init_value - - return - end subroutine init_parameters_999 - - !============================================================================= - subroutine cleanup_nu( ) - - ! Description: - ! De-allocates memory used for the nu arrays - ! - ! References: - ! None - !----------------------------------------------------------------------- - - use crmx_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_r_vert_res_dep, stat = ierr ) - - if ( ierr /= 0 ) then - write(fstderr,*) "Nu deallocation failed." - end if - - return - - end subroutine cleanup_nu - -!=============================================================================== - -end module crmx_parameters_tunable diff --git a/src/physics/spcam/crm/CLUBB/crmx_pdf_closure_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_pdf_closure_module.F90 deleted file mode 100644 index 44e2f4f90a..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_pdf_closure_module.F90 +++ /dev/null @@ -1,1208 +0,0 @@ -! $Id: pdf_closure_module.F90 6146 2013-04-05 18:02:22Z raut@uwm.edu $ -module crmx_pdf_closure_module - - implicit none - - public :: pdf_closure - - 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 & - ( p_in_Pa, exner, thv_ds, wm, & - wp2, wp3, sigma_sqd_w, & - Skw, 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 - 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 crmx_constants_clubb, only: & - ! Constants - sqrt_2pi, & ! sqrt(2*pi) - sqrt_2, & ! sqrt(2) - pi, & ! The ratio of radii to their circumference - two, & ! 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] - Rv, & ! Water vapor 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] - s_mellor_tol, & ! Tolerance for pdf parameter s [kg/kg] - T_freeze_K, & ! Freezing point of water [K] - fstderr, & - zero_threshold - - use crmx_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 crmx_parameters_tunable, only: & - beta ! Variable(s) - ! Plume widths for th_l and r_t [-] - - use crmx_pdf_parameter_module, only: & - pdf_parameter ! type - - use crmx_anl_erf, only: & - erf ! Procedure(s) - ! The error function - - use crmx_numerical_check, only: & - pdf_closure_check ! Procedure(s) - - use crmx_saturation, only: & - sat_mixrat_liq, & ! Procedure(s) - sat_mixrat_ice - - use crmx_error_code, only: & - clubb_no_error ! Constant(s) - - use crmx_error_code, only: & - clubb_at_least_debug_level, & ! Procedure(s) - fatal_error - - use crmx_stats_variables, only: & - iwp4, & ! Variables - ircp2, & - iwprtp2, & - iwprtpthlp, & - iwpthlp2 - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - -#ifdef sam1mom - use crmx_micro_params, only: tbgmin, tbgmax -#endif - - implicit none - - intrinsic :: sqrt, exp, min, max, abs, present - - ! Input Variables - 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] - sigma_sqd_w, & ! Width of individual w plumes [-] - Skw, & ! Skewness of w [-] - 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. - - ! 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 ) :: & - w1_n, w2_n -! thl1_n, thl2_n, -! rt1_n, rt2_n - - ! Variables that are stored in derived data type pdf_params. - real( kind = core_rknd ) :: & - w1, & ! Mean of w (1st PDF component) [m/s] - w2, & ! Mean of w (2nd PDF component) [m/s] - varnce_w1, & ! Variance of w (1st PDF component) [m^2/s^2] - varnce_w2, & ! Variance of w (2nd PDF component) [m^2/s^2] - rt1, & ! Mean of r_t (1st PDF component) [kg/kg] - rt2, & ! Mean of r_t (2nd PDF component) [kg/kg] - varnce_rt1, & ! Variance of r_t (1st PDF component) [kg^2/kg^2] - varnce_rt2, & ! Variance of r_t (2nd PDF component) [kg^2/kg^2] - thl1, & ! Mean of th_l (1st PDF component) [K] - thl2, & ! Mean of th_l (2nd PDF component) [K] - varnce_thl1, & ! Variance of th_l (1st PDF component) [K^2] - varnce_thl2, & ! Variance of th_l (2nd PDF component) [K^2] - rrtthl, & ! Correlation between 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 [-] - crt1, & ! Coef. on r_t in s/t eqns. (1st PDF comp.) [-] - crt2, & ! Coef. on r_t in s/t eqns. (2nd PDF comp.) [-] - cthl1, & ! Coef. on th_l in s/t eqns. (1st PDF comp.) [(kg/kg)/K] - cthl2 ! Coef. on th_l in s/t eqns. (2nd PDF comp.) [(kg/kg)/K] - - real( kind = core_rknd ) :: & - s1, & ! Mean of s (1st PDF component) [kg/kg] - s2, & ! Mean of s (2nd PDF component) [kg/kg] - stdev_s1, & ! Standard deviation of s (1st PDF component) [kg/kg] - stdev_s2, & ! Standard deviation of s (2nd PDF component) [kg/kg] - stdev_t1, & ! Standard deviation of t (1st PDF component) [kg/kg] - stdev_t2, & ! Standard deviation of t (2nd PDF component) [kg/kg] - covar_st_1, & ! Covariance of s and t (1st PDF component) [kg^2/kg^2] - covar_st_2, & ! Covariance of s and t (2nd PDF component) [kg^2/kg^2] - corr_st_1, & ! Correlation between s and t (1st PDF component) [-] - corr_st_2, & ! Correlation between s and t (2nd PDF component) [-] - rsl1, & ! Mean of r_sl (1st PDF component) [kg/kg] - rsl2, & ! Mean of r_sl (2nd PDF component) [kg/kg] - rc1, & ! Mean of r_c (1st PDF component) [kg/kg] - rc2, & ! Mean of r_c (2nd PDF component) [kg/kg] - cloud_frac1, & ! Cloud fraction (1st PDF component) [-] - cloud_frac2, & ! Cloud fraction (2nd PDF component) [-] - mixt_frac ! Weight of 1st PDF component (Sk_w dependent) [-] - - ! Note: alpha coefficients = 0.5 * ( 1 - correlations^2 ). - ! These are used to calculate the scalar widths - ! varnce_thl1, varnce_thl2, varnce_rt1, and varnce_rt2 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 - - ! 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 computing ice cloud fraction - real( kind = core_rknd) :: & - ice_supersat_frac1, & ! first pdf component of ice_supersat_frac - ice_supersat_frac2, & ! second pdf component of ice_supersat_frac - rt_at_ice_sat1, rt_at_ice_sat2, & - s_at_ice_sat1, s_at_ice_sat2 - - - real( kind = core_rknd ), parameter :: & - s_at_liq_sat = 0.0_core_rknd ! Always zero - - integer :: i ! Index - -#ifdef GFDL - real ( kind = core_rknd ), parameter :: t1_combined = 273.16, & - t2_combined = 268.16, & - t3_combined = 238.16 -#endif -#ifdef sam1mom - real ( kind = core_rknd ), parameter :: t1_combined = tbgmax, & - t2_combined = tbgmin -#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 velocity, then use single delta fnc. as pdf - ! Otherwise width parameters (e.g. varnce_w1, varnce_w2, etc.) are non-zero. - if ( wp2 <= w_tol_sqd ) then - - mixt_frac = 0.5_core_rknd - w1 = wm - w2 = wm - varnce_w1 = 0._core_rknd - varnce_w2 = 0._core_rknd - rt1 = rtm - rt2 = rtm - alpha_rt = 0.5_core_rknd - varnce_rt1 = 0._core_rknd - varnce_rt2 = 0._core_rknd - thl1 = thlm - thl2 = thlm - alpha_thl = 0.5_core_rknd - varnce_thl1 = 0._core_rknd - varnce_thl2 = 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) = 0.5_core_rknd - 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 - - ! The variable "mixt_frac" is the weight of Gaussian "plume" 1. The weight of - ! Gaussian "plume" 2 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 Gaussian "plumes" are - ! equally weighted. If there is positive skewness of w (Sk_w > 0 because - ! w'^3 > 0), 0 < mixt_frac < 0.5, and Gaussian "plume" 2 has greater weight than - ! does Gaussian "plume" 1. If there is negative skewness of w (Sk_w < 0 - ! because w'^3 < 0), 0.5 < mixt_frac < 1, and Gaussian "plume" 1 has greater - ! weight than does Gaussian "plume" 2. - if ( abs( Skw ) <= 1e-5_core_rknd ) then - mixt_frac = 0.5_core_rknd - else - mixt_frac = 0.5_core_rknd * ( 1.0_core_rknd - Skw/ & - sqrt( 4.0_core_rknd*( 1.0_core_rknd - sigma_sqd_w )**3 + Skw**2 ) ) - endif - - ! Determine sqrt( wp2 ) here to avoid re-computing it - sqrt_wp2 = sqrt( wp2 ) - - ! 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_core_rknd - mixt_frac = min( max( mixt_frac, 1.0_core_rknd-mixt_frac_max_mag ), mixt_frac_max_mag ) - - ! The normalized mean of w for Gaussian "plume" 1 is w1_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. - w1_n = sqrt( ( (1._core_rknd-mixt_frac)/mixt_frac )*(1._core_rknd-sigma_sqd_w) ) - ! The normalized mean of w for Gaussian "plume" 2 is w2_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. - w2_n = -sqrt( ( mixt_frac/(1._core_rknd-mixt_frac) )*(1._core_rknd-sigma_sqd_w) ) - ! The mean of w for Gaussian "plume" 1 is w1. - w1 = wm + sqrt_wp2*w1_n - ! The mean of w for Gaussian "plume" 2 is w2. - w2 = wm + sqrt_wp2*w2_n - - ! The variance of w for Gaussian "plume" 1 for varnce_w1. - varnce_w1 = sigma_sqd_w*wp2 - ! The variance of w for Gaussian "plume" 2 for varnce_w2. - ! The variance in both Gaussian "plumes" is defined to be the same. - varnce_w2 = sigma_sqd_w*wp2 - - - ! 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 0.5_core_rknd 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 0._core_rknd .and. & - varnce_rt2*varnce_thl2 > 0._core_rknd ) then - rrtthl = ( rtpthlp - mixt_frac * ( rt1-rtm ) * ( thl1-thlm ) & - - (1._core_rknd-mixt_frac) * ( rt2-rtm ) * ( thl2-thlm ) ) & - / ( mixt_frac*sqrt( varnce_rt1*varnce_thl1 ) & - + (1._core_rknd-mixt_frac)*sqrt( varnce_rt2*varnce_thl2 ) ) - if ( rrtthl < -1.0_core_rknd ) then - rrtthl = -1.0_core_rknd - end if - if ( rrtthl > 1.0_core_rknd ) then - rrtthl = 1.0_core_rknd - end if - else - rrtthl = 0.0_core_rknd - end if ! varnce_rt1*varnce_thl1 > 0 .and. varnce_rt2*varnce_thl2 > 0 - - ! Sub-plume correlation, rsclrthl, between passive scalar and theta_l. - if ( l_scalar_calc ) then - do i=1, sclr_dim - if ( varnce_sclr1(i)*varnce_thl1 > 0._core_rknd .and. & - varnce_sclr2(i)*varnce_thl2 > 0._core_rknd ) then - rsclrthl(i) = ( sclrpthlp(i) & - - mixt_frac * ( sclr1(i)-sclrm(i) ) * ( thl1-thlm ) & - - (1._core_rknd-mixt_frac) * ( sclr2(i)-sclrm(i) ) * ( thl2-thlm ) ) & - / ( mixt_frac*sqrt( varnce_sclr1(i)*varnce_thl1 ) & - + (1._core_rknd-mixt_frac)*sqrt( varnce_sclr2(i)*varnce_thl2 ) ) - if ( rsclrthl(i) < -1.0_core_rknd ) then - rsclrthl(i) = -1.0_core_rknd - end if - if ( rsclrthl(i) > 1.0_core_rknd ) then - rsclrthl(i) = 1.0_core_rknd - end if - else - rsclrthl(i) = 0.0_core_rknd - end if - - ! Sub-plume correlation, rsclrrt, between passive scalar - ! and total water. - - if ( varnce_sclr1(i)*varnce_rt1 > 0._core_rknd .and. & - varnce_sclr2(i)*varnce_rt2 > 0._core_rknd ) then - rsclrrt(i) = ( sclrprtp(i) - mixt_frac * ( sclr1(i)-sclrm(i) ) * ( rt1-rtm )& - - (1._core_rknd-mixt_frac) * ( sclr2(i)-sclrm(i) ) * ( rt2-rtm ) ) & - / ( mixt_frac*sqrt( varnce_sclr1(i)*varnce_rt1 ) & - + (1._core_rknd-mixt_frac)*sqrt( varnce_sclr2(i)*varnce_rt2 ) ) - if ( rsclrrt(i) < -1.0_core_rknd ) then - rsclrrt(i) = -1.0_core_rknd - end if - if ( rsclrrt(i) > 1.0_core_rknd ) then - rsclrrt(i) = 1.0_core_rknd - 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 * ( (w1-wm)**2+varnce_w1 ) * ( rt1-rtm ) & - + (1._core_rknd-mixt_frac) * ( (w2-wm)**2+varnce_w2 ) * ( rt2-rtm ) - - wp2thlp = mixt_frac * ( (w1-wm)**2+varnce_w1 ) * ( thl1-thlm ) & - + (1._core_rknd-mixt_frac) * ( (w2-wm)**2+varnce_w2 ) * ( thl2-thlm ) - - ! Compute higher order moments (these are non-interactive diagnostics) - if ( iwp4 > 0 ) then - wp4 = mixt_frac * ( 3._core_rknd*varnce_w1**2 + & - 6._core_rknd*((w1-wm)**2)*varnce_w1 + (w1-wm)**4 ) & - + (1._core_rknd-mixt_frac) * ( 3._core_rknd*varnce_w2**2 + & - 6._core_rknd*((w2-wm)**2)*varnce_w2 + (w2-wm)**4 ) - end if - - if ( iwprtp2 > 0 ) then - wprtp2 = mixt_frac * ( w1-wm )*( (rt1-rtm)**2 + varnce_rt1 ) & - + (1._core_rknd-mixt_frac) * ( w2-wm )*( (rt2-rtm)**2 + varnce_rt2) - end if - - if ( iwpthlp2 > 0 ) then - wpthlp2 = mixt_frac * ( w1-wm )*( (thl1-thlm)**2 + varnce_thl1 ) & - + (1._core_rknd-mixt_frac) * ( w2-wm )*( (thl2-thlm)**2+varnce_thl2 ) - end if - - if ( iwprtpthlp > 0 ) then - wprtpthlp = mixt_frac * ( w1-wm )*( (rt1-rtm)*(thl1-thlm) & - + rrtthl*sqrt( varnce_rt1*varnce_thl1 ) ) & - + ( 1._core_rknd-mixt_frac ) * ( w2-wm )*( (rt2-rtm)*(thl2-thlm) & - + rrtthl*sqrt( varnce_rt2*varnce_thl2 ) ) - end if - - - ! Scalar Addition to higher order moments - if ( l_scalar_calc ) then - do i=1, sclr_dim - - wp2sclrp(i) = mixt_frac * ( (w1-wm)**2+varnce_w1 )*( sclr1(i)-sclrm(i) ) & - + (1._core_rknd-mixt_frac) * ( (w2-wm)**2+varnce_w2 ) * ( sclr2(i)-sclrm(i) ) - - wpsclrp2(i) = mixt_frac * ( w1-wm ) * ( (sclr1(i)-sclrm(i))**2 + varnce_sclr1(i) ) & - + (1._core_rknd-mixt_frac) * ( w2-wm ) * & - ( (sclr2(i)-sclrm(i))**2 + varnce_sclr2(i) ) - - wpsclrprtp(i) = mixt_frac * ( w1-wm ) * ( ( rt1-rtm )*( sclr1(i)-sclrm(i) ) & - + rsclrrt(i)*sqrt( varnce_rt1*varnce_sclr1(i) ) ) & - + ( 1._core_rknd-mixt_frac )*( w2-wm ) * & - ( ( rt2-rtm )*( sclr2(i)-sclrm(i) ) + rsclrrt(i)*sqrt( varnce_rt2*varnce_sclr2(i) ) ) - - wpsclrpthlp(i) = mixt_frac * ( w1-wm ) * ( ( sclr1(i)-sclrm(i) )*( thl1-thlm ) & - + rsclrthl(i)*sqrt( varnce_sclr1(i)*varnce_thl1 ) ) & - + ( 1._core_rknd-mixt_frac ) * ( w2-wm ) * & - ( ( sclr2(i)-sclrm(i) )*( thl2-thlm ) & - + rsclrthl(i)*sqrt( varnce_sclr2(i)*varnce_thl2 ) ) - - 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 = thl1*exner - tl2 = thl2*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 - rsl1 = sat_mixrat_liq( p_in_Pa, tl1 ) - elseif( tl1 > t2_combined ) then - rsl1 = 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 - rsl1 = sat_mixrat_ice( p_in_Pa, tl1 ) & - + sat_mixrat_ice( p_in_Pa, tl1 ) * (RH_crit(1, 1) -1._core_rknd ) & - * ( t2_combined -tl1)/(t2_combined - t3_combined) - else - rsl1 = sat_mixrat_ice( p_in_Pa, tl1 ) * RH_crit(1, 1) - endif - - if( tl2 > t1_combined ) then - rsl2 = sat_mixrat_liq( p_in_Pa, tl2 ) - elseif( tl2 > t2_combined ) then - rsl2 = 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 - rsl2 = sat_mixrat_ice( p_in_Pa, tl2 ) & - + sat_mixrat_ice( p_in_Pa, tl2 )* (RH_crit(1, 2) -1._core_rknd) & - * ( t2_combined -tl2)/(t2_combined - t3_combined) - else - rsl2 = sat_mixrat_ice( p_in_Pa, tl2 ) * RH_crit(1, 2) - endif - - else !sclr_dim <= 0 or do_liquid_only_in_clubb = .T. - rsl1 = sat_mixrat_liq( p_in_Pa, tl1 ) - rsl2 = sat_mixrat_liq( p_in_Pa, tl2 ) - - endif !sclr_dim > 0 - -#elif sam1mom -! For sinlge moment microphysics in SAM_CLUBB - if(tl1 > t1_combined) then - rsl1 = sat_mixrat_liq( p_in_Pa, tl1 ) - else if (tl1 < t2_combined) then - rsl1 = sat_mixrat_ice( p_in_Pa, tl1 ) - else - rsl1 = 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) - endif - if(tl2 > t1_combined) then - rsl2 = sat_mixrat_liq( p_in_Pa, tl2 ) - else if (tl2 < t2_combined) then - rsl2 = sat_mixrat_ice( p_in_Pa, tl2 ) - else - rsl2 = 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) - endif -#else - rsl1 = sat_mixrat_liq( p_in_Pa, tl1 ) - rsl2 = 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 - s1 = ( rt1 - rsl1 ) / ( 1._core_rknd + beta1 * rsl1 ) - s2 = ( rt2 - rsl2 ) / ( 1._core_rknd + beta2 * rsl2 ) - - ! 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. - - crt1 = 1._core_rknd/( 1._core_rknd + beta1*rsl1) - crt2 = 1._core_rknd/( 1._core_rknd + beta2*rsl2) - - cthl1 = ( (1._core_rknd + beta1 * rt1) / ( 1._core_rknd + beta1*rsl1)**2 ) & - * ( Cp/Lv ) * beta1 * rsl1 * exner - cthl2 = ( (1._core_rknd + beta2 * rt2) / ( 1._core_rknd + beta2*rsl2 )**2 ) & - * ( Cp/Lv ) * beta2 * rsl2 * exner - - ! Standard deviation of s for each component. - ! Include subplume correlation of qt, thl - ! Because of round-off error, - ! stdev_s1 (and probably stdev_s2) 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_s1 = sqrt( max( crt1**2 * varnce_rt1 & - - two * rrtthl * crt1 * cthl1 & - * sqrt( varnce_rt1 * varnce_thl1 ) & - + cthl1**2 * varnce_thl1, & - zero_threshold ) ) - - stdev_s2 = sqrt( max( crt2**2 * varnce_rt2 & - - two * rrtthl * crt2 * cthl2 & - * sqrt( varnce_rt2 * varnce_thl2 ) & - + cthl2**2 * varnce_thl2, & - zero_threshold ) ) - - ! Standard deviation of t for each component. - stdev_t1 = sqrt( max( crt1**2 * varnce_rt1 & - + two * rrtthl * crt1 * cthl1 & - * sqrt( varnce_rt1 * varnce_thl1 ) & - + cthl1**2 * varnce_thl1, & - zero_threshold ) ) - - stdev_t2 = sqrt( max( crt2**2 * varnce_rt2 & - + two * rrtthl * crt2 * cthl2 & - * sqrt( varnce_rt2 * varnce_thl2 ) & - + cthl2**2 * varnce_thl2, & - zero_threshold ) ) - - ! Covariance of s and t for each component. - covar_st_1 = crt1**2 * varnce_rt1 - cthl1**2 * varnce_thl1 - - covar_st_2 = crt2**2 * varnce_rt2 - cthl2**2 * varnce_thl2 - - ! Correlation between s and t for each component. - if ( stdev_s1 * stdev_t1 > zero ) then - corr_st_1 = covar_st_1 / ( stdev_s1 * stdev_t1 ) - else - corr_st_1 = zero - endif - - if ( stdev_s2 * stdev_t2 > zero ) then - corr_st_2 = covar_st_2 / ( stdev_s2 * stdev_t2 ) - else - corr_st_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 -#elif sam1mom - l_calc_ice_supersat_frac = .false. -#else - l_calc_ice_supersat_frac = .true. -#endif - - ! We need to introduce a threshold value for the variance of s - - ! Calculate cloud_frac1 and rc1 - call calc_cloud_frac_component(s1, stdev_s1, s_at_liq_sat, cloud_frac1, rc1) - - ! Calculate cloud_frac2 and rc2 - call calc_cloud_frac_component(s2, stdev_s2, s_at_liq_sat, cloud_frac2, rc2) - - if (l_calc_ice_supersat_frac) then - ! We must compute s_at_ice_sat1 and s_at_ice_sat2 - if (tl1 <= T_freeze_K) then - rt_at_ice_sat1 = sat_mixrat_ice( p_in_Pa, tl1 ) - s_at_ice_sat1 = ( rt_at_ice_sat1 - rsl1 ) / ( 1._core_rknd + beta1 * rsl1 ) - else - ! If the temperature is warmer than freezing (> 0C) then ice_supersat_frac - ! is not defined, so we use s_at_liq_sat - s_at_ice_sat1 = s_at_liq_sat - end if - - if (tl2 <= T_freeze_K) then - rt_at_ice_sat2 = sat_mixrat_ice( p_in_Pa, tl2 ) - s_at_ice_sat2 = ( rt_at_ice_sat2 - rsl2 ) / ( 1._core_rknd + beta2 * rsl2 ) - else - ! If the temperature is warmer than freezing (> 0C) then ice_supersat_frac - ! is not defined, so we use s_at_liq_sat - s_at_ice_sat2 = s_at_liq_sat - end if - - ! Calculate ice_supersat_frac1 - call calc_cloud_frac_component(s1, stdev_s1, s_at_ice_sat1, ice_supersat_frac1) - - ! Calculate ice_supersat_frac2 - call calc_cloud_frac_component(s2, stdev_s2, s_at_ice_sat2, ice_supersat_frac2) - 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 - - wp2rcp = mixt_frac * ((w1-wm)**2 + varnce_w1)*rc1 & - + (1._core_rknd-mixt_frac) * ((w2-wm)**2 + varnce_w2)*rc2 & - - wp2 * (mixt_frac*rc1+(1._core_rknd-mixt_frac)*rc2) - - wp2thvp = wp2thlp + ep1*thv_ds*wp2rtp + rc_coef*wp2rcp - - wprcp = mixt_frac * (w1-wm)*rc1 + (1._core_rknd-mixt_frac) * (w2-wm)*rc2 - - wpthvp = wpthlp + ep1*thv_ds*wprtp + rc_coef*wprcp - - ! Account for subplume correlation in qt-thl - thlprcp = mixt_frac * ( (thl1-thlm)*rc1 - (cthl1*varnce_thl1)*cloud_frac1 ) & - + (1._core_rknd-mixt_frac) * ( (thl2-thlm)*rc2 - (cthl2*varnce_thl2)*cloud_frac2 ) & - + mixt_frac*rrtthl*crt1*sqrt( varnce_rt1*varnce_thl1 )*cloud_frac1 & - + (1._core_rknd-mixt_frac)*rrtthl*crt2*sqrt( varnce_rt2*varnce_thl2 )*cloud_frac2 - thlpthvp = thlp2 + ep1*thv_ds*rtpthlp + rc_coef*thlprcp - - ! Account for subplume correlation in qt-thl - rtprcp = mixt_frac * ( (rt1-rtm)*rc1 + (crt1*varnce_rt1)*cloud_frac1 ) & - + (1._core_rknd-mixt_frac) * ( (rt2-rtm)*rc2 + (crt2*varnce_rt2)*cloud_frac2 ) & - - mixt_frac*rrtthl*cthl1*sqrt( varnce_rt1*varnce_thl1 )*cloud_frac1 & - - (1._core_rknd-mixt_frac)*rrtthl*cthl2*sqrt( varnce_rt2*varnce_thl2 )*cloud_frac2 - - rtpthvp = rtpthlp + ep1*thv_ds*rtp2 + rc_coef*rtprcp - - ! Account for subplume correlation between 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) ) * rc1 ) & - + (1._core_rknd-mixt_frac) * ( ( sclr2(i)-sclrm(i) ) * rc2 ) & - + mixt_frac*rsclrrt(i) * crt1 & - * sqrt( varnce_sclr1(i) * varnce_rt1 ) * cloud_frac1 & - + (1._core_rknd-mixt_frac) * rsclrrt(i) * crt2 & - * sqrt( varnce_sclr2(i) * varnce_rt2 ) * cloud_frac2 & - - mixt_frac * rsclrthl(i) * cthl1 & - * sqrt( varnce_sclr1(i) * varnce_thl1 ) * cloud_frac1 & - - (1._core_rknd-mixt_frac) * rsclrthl(i) * cthl2 & - * sqrt( varnce_sclr2(i) * varnce_thl2 ) * cloud_frac2 - - 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_frac1, cloud_frac2, mixt_frac) - rcm = mixt_frac * rc1 + (1._core_rknd-mixt_frac) * rc2 - - 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_frac1, ice_supersat_frac2, 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_SAM ! in SAM, rcp2 is needed for Morrison microphysics - if ( ircp2 > 0 ) then -#endif - - rcp2 = mixt_frac * ( s1*rc1 + cloud_frac1*stdev_s1**2 ) & - + ( 1._core_rknd-mixt_frac ) * ( s2*rc2 + cloud_frac2*stdev_s2**2 ) - rcm**2 - rcp2 = max( zero_threshold, rcp2 ) - -#ifndef CLUBB_SAM ! in SAM, rcp2 is needed for Morrison microphysics - end if -#endif - - - ! Save PDF parameters - pdf_params%w1 = w1 - pdf_params%w2 = w2 - pdf_params%varnce_w1 = varnce_w1 - pdf_params%varnce_w2 = varnce_w2 - pdf_params%rt1 = rt1 - pdf_params%rt2 = rt2 - pdf_params%varnce_rt1 = varnce_rt1 - pdf_params%varnce_rt2 = varnce_rt2 - pdf_params%thl1 = thl1 - pdf_params%thl2 = thl2 - pdf_params%varnce_thl1 = varnce_thl1 - pdf_params%varnce_thl2 = varnce_thl2 - pdf_params%rrtthl = rrtthl - pdf_params%alpha_thl = alpha_thl - pdf_params%alpha_rt = alpha_rt - pdf_params%crt1 = crt1 - pdf_params%crt2 = crt2 - pdf_params%cthl1 = cthl1 - pdf_params%cthl2 = cthl2 - pdf_params%s1 = s1 - pdf_params%s2 = s2 - pdf_params%stdev_s1 = stdev_s1 - pdf_params%stdev_s2 = stdev_s2 - pdf_params%stdev_t1 = stdev_t1 - pdf_params%stdev_t2 = stdev_t2 - pdf_params%covar_st_1 = covar_st_1 - pdf_params%covar_st_2 = covar_st_2 - pdf_params%corr_st_1 = corr_st_1 - pdf_params%corr_st_2 = corr_st_2 - pdf_params%rsl1 = rsl1 - pdf_params%rsl2 = rsl2 - pdf_params%rc1 = rc1 - pdf_params%rc2 = rc2 - pdf_params%cloud_frac1 = cloud_frac1 - pdf_params%cloud_frac2 = cloud_frac2 - pdf_params%mixt_frac = mixt_frac - - - 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, & - crt1, crt2, cthl1, cthl2, pdf_params, & - err_code, & - sclrpthvp, sclrprcp, wpsclrp2, & - wpsclrprtp, wpsclrpthlp, wp2sclrp ) - - ! 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%w1 = ", pdf_params%w1 - write(fstderr,*) "pdf_params%w2 = ", pdf_params%w2 - write(fstderr,*) "pdf_params%varnce_w1 = ", pdf_params%varnce_w1 - write(fstderr,*) "pdf_params%varnce_w2 = ", pdf_params%varnce_w2 - write(fstderr,*) "pdf_params%rt1 = ", pdf_params%rt1 - write(fstderr,*) "pdf_params%rt2 = ", pdf_params%rt2 - write(fstderr,*) "pdf_params%varnce_rt1 = ", pdf_params%varnce_rt1 - write(fstderr,*) "pdf_params%varnce_rt2 = ", pdf_params%varnce_rt2 - write(fstderr,*) "pdf_params%thl1 = ", pdf_params%thl1 - write(fstderr,*) "pdf_params%thl2 = ", pdf_params%thl2 - write(fstderr,*) "pdf_params%varnce_thl1 = ", pdf_params%varnce_thl1 - write(fstderr,*) "pdf_params%varnce_thl2 = ", pdf_params%varnce_thl2 - 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%crt1 = ", pdf_params%crt1 - write(fstderr,*) "pdf_params%crt2 = ", pdf_params%crt2 - write(fstderr,*) "pdf_params%cthl1 = ", pdf_params%cthl1 - write(fstderr,*) "pdf_params%cthl2 = ", pdf_params%cthl2 - write(fstderr,*) "pdf_params%s1 = ", pdf_params%s1 - write(fstderr,*) "pdf_params%s2 = ", pdf_params%s2 - write(fstderr,*) "pdf_params%stdev_s1 = ", pdf_params%stdev_s1 - write(fstderr,*) "pdf_params%stdev_s2 = ", pdf_params%stdev_s2 - write(fstderr,*) "pdf_params%stdev_t1 = ", pdf_params%stdev_t1 - write(fstderr,*) "pdf_params%stdev_t2 = ", pdf_params%stdev_t2 - write(fstderr,*) "pdf_params%covar_st_1 = ", pdf_params%covar_st_1 - write(fstderr,*) "pdf_params%covar_st_2 = ", pdf_params%covar_st_2 - write(fstderr,*) "pdf_params%corr_st_1 = ", pdf_params%corr_st_1 - write(fstderr,*) "pdf_params%corr_st_2 = ", pdf_params%corr_st_2 - write(fstderr,*) "pdf_params%rsl1 = ", pdf_params%rsl1 - write(fstderr,*) "pdf_params%rsl2 = ", pdf_params%rsl2 - write(fstderr,*) "pdf_params%rc1 = ", pdf_params%rc1 - write(fstderr,*) "pdf_params%rc2 = ", pdf_params%rc2 - write(fstderr,*) "pdf_params%cloud_frac1 = ", pdf_params%cloud_frac1 - write(fstderr,*) "pdf_params%cloud_frac2 = ", pdf_params%cloud_frac2 - write(fstderr,*) "pdf_params%mixt_frac = ", pdf_params%mixt_frac - - 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 - - end if ! clubb_at_least_debug_level - - return - end subroutine pdf_closure - - !----------------------------------------------------------------------- - subroutine calc_cloud_frac_component(s, stdev_s, s_at_sat, cloud_fracN, rcN) - ! Description: - ! Given the mean and standard deviation of 's', this subroutine - ! calculates cloud_frac, where n is the PDF component (either 1 or - ! 2). In addition, the subroutine can also optionally calculate rc, - ! the mean of r_c - ! - ! References: - ! See ticket#529 - !----------------------------------------------------------------------- - - use crmx_constants_clubb, only: & - s_mellor_tol,&! Tolerance for pdf parameter s [kg/kg] - sqrt_2pi, &! sqrt(2*pi) - sqrt_2 ! sqrt(2) - - use crmx_clubb_precision, only: & - core_rknd ! Precision - - use crmx_anl_erf, only: & - erf ! Procedure(s) - ! The error function - - implicit none - - ! Input Variables - real( kind = core_rknd ), intent(in) :: & - s, & ! Mean of 's' component - stdev_s, & ! Standard deviation of s - s_at_sat ! Value of 's' at exact saturation with respect to ice - ! Negative (or zero for liquid) - - ! Output Variables - real( kind = core_rknd ), intent(out) :: & - cloud_fracN ! Component of cloud_frac - - ! Output Variable - ! Note: this parameter can be optionally computed. - real( kind = core_rknd), intent(out), optional :: & - rcN ! Mean of r_c - - ! Local Variables - real( kind = core_rknd) :: zetaN - - !----------------------------------------------------------------------- - !----- Begin Code ----- - if ( stdev_s > s_mellor_tol ) then - zetaN = (s - s_at_sat) / stdev_s - cloud_fracN = 0.5_core_rknd*( 1._core_rknd + erf( zetaN/sqrt_2 ) ) - if (present(rcN)) & - rcN = s*cloud_fracN + stdev_s*exp( -0.5_core_rknd*zetaN**2 )/( sqrt_2pi ) - else - if ( s < 0.0_core_rknd ) then - cloud_fracN = 0.0_core_rknd - if (present(rcN)) & - rcN = 0.0_core_rknd - else - cloud_fracN = 1.0_core_rknd - if (present(rcN)) & - rcN = s - end if ! s < 0 - end if ! stdev_s > s_mellor_tol - - - end subroutine calc_cloud_frac_component - !----------------------------------------------------------------------- - - !----------------------------------------------------------------------- - function calc_cloud_frac(cloud_frac1, cloud_frac2, 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: - ! See ticket#530 - !----------------------------------------------------------------------- - - use crmx_constants_clubb, only: & - fstderr, &! Standard error output - zero_threshold ! A physical quantity equal to zero - - use crmx_clubb_precision, only: & - core_rknd ! Precision - - use crmx_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_frac1, & ! First PDF component of cloud_frac - cloud_frac2, & ! 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_frac1 + (1.0_core_rknd-mixt_frac) * cloud_frac2 - - ! 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 > 1.0_core_rknd ) then - write(fstderr,*) "Cloud fraction > 1" - end if - end if - cloud_frac = min( 1.0_core_rknd, cloud_frac ) - - calc_cloud_frac = cloud_frac - return - - end function calc_cloud_frac - !----------------------------------------------------------------------- - -end module crmx_pdf_closure_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_pdf_parameter_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_pdf_parameter_module.F90 deleted file mode 100644 index bc62a8bdd5..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_pdf_parameter_module.F90 +++ /dev/null @@ -1,58 +0,0 @@ -! $Id: pdf_parameter_module.F90 5668 2012-01-29 03:40:28Z bmg2@uwm.edu $ -module crmx_pdf_parameter_module -! Description: -! This module defines the derived type pdf_parameter. -! References: -! None -!------------------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd - - implicit none - - private ! Default scope - - public :: pdf_parameter - - type pdf_parameter - real( kind = core_rknd ) :: & - w1, & ! Mean of w (1st PDF component) [m/s] - w2, & ! Mean of w (2nd PDF component) [m/s] - varnce_w1, & ! Variance of w (1st PDF component) [m^2/s^2] - varnce_w2, & ! Variance of w (2nd PDF component) [m^2/s^2] - rt1, & ! Mean of r_t (1st PDF component) [kg/kg] - rt2, & ! Mean of r_t (2nd PDF component) [kg/kg] - varnce_rt1, & ! Variance of r_t (1st PDF component) [kg^2/kg^2] - varnce_rt2, & ! Variance of r_t (2nd PDF component) [kg^2/kg^2] - thl1, & ! Mean of th_l (1st PDF component) [K] - thl2, & ! Mean of th_l (2nd PDF component) [K] - varnce_thl1, & ! Variance of th_l (1st PDF component) [K^2] - varnce_thl2, & ! Variance of th_l (2nd PDF component) [K^2] - rrtthl, & ! Correlation between 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 [-] - crt1, & ! Coef. on r_t in s/t eqns. (1st PDF comp.) [-] - crt2, & ! Coef. on r_t in s/t eqns. (2nd PDF comp.) [-] - cthl1, & ! Coef. on th_l in s/t eqns. (1st PDF comp.) [(kg/kg)/K] - cthl2, & ! Coef. on th_l in s/t eqns. (2nd PDF comp.) [(kg/kg)/K] - s1, & ! Mean of s (1st PDF component) [kg/kg] - s2, & ! Mean of s (2nd PDF component) [kg/kg] - stdev_s1, & ! Standard deviation of s (1st PDF component) [kg/kg] - stdev_s2, & ! Standard deviation of s (2nd PDF component) [kg/kg] - stdev_t1, & ! Standard deviation of t (1st PDF component) [kg/kg] - stdev_t2, & ! Standard deviation of t (2nd PDF component) [kg/kg] - covar_st_1, & ! Covariance of s and t (1st PDF component) [kg^2/kg^2] - covar_st_2, & ! Covariance of s and t (2nd PDF component) [kg^2/kg^2] - corr_st_1, & ! Correlation between s and t (1st PDF component) [-] - corr_st_2, & ! Correlation between s and t (2nd PDF component) [-] - rsl1, & ! Mean of r_sl (1st PDF component) [kg/kg] - rsl2, & ! Mean of r_sl (2nd PDF component) [kg/kg] - rc1, & ! Mean of r_c (1st PDF component) [kg/kg] - rc2, & ! Mean of r_c (2nd PDF component) [kg/kg] - cloud_frac1, & ! Cloud fraction (1st PDF component) [-] - cloud_frac2, & ! Cloud fraction (2nd PDF component) [-] - mixt_frac ! Weight of 1st PDF component (Sk_w dependent) [-] - end type pdf_parameter - -end module crmx_pdf_parameter_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_pos_definite_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_pos_definite_module.F90 deleted file mode 100644 index 65471a4345..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_pos_definite_module.F90 +++ /dev/null @@ -1,220 +0,0 @@ -!$Id: pos_definite_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_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 crmx_grid_class, only: & - gr, & ! Variable(s) - ddzt, & ! Function - ddzm ! Function - - use crmx_constants_clubb, only : & - eps, & ! Variable(s) - zero_threshold - - use crmx_clubb_precision, only: & - time_precision, & ! Variable(s) - core_rknd - - use crmx_error_code, only: & - clubb_at_least_debug_level - - implicit none - - ! External - intrinsic :: eoshift, kind, any, min, max - - ! Input variables - real(kind=time_precision), 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) ) / real( dt, kind = core_rknd ) - - else if ( field_grid == "zt" ) then - dz_over_dt(k) = ( 1._core_rknd/gr%invrs_dzt(k) ) / real( dt, kind = core_rknd ) - - 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 ) / real( dt, kind = core_rknd ) - - field_nonlim = field_np1 - - ! Apply change to field at n+1 - if ( field_grid == "zt" ) then - - field_np1 = -real( dt, kind = core_rknd ) * ddzm( flux_lim - flux_np1 ) + field_np1 - - else if ( field_grid == "zm" ) then - - field_np1 = -real( dt, kind = core_rknd ) * 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 ) / real( dt, kind = core_rknd ) - - ! Replace the non-limited flux with the limited flux - flux_np1 = flux_lim - - return - end subroutine pos_definite_adj - -end module crmx_pos_definite_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_saturation.F90 b/src/physics/spcam/crm/CLUBB/crmx_saturation.F90 deleted file mode 100644 index a99bfce9fc..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_saturation.F90 +++ /dev/null @@ -1,789 +0,0 @@ -!$Id: saturation.F90 5997 2012-12-18 20:47:09Z raut@uwm.edu $ -!----------------------------------------------------------------------- -module crmx_saturation - -! Description: -! Contains functions that compute saturation with respect -! to liquid or ice. -!----------------------------------------------------------------------- - -#ifdef GFDL - use crmx_model_flags, only: & ! h1g, 2010-06-18 - I_sat_sphum -#endif - - use crmx_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 / - - 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 crmx_constants_clubb, only: & - ep, & ! Variable - fstderr - - use crmx_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 crmx_constants_clubb, only: & - ep, & ! Variable - fstderr - - use crmx_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 crmx_model_flags, only: & - saturation_formula, & ! Variable - saturation_bolton, & - saturation_gfdl, & - saturation_flatau - - use crmx_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 crmx_constants_clubb, only: T_freeze_K - - use crmx_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 crmx_constants_clubb, only: T_freeze_K - - use crmx_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 Gatch (1946) - -! Polysvp returned in units of pa. -! T_in_K is input in units of K. -!------------------------------------------------------------------------ - - use crmx_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] - -! Goff Gatch equation, uncertain below -70 C - - esat = 10._core_rknd**(-7.90298_core_rknd*(373.16_core_rknd/T_in_K-1._core_rknd)+ & - 5.02808_core_rknd*log10(373.16_core_rknd/T_in_K)- & - 1.3816e-7_core_rknd*(10._core_rknd**(11.344_core_rknd & - *(1._core_rknd-T_in_K/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-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 crmx_constants_clubb, only: & - ep ! Variable(s) - - use crmx_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 crmx_model_flags, only: & - saturation_formula, & ! Variable(s) - saturation_bolton, & - saturation_gfdl, & - saturation_flatau - - use crmx_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 crmx_constants_clubb, only: T_freeze_K - - use crmx_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 crmx_constants_clubb, only: T_freeze_K - - use crmx_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 Gatch (1946) -! -! Polysvp returned in units of pa. -! T_in_K is input in units of K. -!------------------------------------------------------------------------ - - use crmx_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 ) :: esati ! Saturation vapor pressure over ice [Pa] - -! Goff Gatch equation (good down to -100 C) - - esati = 10._core_rknd**(-9.09718_core_rknd* & - (273.16_core_rknd/T_in_k-1._core_rknd)-3.56654_core_rknd* & - log10(273.16_core_rknd/T_in_k)+0.876793_core_rknd* & - (1._core_rknd-T_in_k/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 crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - use crmx_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 - ELSEIF ( answer - thlm > tolerance ) THEN - too_high = theta - ELSEIF ( thlm - answer > tolerance ) THEN - too_low = theta - ENDIF - - ! 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 - ENDIF - - 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 crmx_saturation diff --git a/src/physics/spcam/crm/CLUBB/crmx_sigma_sqd_w_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_sigma_sqd_w_module.F90 deleted file mode 100644 index a10a868cdb..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_sigma_sqd_w_module.F90 +++ /dev/null @@ -1,64 +0,0 @@ -! $Id: sigma_sqd_w_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_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 crmx_constants_clubb, only: & - w_tol, & ! Constant(s) - rt_tol, & - thl_tol - - use crmx_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 crmx_sigma_sqd_w_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_sponge_layer_damping.F90 b/src/physics/spcam/crm/CLUBB/crmx_sponge_layer_damping.F90 deleted file mode 100644 index 5f13049ebe..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_sponge_layer_damping.F90 +++ /dev/null @@ -1,211 +0,0 @@ -!$Id: sponge_layer_damping.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_sponge_layer_damping -! Description: -! This module is used for damping variables in upper altitudes of the grid. -! -! References: -! None -!--------------------------------------------------------------------------------------------------- - - use crmx_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 ), pointer, 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 - - type(sponge_damp_profile), public :: & - 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 crmx_grid_class, only: gr ! Variable(s) - - use crmx_clubb_precision, only: time_precision, core_rknd ! Variable(s) - - implicit none - - ! External - intrinsic :: associated - - ! Input Variable(s) - real(kind=time_precision), 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 ( associated( 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 = real( dt, kind = core_rknd ) / 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 crmx_clubb_precision, only: time_precision, core_rknd ! Variable(s) - - use crmx_constants_clubb, only: fstderr ! Constant(s) - - use crmx_grid_class, only: gr ! Variable(s) - - use crmx_interpolation, only: lin_int ! function - - implicit none - - ! Input Variable(s) - real(kind=time_precision), 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 * real( dt, kind = core_rknd ) ) 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_int( 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 crmx_sponge_layer_damping diff --git a/src/physics/spcam/crm/CLUBB/crmx_stat_file_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_stat_file_module.F90 deleted file mode 100644 index 0818ecf1bd..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stat_file_module.F90 +++ /dev/null @@ -1,94 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: stat_file_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -module crmx_stat_file_module - - -! Description: -! Contains two derived types for describing the contents and location of -! either NetCDF or GrADS files. -!------------------------------------------------------------------------------- - use crmx_clubb_precision, only: & - stat_rknd, & ! Variable - time_precision, & - core_rknd - - implicit none - - public :: variable, stat_file - - 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 - 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(:), pointer :: & - z ! Height of vertical levels [m] - - ! Time information - - integer :: day, month, year ! Date of starting time - - real( kind = core_rknd ), dimension(:), pointer :: & - rlat, & ! Latitude [Degrees N] - rlon ! Longitude [Degrees E] - - real(kind=time_precision) :: & - 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(:), pointer :: & - var ! List and variable description - - end type stat_file - - end module crmx_stat_file_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_stats_LH_sfc.F90 b/src/physics/spcam/crm/CLUBB/crmx_stats_LH_sfc.F90 deleted file mode 100644 index f25a867d2a..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stats_LH_sfc.F90 +++ /dev/null @@ -1,106 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_LH_sfc.F90 6100 2013-03-08 17:53:44Z dschanen@uwm.edu $ - -module crmx_stats_LH_sfc - - - 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 LH_sfc -! References: -! None -!----------------------------------------------------------------------- - - use crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_stats_variables, only: & - LH_sfc ! Variable(s) - - use crmx_stats_variables, only: & - iLH_morr_rain_rate, & ! Variable(s) - iLH_morr_snow_rate, & - iLH_vwp, & - iLH_lwp - - use crmx_stats_type, only: & - stat_assign ! Procedure - - implicit none - - ! Input Variable - character(len= * ), dimension(nvarmax_LH_sfc), intent(in) :: vars_LH_sfc - - ! Output Variable - logical, intent(inout) :: l_error - - ! Local Varables - integer :: i, k - - ! ---- Begin Code ---- - - ! Default initialization for array indices for sfc - - iLH_morr_rain_rate = 0 - iLH_morr_snow_rate = 0 - iLH_vwp = 0 - iLH_lwp = 0 - - ! Assign pointers for statistics variables sfc - - k = 1 - do i=1,LH_sfc%nn - - select case ( trim( vars_LH_sfc(i) ) ) - - case ( 'LH_morr_rain_rate' ) - iLH_morr_rain_rate = k - call stat_assign( iLH_morr_rain_rate, "LH_morr_rain_rate", & - "Total precip fallout rate from Morrison scheme [mm/day]","mm/day", LH_sfc ) - k = k + 1 - - case ( 'LH_morr_snow_rate' ) - iLH_morr_snow_rate = k - call stat_assign( iLH_morr_snow_rate, "LH_morr_snow_rate", & - "Snow+Ice+Graupel fallout rate from Morrison scheme [mm/day]","mm/day", LH_sfc ) - k = k + 1 - - case ( 'LH_vwp' ) - iLH_vwp = k - call stat_assign( iLH_vwp, "LH_vwp", & - "Vapor water path [kg/m^2]","kg/m^2", LH_sfc ) - k = k + 1 - - case ( 'LH_lwp' ) - iLH_lwp = k - call stat_assign( iLH_lwp, "LH_lwp", & - "Liquid water path [kg/m^2]","kg/m^2", 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 - - return - end subroutine stats_init_LH_sfc - -end module crmx_stats_LH_sfc - diff --git a/src/physics/spcam/crm/CLUBB/crmx_stats_LH_zt.F90 b/src/physics/spcam/crm/CLUBB/crmx_stats_LH_zt.F90 deleted file mode 100644 index 9e48d884d6..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stats_LH_zt.F90 +++ /dev/null @@ -1,478 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_LH_zt.F90 5997 2012-12-18 20:47:09Z raut@uwm.edu $ - -module crmx_stats_LH_zt - - 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 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 crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_stats_variables, only: & - LH_zt ! Variable - - use crmx_stats_variables, only: & - iAKm, & ! Variable(s) - iLH_AKm, & - iAKstd, & - iAKstd_cld, & - iAKm_rcm, & - iAKm_rcc - - use crmx_stats_variables, only: & - iLH_thlm_mc, & ! Variable(s) - iLH_rvm_mc, & - iLH_rcm_mc, & - iLH_Ncm_mc, & - iLH_rrainm_mc, & - iLH_Nrm_mc, & - iLH_rsnowm_mc, & - iLH_Nsnowm_mc, & - iLH_rgraupelm_mc, & - iLH_Ngraupelm_mc, & - iLH_ricem_mc, & - iLH_Nim_mc, & - iLH_Vrr, & - iLH_VNr, & - iLH_rcm_avg - - use crmx_stats_variables, only: & - iLH_rrainm, & ! Variable(s) - iLH_Nrm, & - iLH_ricem, & - iLH_Nim, & - iLH_rsnowm, & - iLH_Nsnowm, & - iLH_rgraupelm, & - iLH_Ngraupelm, & - iLH_thlm, & - iLH_rcm, & - iLH_Ncm, & - iLH_rvm, & - iLH_wm, & - iLH_wp2_zt, & - iLH_rcp2_zt, & - iLH_rtp2_zt, & - iLH_thlp2_zt, & - iLH_rrainp2_zt, & - iLH_Nrp2_zt, & - iLH_Ncp2_zt, & - iLH_cloud_frac, & - iLH_rrainm_auto, & - iLH_rrainm_accr - - - use crmx_stats_type, only: & - stat_assign ! Procedure - - implicit none - - ! Input Variable - character(len= * ), dimension(nvarmax_LH_zt), intent(in) :: vars_LH_zt - - ! Output Variable - logical, intent(inout) :: l_error - - ! Local Varables - integer :: i, k - - ! ---- Begin Code ---- - - ! Default initialization for array indices for LH_zt - - iAKm = 0 ! analytic Kessler. Vince Larson 22 May 2005 - iLH_AKm = 0 ! LH Kessler. Vince Larson 22 May 2005 - iAKstd = 0 - iAKstd_cld = 0 - iAKm_rcm = 0 - iAKm_rcc = 0 - - iLH_thlm_mc = 0 - iLH_rvm_mc = 0 - iLH_rcm_mc = 0 - iLH_Ncm_mc = 0 - iLH_rrainm_mc = 0 - iLH_Nrm_mc = 0 - iLH_rsnowm_mc = 0 - iLH_Nsnowm_mc = 0 - iLH_rgraupelm_mc = 0 - iLH_Ngraupelm_mc = 0 - iLH_ricem_mc = 0 - iLH_Nim_mc = 0 - - iLH_rcm_avg = 0 - - iLH_Vrr = 0 - iLH_VNr = 0 - - iLH_rrainm = 0 - iLH_ricem = 0 - iLH_rsnowm = 0 - iLH_rgraupelm = 0 - - iLH_Nrm = 0 - iLH_Nim = 0 - iLH_Nsnowm = 0 - iLH_Ngraupelm = 0 - - iLH_thlm = 0 - iLH_rcm = 0 - iLH_rvm = 0 - iLH_wm = 0 - iLH_cloud_frac = 0 - - iLH_wp2_zt = 0 - iLH_rcp2_zt = 0 - iLH_rtp2_zt = 0 - iLH_thlp2_zt = 0 - iLH_rrainp2_zt = 0 - iLH_Nrp2_zt = 0 - iLH_Ncp2_zt = 0 - - iLH_rrainm_auto = 0 - iLH_rrainm_accr = 0 - - ! Assign pointers for statistics variables zt - - k = 1 - do i=1,LH_zt%nn - - select case ( trim(vars_LH_zt(i)) ) - case ( 'AKm' ) ! Vince Larson 22 May 2005 - iAKm = k - call stat_assign( iAKm, "AKm", & - "Analytic Kessler ac [kg/kg]", "kg/kg", LH_zt ) - k = k + 1 - - case ( 'LH_AKm' ) ! Vince Larson 22 May 2005 - iLH_AKm = k - - call stat_assign( iLH_AKm, "LH_AKm", & - "LH Kessler estimate [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'AKstd' ) - iAKstd = k - - call stat_assign( iAKstd, "AKstd", & - "Exact standard deviation of gba Kessler [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'AKstd_cld' ) - iAKstd_cld = k - - call stat_assign( iAKstd_cld, "AKstd_cld", & - "Exact w/in cloud std of gba Kessler [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'AKm_rcm' ) - iAKm_rcm = k - - call stat_assign( iAKm_rcm, "AKm_rcm", & - "Exact local gba auto based on rcm [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'AKm_rcc' ) - iAKm_rcc = k - - call stat_assign( iAKm_rcc, "AKm_rcc", & - "Exact local gba based on w/in cloud rc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_rvm_mc' ) - iLH_rvm_mc = k - - call stat_assign( iLH_rvm_mc, "LH_rvm_mc", & - "Latin hypercube estimate of rvm_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_thlm_mc' ) - iLH_thlm_mc = k - - call stat_assign( iLH_thlm_mc, "LH_thlm_mc", & - "Latin hypercube estimate of thlm_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_rcm_mc' ) - iLH_rcm_mc = k - - call stat_assign( iLH_rcm_mc, "LH_rcm_mc", & - "Latin hypercube estimate of rcm_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_Ncm_mc' ) - iLH_Ncm_mc = k - - call stat_assign( iLH_Ncm_mc, "LH_Ncm_mc", & - "Latin hypercube estimate of Ncm_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_rrainm_mc' ) - iLH_rrainm_mc = k - - call stat_assign( iLH_rrainm_mc, "LH_rrainm_mc", & - "Latin hypercube estimate of rrainm_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_Nrm_mc' ) - iLH_Nrm_mc = k - - call stat_assign( iLH_Nrm_mc, "LH_Nrm_mc", & - "Latin hypercube estimate of Nrm_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case('LH_rsnowm_mc') - iLH_rsnowm_mc = k - - call stat_assign( iLH_rsnowm_mc, "LH_rsnowm_mc", & - "Latin hypercube estimate of rsnowm_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_Nsnowm_mc' ) - iLH_Nsnowm_mc = k - - call stat_assign( iLH_Nsnowm_mc, "LH_Nsnowm_mc", & - "Latin hypercube estimate of Nsnowm_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_rgraupelm_mc' ) - iLH_rgraupelm_mc = k - - call stat_assign( iLH_rgraupelm_mc, "LH_rgraupelm_mc", & - "Latin hypercube estimate of rgraupelm_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_Ngraupelm_mc' ) - iLH_Ngraupelm_mc = k - - call stat_assign( iLH_Ngraupelm_mc, "LH_Ngraupelm_mc", & - "Latin hypercube estimate of Ngraupelm_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_ricem_mc' ) - iLH_ricem_mc = k - - call stat_assign( iLH_ricem_mc, "LH_ricem_mc", & - "Latin hypercube estimate of ricem_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_Nim_mc' ) - iLH_Nim_mc = k - - call stat_assign( iLH_Nim_mc, "LH_Nim_mc", & - "Latin hypercube estimate of Nim_mc [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_Vrr' ) - iLH_Vrr = k - - call stat_assign( iLH_Vrr, "LH_Vrr", & - "Latin hypercube estimate of rrainm sedimentation velocity [m/s]", "m/s", LH_zt ) - k = k + 1 - - case ( 'LH_VNr' ) - iLH_VNr = k - - call stat_assign( iLH_VNr, "LH_VNr", & - "Latin hypercube estimate of Nrm sedimentation velocity [m/s]", "m/s", LH_zt ) - k = k + 1 - - case ( 'LH_rcm_avg' ) - iLH_rcm_avg = k - - call stat_assign( iLH_rcm_avg, "LH_rcm_avg", & - "Latin hypercube average estimate of rcm [kg/kg]", "kg/kg", LH_zt ) - - k = k + 1 - - case ( 'LH_rrainm' ) - iLH_rrainm = k - - call stat_assign( iLH_rrainm, "LH_rrainm", & - "Latin hypercube estimate of rrainm [kg/kg]", "kg/kg", LH_zt ) - k = k + 1 - - case ( 'LH_Nrm' ) - iLH_Nrm = k - - call stat_assign( iLH_Nrm, "LH_Nrm", & - "Latin hypercube estimate of Nrm [count/kg]", "count/kg", LH_zt ) - k = k + 1 - - case ( 'LH_ricem' ) - iLH_ricem = k - - call stat_assign( iLH_ricem, "LH_ricem", & - "Latin hypercube estimate of ricem [kg/kg]", "kg/kg", LH_zt ) - k = k + 1 - - case ( 'LH_Nim' ) - iLH_Nim = k - - call stat_assign( iLH_Nim, "LH_Nim", & - "Latin hypercube estimate of Nim [count/kg]", "count/kg", LH_zt ) - k = k + 1 - - case ( 'LH_rsnowm' ) - iLH_rsnowm = k - - call stat_assign( iLH_rsnowm, "LH_rsnowm", & - "Latin hypercube estimate of rsnowm [kg/kg]", "kg/kg", LH_zt ) - k = k + 1 - - case ( 'LH_Nsnowm' ) - iLH_Nsnowm = k - - call stat_assign( iLH_Nsnowm, "LH_Nsnowm", & - "Latin hypercube estimate of Nsnowm [count/kg]", "count/kg", LH_zt ) - k = k + 1 - - - case ( 'LH_rgraupelm' ) - iLH_rgraupelm = k - - call stat_assign( iLH_rgraupelm, "LH_rgraupelm", & - "Latin hypercube estimate of rgraupelm [kg/kg]", "kg/kg", LH_zt ) - k = k + 1 - - case ( 'LH_Ngraupelm' ) - iLH_Ngraupelm = k - - call stat_assign( iLH_Ngraupelm, "LH_Ngraupelm", & - "Latin hypercube estimate of Ngraupelm [kg/kg]", "kg/kg", LH_zt ) - k = k + 1 - - case ( 'LH_thlm' ) - iLH_thlm = k - - call stat_assign( iLH_thlm, "LH_thlm", & - "Latin hypercube estimate of thlm [K]", "K", LH_zt ) - k = k + 1 - - case ( 'LH_rcm' ) - iLH_rcm = k - - call stat_assign( iLH_rcm, "LH_rcm", & - "Latin hypercube estimate of rcm [kg/kg]", "kg/kg", LH_zt ) - k = k + 1 - - case ( 'LH_Ncm' ) - iLH_Ncm = k - - call stat_assign( iLH_Ncm, "LH_Ncm", & - "Latin hypercube estimate of Ncm [count/kg]", "count/kg", LH_zt ) - k = k + 1 - - - case ( 'LH_rvm' ) - iLH_rvm = k - - call stat_assign( iLH_rvm, "LH_rvm", & - "Latin hypercube estimate of rvm [kg/kg]", "kg/kg", LH_zt ) - k = k + 1 - - case ( 'LH_wm' ) - iLH_wm = k - - call stat_assign( iLH_wm, "LH_wm", & - "Latin hypercube estimate of vertical velocity [m/s]", "m/s", LH_zt ) - k = k + 1 - - case ( 'LH_cloud_frac' ) - iLH_cloud_frac = k - - ! Note: count is the udunits compatible unit - call stat_assign( iLH_cloud_frac, "LH_cloud_frac", & - "Latin hypercube estimate of cloud fraction [count]", "count", LH_zt ) - k = k + 1 - - case ( 'LH_wp2_zt' ) - iLH_wp2_zt = k - call stat_assign( iLH_wp2_zt, "LH_wp2_zt", & - "Variance of the latin hypercube estimate of w [m^2/s^2]", "m^2/s^2", LH_zt ) - k = k + 1 - - case ( 'LH_Ncp2_zt' ) - iLH_Ncp2_zt = k - call stat_assign( iLH_Ncp2_zt, "LH_Ncp2_zt", & - "Variance of the latin hypercube estimate of Nc [count^2/kg^2]", "count^2/kg^2", LH_zt ) - k = k + 1 - - case ( 'LH_Nrp2_zt' ) - iLH_Nrp2_zt = k - call stat_assign( iLH_Nrp2_zt, "LH_Nrp2_zt", & - "Variance of the latin hypercube estimate of Nr [count^2/kg^2]", "count^2/kg^2", LH_zt ) - k = k + 1 - - case ( 'LH_rcp2_zt' ) - iLH_rcp2_zt = k - call stat_assign( iLH_rcp2_zt, "LH_rcp2_zt", & - "Variance of the latin hypercube estimate of rc [kg^2/kg^2]", "kg^2/kg^2", LH_zt ) - k = k + 1 - - case ( 'LH_rtp2_zt' ) - iLH_rtp2_zt = k - call stat_assign( iLH_rtp2_zt, "LH_rtp2_zt", & - "Variance of the latin hypercube estimate of rt [kg^2/kg^2]", "kg^2/kg^2", LH_zt ) - k = k + 1 - - case ( 'LH_thlp2_zt' ) - iLH_thlp2_zt = k - call stat_assign( iLH_thlp2_zt, "LH_thlp2_zt", & - "Variance of the latin hypercube estimate of thl [K^2]", "K^2", LH_zt ) - k = k + 1 - - case ( 'LH_rrainp2_zt' ) - iLH_rrainp2_zt = k - call stat_assign( iLH_rrainp2_zt, "LH_rrainp2_zt", & - "Variance of the latin hypercube estimate of rrain [kg^2/kg^2]", "kg^2/kg^2", LH_zt ) - k = k + 1 - - case ( 'LH_rrainm_auto' ) - iLH_rrainm_auto = k - call stat_assign( iLH_rrainm_auto, "LH_rrainm_auto", & - "Latin hypercube estimate of autoconversion [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - case ( 'LH_rrainm_accr' ) - iLH_rrainm_accr = k - call stat_assign( iLH_rrainm_accr, "LH_rrainm_accr", & - "Latin hypercube estimate of accretion [kg/kg/s]", "kg/kg/s", LH_zt ) - k = k + 1 - - 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 - - return - end subroutine stats_init_LH_zt - -end module crmx_stats_LH_zt diff --git a/src/physics/spcam/crm/CLUBB/crmx_stats_rad_zm.F90 b/src/physics/spcam/crm/CLUBB/crmx_stats_rad_zm.F90 deleted file mode 100644 index 8e12d00fd7..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stats_rad_zm.F90 +++ /dev/null @@ -1,157 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_rad_zm.F90 4032 2009-08-17 21:45:29Z senkbeil@uwm.edu $ - -module crmx_stats_rad_zm - - 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 rad_zm variables -!----------------------------------------------------------------------- - - use crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_stats_variables, only: & - 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 crmx_stats_variables, only: & - ifulwcl, ifdlwcl, ifdswcl, ifuswcl ! Variable(s) - - use crmx_stats_type, 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 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 rad_zm - - k = 1 - do i=1,rad_zm%nn - - select case ( trim(vars_rad_zm(i)) ) - - case('fulwcl') - ifulwcl = k - call stat_assign( ifulwcl, "fulwcl", & - "Upward clear-sky LW flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case( 'fdlwcl' ) - ifdlwcl = k - call stat_assign( ifdlwcl, "fdlwcl", & - "Downward clear-sky LW flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case( 'fdswcl' ) - ifdswcl = k - call stat_assign( ifdswcl, "fdswcl", & - "Downward clear-sky SW flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case( 'fuswcl' ) - ifuswcl = k - call stat_assign( ifuswcl, "fuswcl", & - "Upward clear-sky SW flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_LW_rad') - iFrad_LW_rad = k - - call stat_assign( iFrad_LW_rad, "Frad_LW_rad", & - "Net long-wave radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_SW_rad') - iFrad_SW_rad = k - - call stat_assign( iFrad_SW_rad, "Frad_SW_rad", & - "Net short-wave radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_SW_up_rad') - iFrad_SW_up_rad = k - - call stat_assign( iFrad_SW_up_rad, "Frad_SW_up_rad", & - "Short-wave upwelling radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_LW_up_rad') - iFrad_LW_up_rad = k - - call stat_assign( iFrad_LW_up_rad, "Frad_LW_up_rad", & - "Long-wave upwelling radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_SW_down_rad') - iFrad_SW_down_rad = k - - call stat_assign( iFrad_SW_down_rad, "Frad_SW_down_rad", & - "Short-wave downwelling radiative flux [W/m^2]", "W/m^2", rad_zm ) - k = k + 1 - - case ('Frad_LW_down_rad') - iFrad_LW_down_rad = k - - call stat_assign( iFrad_LW_down_rad, "Frad_LW_down_rad", & - "Long-wave downwelling radiative flux [W/m^2]", "W/m^2", 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 crmx_stats_rad_zm diff --git a/src/physics/spcam/crm/CLUBB/crmx_stats_rad_zt.F90 b/src/physics/spcam/crm/CLUBB/crmx_stats_rad_zt.F90 deleted file mode 100644 index 541fc2442b..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stats_rad_zt.F90 +++ /dev/null @@ -1,163 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_rad_zt.F90 4032 2009-08-17 21:45:29Z senkbeil@uwm.edu $ - -module crmx_stats_rad_zt - - 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 zt -! -! References: -! None -!----------------------------------------------------------------------- - - use crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_stats_variables, only: & - rad_zt, & - iT_in_K_rad, & ! Variable(s) - ircil_rad, & - io3l_rad, & - irsnowm_rad, & - ircm_in_cloud_rad, & - icloud_frac_rad, & - iice_supersat_frac_rad, & - iradht_rad, & - iradht_LW_rad, & - iradht_SW_rad - - use crmx_stats_type, 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 rad_zt - - iT_in_K_rad = 0 - ircil_rad = 0 - io3l_rad = 0 - irsnowm_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 - - ! Assign pointers for statistics variables rad_zt - - k = 1 - do i=1,rad_zt%nn - - select case ( trim(vars_rad_zt(i)) ) - - case ('T_in_K_rad') - iT_in_K_rad = k - - call stat_assign( iT_in_K_rad, "T_in_K_rad", & - "Temperature [K]", "K", rad_zt ) - k = k + 1 - - case ('rcil_rad') - ircil_rad = k - - call stat_assign( ircil_rad, "rcil_rad", & - "Ice mixing ratio [kg/kg]", "kg/kg", rad_zt ) - k = k + 1 - - case ('o3l_rad') - io3l_rad = k - - call stat_assign( io3l_rad, "o3l_rad", & - "Ozone mixing ratio [kg/kg]", "kg/kg", rad_zt ) - k = k + 1 - - case ('rsnowm_rad') - irsnowm_rad = k - - call stat_assign( irsnowm_rad, "rsnowm_rad", & - "Snow water mixing ratio [kg/kg]", "kg/kg", rad_zt ) - k = k + 1 - - case ('rcm_in_cloud_rad') - ircm_in_cloud_rad = k - - call stat_assign( ircm_in_cloud_rad, "rcm_in_cloud_rad", & - "rcm in cloud layer [kg/kg]", "kg/kg", rad_zt ) - k = k + 1 - - case ('cloud_frac_rad') - icloud_frac_rad = k - - call stat_assign( icloud_frac_rad, "cloud_frac_rad", & - "Cloud fraction (between 0 and 1) [-]", "count", rad_zt ) - k = k + 1 - - case ('ice_supersat_frac_rad') - iice_supersat_frac_rad = k - - call stat_assign( iice_supersat_frac_rad, "ice_supersat_frac_rad", & - "Ice cloud fraction (between 0 and 1) [-]", "count", rad_zt ) - k = k + 1 - - case ('radht_rad') - iradht_rad = k - - call stat_assign( iradht_rad, "radht_rad", & - "Total radiative heating rate [K/s]", "K/s", rad_zt ) - k = k + 1 - - case ('radht_LW_rad') - iradht_LW_rad = k - - call stat_assign( iradht_LW_rad, "radht_LW_rad", & - "Long-wave radiative heating rate [K/s]", "K/s", rad_zt ) - k = k + 1 - - case ('radht_SW_rad') - iradht_SW_rad = k - - call stat_assign( iradht_SW_rad, "radht_SW_rad", & - "Short-wave radiative heating rate [K/s]", "K/s", 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 crmx_stats_rad_zt diff --git a/src/physics/spcam/crm/CLUBB/crmx_stats_sfc.F90 b/src/physics/spcam/crm/CLUBB/crmx_stats_sfc.F90 deleted file mode 100644 index fdea934be5..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stats_sfc.F90 +++ /dev/null @@ -1,469 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_sfc.F90 6146 2013-04-05 18:02:22Z raut@uwm.edu $ - -module crmx_stats_sfc - - - 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 sfc -! References: -! None -!----------------------------------------------------------------------- - - use crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_stats_variables, only: & - 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, & - irain_rate_sfc, & - irain_flux_sfc, & - irrainm_sfc - - use crmx_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 crmx_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 crmx_stats_variables, only: & - imorr_rain_rate, & - imorr_snow_rate - - use crmx_stats_variables, only: & - irtm_spur_src, & - ithlm_spur_src - - use crmx_stats_type, only: & - stat_assign ! Procedure - - implicit none - - ! Input Variable - character(len= * ), dimension(nvarmax_sfc), intent(in) :: vars_sfc - - ! Output Variable - logical, intent(inout) :: l_error - - ! Local Varables - integer :: i, k - - ! ---- Begin Code ---- - - ! Default initialization for array indices for sfc - - isoil_heat_flux = 0 - iveg_T_in_K = 0 - isfc_soil_T_in_K = 0 - ideep_soil_T_in_K = 0 - - iustar = 0 - ilh = 0 - ish = 0 - icc = 0 - ilwp = 0 - irwp = 0 - ivwp = 0 ! nielsenb - iiwp = 0 ! nielsenb - iswp = 0 ! nielsenb - iz_cloud_base = 0 - iz_inversion = 0 - irain_rate_sfc = 0 ! Brian - irain_flux_sfc = 0 ! Brian - irrainm_sfc = 0 ! Brian - iwpthlp_sfc = 0 - 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 = 0 ! kcwhite - - ! These are estimates of the condition number on each LHS - ! matrix, and not located at the surface of the domain. - 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 - - imorr_rain_rate = 0 - imorr_snow_rate = 0 - - irtm_spur_src = 0 - ithlm_spur_src = 0 - - ! Assign pointers for statistics variables sfc - - k = 1 - do i=1,sfc%nn - - select case ( trim(vars_sfc(i)) ) - case ('soil_heat_flux') - isoil_heat_flux = k - - call stat_assign(isoil_heat_flux, "soil_heat_flux", & - "soil_heat_flux[W/m^2]","W/m^2",sfc ) - k = k + 1 - case ('ustar') - iustar = k - - call stat_assign(iustar,"ustar", & - "Friction velocity [m/s]","m/s",sfc) - k = k + 1 - case ('veg_T_in_K') - iveg_T_in_K = k - - call stat_assign(iveg_T_in_K,"veg_T_in_K", & - "Surface Vegetation Temperature [K]","K",sfc) - k = k + 1 - case ('sfc_soil_T_in_K') - isfc_soil_T_in_K = k - - call stat_assign(isfc_soil_T_in_K,"sfc_soil_T_in_K", & - "Surface soil temperature [K]","K",sfc) - k = k + 1 - case ('deep_soil_T_in_K') - ideep_soil_T_in_K = k - - call stat_assign(ideep_soil_T_in_K,"deep_soil_T_in_K", & - "Deep soil Temperature [K]","K",sfc) - k = k + 1 - - case ('lh') - ilh = k - call stat_assign(ilh,"lh", & - "Surface latent heating [W/m^2]","W/m2",sfc) - k = k + 1 - - case ('sh') - ish = k - call stat_assign(ish,"sh", & - "Surface sensible heating [W/m^2]","W/m2",sfc) - k = k + 1 - - case ('cc') - icc = k - call stat_assign(icc,"cc", & - "Cloud cover [count]","count",sfc) - k = k + 1 - - case ('lwp') - ilwp = k - call stat_assign(ilwp,"lwp", & - "Liquid water path [kg/m^2]","kg/m2",sfc) - k = k + 1 - - case ('vwp') - ivwp = k - call stat_assign(ivwp,"vwp", & - "Vapor water path [kg/m^2]","kg/m2",sfc) - k = k + 1 - - case ('iwp') - iiwp = k - call stat_assign(iiwp,"iwp", & - "Ice water path [kg/m^2]","kg/m2",sfc) - k = k + 1 - - case ('swp') - iswp = k - call stat_assign(iswp,"swp", & - "Snow water path [kg/m^2]","kg/m2",sfc) - k = k + 1 - - case ('rwp') - irwp = k - call stat_assign(irwp,"rwp", & - "Rain water path [kg/m^2]","kg/m2",sfc) - k = k + 1 - - case ('z_cloud_base') - iz_cloud_base = k - call stat_assign(iz_cloud_base,"z_cloud_base", & - "Cloud base altitude [m]","m",sfc) - k = k + 1 - - case ('z_inversion') - iz_inversion = k - call stat_assign(iz_inversion,"z_inversion", & - "Inversion altitude [m]","m",sfc) - k = k + 1 - - case ('rain_rate_sfc') ! Brian - irain_rate_sfc = k - call stat_assign(irain_rate_sfc,"rain_rate_sfc", & - "Surface rainfall rate [mm/day]","mm/day",sfc) - k = k + 1 - - case ('rain_flux_sfc') ! Brian - irain_flux_sfc = k - - call stat_assign( irain_flux_sfc,"rain_flux_sfc", & - "Surface rain flux [W/m^2]", "W/m^2", sfc ) - k = k + 1 - - case ('rrainm_sfc') ! Brian - irrainm_sfc = k - - call stat_assign(irrainm_sfc,"rrainm_sfc", & - "Surface rain water mixing ratio [kg/kg]","kg/kg",sfc) - k = k + 1 - - case ( 'morr_rain_rate' ) - imorr_rain_rate = k - call stat_assign( imorr_rain_rate, "morr_rain_rate", & - "Total precip fallout rate from Morrison scheme [mm/day]","mm/day", sfc ) - k = k + 1 - - case ( 'morr_snow_rate' ) - imorr_snow_rate = k - call stat_assign( imorr_snow_rate, "morr_snow_rate", & - "Snow+Ice+Graupel fallout rate from Morrison scheme [mm/day]","mm/day", sfc ) - k = k + 1 - - case ('wpthlp_sfc') - iwpthlp_sfc = k - - call stat_assign(iwpthlp_sfc,"wpthlp_sfc", & - "wpthlp surface flux [K m/s]","K m/s",sfc) - k = k + 1 - - case ('wprtp_sfc') - iwprtp_sfc = k - - call stat_assign(iwprtp_sfc,"wprtp_sfc", & - "wprtp surface flux [kg/kg]","(kg/kg) m/s",sfc) - k = k + 1 - - case ('upwp_sfc') - iupwp_sfc = k - - call stat_assign(iupwp_sfc,"upwp_sfc", & - "upwp surface flux [m^2/s^2]","m^2/s^2",sfc) - k = k + 1 - - case ('vpwp_sfc') - ivpwp_sfc = k - - call stat_assign(ivpwp_sfc,"vpwp_sfc", & - "vpwp surface flux [m^2/s^2]","m^2/s^2",sfc) - k = k + 1 - - case ('thlm_vert_avg') - ithlm_vert_avg = k - - call stat_assign( ithlm_vert_avg, "thlm_vert_avg", & - "Vertical average (density-weighted) of thlm [K]", "K", sfc ) - k = k + 1 - - case ('rtm_vert_avg') - irtm_vert_avg = k - - call stat_assign( irtm_vert_avg, "rtm_vert_avg", & - "Vertical average (density-weighted) of rtm [kg/kg]", "kg/kg", sfc ) - k = k + 1 - - case ('um_vert_avg') - ium_vert_avg = k - - call stat_assign( ium_vert_avg, "um_vert_avg", & - "Vertical average (density-weighted) of um [m/s]", "m/s", sfc ) - k = k + 1 - - case ('vm_vert_avg') - ivm_vert_avg = k - - call stat_assign( ivm_vert_avg, "vm_vert_avg", & - "Vertical average (density-weighted) of vm [m/s]", "m/s", sfc ) - k = k + 1 - - case ('wp2_vert_avg') - iwp2_vert_avg = k - - call stat_assign( iwp2_vert_avg, "wp2_vert_avg", & - "Vertical average (density-weighted) of wp2 [m^2/s^2]", "m^2/s^2", & - sfc ) - k = k + 1 - - case ('up2_vert_avg') - iup2_vert_avg = k - - call stat_assign( iup2_vert_avg, "up2_vert_avg", & - "Vertical average (density-weighted) of up2 [m^2/s^2]", "m^2/s^2", & - sfc ) - k = k + 1 - - case ('vp2_vert_avg') - ivp2_vert_avg = k - - call stat_assign( ivp2_vert_avg, "vp2_vert_avg", & - "Vertical average (density-weighted) of vp2 [m^2/s^2]", "m^2/s^2", & - sfc ) - k = k + 1 - - case ('rtp2_vert_avg') - irtp2_vert_avg = k - - call stat_assign( irtp2_vert_avg, "rtp2_vert_avg", & - "Vertical average (density-weighted) of rtp2 [kg^2/kg^2]", & - "kg^2/kg^2", sfc ) - k = k + 1 - - case ('thlp2_vert_avg') - ithlp2_vert_avg = k - - call stat_assign( ithlp2_vert_avg, "thlp2_vert_avg", & - "Vertical average (density-weighted) of thlp2 [K^2]", "K^2", sfc ) - k = k + 1 - - case ('T_sfc') - iT_sfc = k - - call stat_assign( iT_sfc, "T_sfc", "Surface Temperature [K]", "K", sfc ) - k = k + 1 - - case ('wp23_matrix_condt_num') - iwp23_matrix_condt_num = k - call stat_assign(iwp23_matrix_condt_num,"wp23_matrix_condt_num", & - "Estimate of the condition number for wp2/3 [count]","count",sfc) - k = k + 1 - - case ('thlm_matrix_condt_num') - ithlm_matrix_condt_num = k - call stat_assign(ithlm_matrix_condt_num,"thlm_matrix_condt_num", & - "Estimate of the condition number for thlm/wpthlp [count]", & - "count",sfc) - k = k + 1 - - case ('rtm_matrix_condt_num') - irtm_matrix_condt_num = k - - call stat_assign(irtm_matrix_condt_num,"rtm_matrix_condt_num", & - "Estimate of the condition number for rtm/wprtp [count]", & - "count",sfc) - k = k + 1 - - case ('thlp2_matrix_condt_num') - ithlp2_matrix_condt_num = k - - call stat_assign(ithlp2_matrix_condt_num,"thlp2_matrix_condt_num", & - "Estimate of the condition number for thlp2 [count]", & - "count",sfc) - k = k + 1 - - case ('rtp2_matrix_condt_num') - irtp2_matrix_condt_num = k - call stat_assign(irtp2_matrix_condt_num,"rtp2_matrix_condt_num", & - "Estimate of the condition number for rtp2 [count]", & - "count",sfc) - k = k + 1 - - case ('rtpthlp_matrix_condt_num') - irtpthlp_matrix_condt_num = k - call stat_assign(irtpthlp_matrix_condt_num,"rtpthlp_matrix_condt_num", & - "Estimate of the condition number for rtpthlp [count]", & - "count",sfc) - k = k + 1 - - case ('up2_vp2_matrix_condt_num') - iup2_vp2_matrix_condt_num = k - call stat_assign(iup2_vp2_matrix_condt_num,"up2_vp2_matrix_condt_num", & - "Estimate of the condition number for up2/vp2 [count]","count",sfc) - k = k + 1 - - case ('windm_matrix_condt_num') - iwindm_matrix_condt_num = k - call stat_assign(iwindm_matrix_condt_num,"windm_matrix_condt_num", & - "Estimate of the condition number for the mean wind [count]","count",sfc) - - k = k + 1 - - case ('rtm_spur_src') - irtm_spur_src = k - - call stat_assign(irtm_spur_src, "rtm_spur_src", & - "rtm spurious source [kg/(m^2 s)]", "kg/(m^2 s)",sfc ) - k = k + 1 - - case ('thlm_spur_src') - ithlm_spur_src = k - - call stat_assign(ithlm_spur_src, "thlm_spur_src", & - "thlm spurious source [(K kg) / (m^2 s)]", "(K kg) / (m^2 s)",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 - - return - - end subroutine stats_init_sfc - - -end module crmx_stats_sfc - diff --git a/src/physics/spcam/crm/CLUBB/crmx_stats_subs.F90 b/src/physics/spcam/crm/CLUBB/crmx_stats_subs.F90 deleted file mode 100644 index 8245c378db..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stats_subs.F90 +++ /dev/null @@ -1,2679 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_subs.F90 6146 2013-04-05 18:02:22Z raut@uwm.edu $ -module crmx_stats_subs - - 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 - - contains - - !----------------------------------------------------------------------- - subroutine stats_init( iunit, fname_prefix, fdir, l_stats_in, & - stats_fmt_in, stats_tsamp_in, stats_tout_in, fnamelist, & - nzmax, gzt, gzm, nnrad_zt, & - grad_zt, nnrad_zm, grad_zm, day, month, year, & - rlat, rlon, time_current, delt ) - ! - ! Description: - ! Initializes the statistics saving functionality of the CLUBB model. - ! - ! References: - ! None - !----------------------------------------------------------------------- - - use crmx_stats_variables, only: & - zt, & ! Variables - ztscr01, & - ztscr02, & - ztscr03, & - ztscr04, & - ztscr05, & - ztscr06, & - ztscr07, & - ztscr08, & - ztscr09, & - ztscr10, & - ztscr11, & - ztscr12, & - ztscr13, & - ztscr14, & - ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 - - use crmx_stats_variables, only: & - LH_zt, & ! Variable(s) - LH_sfc - - use crmx_stats_variables, only: & - zm, & ! Variables - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr10, & - zmscr11, & - zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17, & - rad_zt - - use crmx_stats_variables, only: & - rad_zm, & - 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 crmx_clubb_precision, only: & - time_precision, & ! Constant(s) - core_rknd - - use crmx_output_grads, only: & - open_grads ! Procedure - -#ifdef NETCDF - use crmx_output_netcdf, only: & - open_netcdf ! Procedure -#endif - - use crmx_stats_zm, only: & - nvarmax_zm, & ! Constant(s) - stats_init_zm ! Procedure(s) - - use crmx_stats_zt, only: & - nvarmax_zt, & ! Constant(s) - stats_init_zt ! Procedure(s) - - use crmx_stats_LH_zt, only: & - nvarmax_LH_zt, & ! Constant(s) - stats_init_LH_zt ! Procedure(s) - - use crmx_stats_LH_sfc, only: & - nvarmax_LH_sfc, & ! Constant(s) - stats_init_LH_sfc ! Procedure(s) - - use crmx_stats_rad_zt, only: & - nvarmax_rad_zt, & ! Constant(s) - stats_init_rad_zt ! Procedure(s) - - use crmx_stats_rad_zm, only: & - nvarmax_rad_zm, & ! Constant(s) - stats_init_rad_zm ! Procedure(s) - - use crmx_stats_sfc, only: & - nvarmax_sfc, & ! Constant(s) - stats_init_sfc ! Procedure(s) - - use crmx_error_code, only: & - clubb_at_least_debug_level ! Function - - use crmx_constants_clubb, only: & - fstdout, fstderr, var_length ! Constants - - use crmx_parameters_microphys, only: & - LH_microphys_disabled, & ! Constant - LH_microphys_type ! Variable - - 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=time_precision), 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) :: nzmax ! Grid points in the vertical [count] - - 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(1), intent(in) :: & - rlat, rlon ! Latitude and Longitude [Degrees N/E] - - real(kind=time_precision), intent(in) :: & - time_current ! Model time [s] - - real(kind=time_precision), intent(in) :: & - delt ! Timestep (dt_main in CLUBB) [s] - - - ! Local Variables - logical :: l_error - - character(len=200) :: fname - - integer :: i, 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 ) - - 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 = " - i = 1 - do while ( vars_zt(i) /= '' ) - write(fstdout,*) vars_zt(i) - i = i + 1 - end do - - write(fstdout,*) "vars_zm = " - i = 1 - do while ( vars_zm(i) /= '' ) - write(fstdout,*) vars_zm(i) - i = i + 1 - end do - - if ( LH_microphys_type /= LH_microphys_disabled ) then - write(fstdout,*) "vars_LH_zt = " - i = 1 - do while ( vars_LH_zt(i) /= '' ) - write(fstdout,*) vars_LH_zt(i) - i = i + 1 - end do - - write(fstdout,*) "vars_LH_sfc = " - i = 1 - do while ( vars_LH_sfc(i) /= '' ) - write(fstdout,*) vars_LH_sfc(i) - i = i + 1 - end do - end if ! LH_microphys_type /= LH_microphys_disabled - - if ( l_output_rad_files ) then - write(fstdout,*) "vars_rad_zt = " - i = 1 - do while ( vars_rad_zt(i) /= '' ) - write(fstdout,*) vars_rad_zt(i) - i = i + 1 - end do - - write(fstdout,*) "vars_rad_zm = " - i = 1 - do while ( vars_rad_zm(i) /= '' ) - write(fstdout,*) vars_rad_zm(i) - i = i + 1 - end do - end if ! l_output_rad_files - - write(fstdout,*) "vars_sfc = " - i = 1 - do while ( vars_sfc(i) /= '' ) - write(fstdout,*) vars_sfc(i) - i = i + 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_subs 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=time_precision ) ) & - > 1.e-8_time_precision ) 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=time_precision ) ) & - > 1.e-8_time_precision ) 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) - - i = 1 - do while ( ichar(vars_zt(i)(1:1)) /= 0 & - .and. len_trim(vars_zt(i)) /= 0 & - .and. i <= nvarmax_zt ) - i = i + 1 - end do - ntot = i - 1 - 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 - - zt%nn = ntot - zt%kk = nzmax - - allocate( zt%z( zt%kk ) ) - zt%z = gzt - - allocate( zt%x( 1, 1, zt%kk, zt%nn ) ) - allocate( zt%n( 1, 1, zt%kk, zt%nn ) ) - allocate( zt%l_in_update( 1, 1, zt%kk, zt%nn ) ) - call stats_zero( zt%kk, zt%nn, zt%x, zt%n, zt%l_in_update ) - - allocate( zt%f%var( zt%nn ) ) - allocate( zt%f%z( zt%kk ) ) - - ! Allocate scratch space - - allocate( ztscr01(zt%kk) ) - allocate( ztscr02(zt%kk) ) - allocate( ztscr03(zt%kk) ) - allocate( ztscr04(zt%kk) ) - allocate( ztscr05(zt%kk) ) - allocate( ztscr06(zt%kk) ) - allocate( ztscr07(zt%kk) ) - allocate( ztscr08(zt%kk) ) - allocate( ztscr09(zt%kk) ) - allocate( ztscr10(zt%kk) ) - allocate( ztscr11(zt%kk) ) - allocate( ztscr12(zt%kk) ) - allocate( ztscr13(zt%kk) ) - allocate( ztscr14(zt%kk) ) - allocate( ztscr15(zt%kk) ) - allocate( ztscr16(zt%kk) ) - allocate( ztscr17(zt%kk) ) - allocate( ztscr18(zt%kk) ) - allocate( ztscr19(zt%kk) ) - allocate( ztscr20(zt%kk) ) - allocate( ztscr21(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, zt%kk, zt%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - zt%nn, zt%f ) - - else ! Open NetCDF file -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, 1, zt%kk, zt%z, & ! In - day, month, year, rlat, rlon, & ! In - time_current+stats_tout, stats_tout, zt%nn, & ! In - zt%f ) ! 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 LH_zt (Latin Hypercube stats) - - if ( LH_microphys_type /= LH_microphys_disabled ) then - - i = 1 - do while ( ichar(vars_LH_zt(i)(1:1)) /= 0 & - .and. len_trim(vars_LH_zt(i)) /= 0 & - .and. i <= nvarmax_LH_zt ) - i = i + 1 - end do - ntot = i - 1 - 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 - - LH_zt%nn = ntot - LH_zt%kk = nzmax - - allocate( LH_zt%z( LH_zt%kk ) ) - LH_zt%z = gzt - - allocate( LH_zt%x( 1, 1, LH_zt%kk, LH_zt%nn ) ) - allocate( LH_zt%n( 1, 1, LH_zt%kk, LH_zt%nn ) ) - allocate( LH_zt%l_in_update( 1, 1, LH_zt%kk, LH_zt%nn ) ) - call stats_zero( LH_zt%kk, LH_zt%nn, LH_zt%x, LH_zt%n, LH_zt%l_in_update ) - - allocate( LH_zt%f%var( LH_zt%nn ) ) - allocate( LH_zt%f%z( LH_zt%kk ) ) - - - fname = trim( fname_LH_zt ) - - if ( l_grads ) then - - ! Open GrADS file - call open_grads( iunit, fdir, fname, & - 1, LH_zt%kk, LH_zt%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - LH_zt%nn, LH_zt%f ) - - else ! Open NetCDF file -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, 1, LH_zt%kk, LH_zt%z, & ! In - day, month, year, rlat, rlon, & ! In - time_current+stats_tout, stats_tout, LH_zt%nn, & ! In - LH_zt%f ) ! 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 ) - - i = 1 - do while ( ichar(vars_LH_sfc(i)(1:1)) /= 0 & - .and. len_trim(vars_LH_sfc(i)) /= 0 & - .and. i <= nvarmax_LH_sfc ) - i = i + 1 - end do - ntot = i - 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 - - LH_sfc%nn = ntot - LH_sfc%kk = 1 - - allocate( LH_sfc%z( LH_sfc%kk ) ) - LH_sfc%z = gzm(1) - - allocate( LH_sfc%x( 1, 1, LH_sfc%kk, LH_sfc%nn ) ) - allocate( LH_sfc%n( 1, 1, LH_sfc%kk, LH_sfc%nn ) ) - allocate( LH_sfc%l_in_update( 1, 1, LH_sfc%kk, LH_sfc%nn ) ) - - call stats_zero( LH_sfc%kk, LH_sfc%nn, LH_sfc%x, LH_sfc%n, LH_sfc%l_in_update ) - - allocate( LH_sfc%f%var( LH_sfc%nn ) ) - allocate( LH_sfc%f%z( LH_sfc%kk ) ) - - fname = trim( fname_LH_sfc ) - - if ( l_grads ) then - - ! Open GrADS file - call open_grads( iunit, fdir, fname, & - 1, LH_sfc%kk, LH_sfc%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - LH_sfc%nn, LH_sfc%f ) - - else ! Open NetCDF file -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, 1, LH_sfc%kk, LH_sfc%z, & ! In - day, month, year, rlat, rlon, & ! In - time_current+stats_tout, stats_tout, LH_sfc%nn, & ! In - LH_sfc%f ) ! 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 ! LH_microphys_type /= LH_microphys_disabled - - ! Initialize zm (momentum points) - - i = 1 - do while ( ichar(vars_zm(i)(1:1)) /= 0 & - .and. len_trim(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 ", & - "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 - - zm%nn = ntot - zm%kk = nzmax - - allocate( zm%z( zm%kk ) ) - zm%z = gzm - - allocate( zm%x( 1, 1, zm%kk, zm%nn ) ) - allocate( zm%n( 1, 1, zm%kk, zm%nn ) ) - allocate( zm%l_in_update( 1, 1, zm%kk, zm%nn ) ) - - call stats_zero( zm%kk, zm%nn, zm%x, zm%n, zm%l_in_update ) - - allocate( zm%f%var( zm%nn ) ) - allocate( zm%f%z( zm%kk ) ) - - ! Allocate scratch space - - allocate( zmscr01(zm%kk) ) - allocate( zmscr02(zm%kk) ) - allocate( zmscr03(zm%kk) ) - allocate( zmscr04(zm%kk) ) - allocate( zmscr05(zm%kk) ) - allocate( zmscr06(zm%kk) ) - allocate( zmscr07(zm%kk) ) - allocate( zmscr08(zm%kk) ) - allocate( zmscr09(zm%kk) ) - allocate( zmscr10(zm%kk) ) - allocate( zmscr11(zm%kk) ) - allocate( zmscr12(zm%kk) ) - allocate( zmscr13(zm%kk) ) - allocate( zmscr14(zm%kk) ) - allocate( zmscr15(zm%kk) ) - allocate( zmscr16(zm%kk) ) - allocate( zmscr17(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, zm%kk, zm%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - zm%nn, zm%f ) - - else ! Open NetCDF file -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, 1, zm%kk, zm%z, & ! In - day, month, year, rlat, rlon, & ! In - time_current+stats_tout, stats_tout, zm%nn, & ! In - zm%f ) ! InOut - -#else - stop "This CLUBB program was not compiled with netCDF support." -#endif - end if - - call stats_init_zm( vars_zm, l_error ) - - ! Initialize rad_zt (radiation points) - - if (l_output_rad_files) then - - i = 1 - do while ( ichar(vars_rad_zt(i)(1:1)) /= 0 & - .and. len_trim(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 ", & - "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 - - rad_zt%nn = ntot - rad_zt%kk = nnrad_zt - - allocate( rad_zt%z( rad_zt%kk ) ) - rad_zt%z = grad_zt - - allocate( rad_zt%x( 1, 1, rad_zt%kk, rad_zt%nn ) ) - allocate( rad_zt%n( 1, 1, rad_zt%kk, rad_zt%nn ) ) - allocate( rad_zt%l_in_update( 1, 1, rad_zt%kk, rad_zt%nn ) ) - - call stats_zero( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n, rad_zt%l_in_update ) - - allocate( rad_zt%f%var( rad_zt%nn ) ) - allocate( rad_zt%f%z( rad_zt%kk ) ) - - ! Allocate scratch space - - !allocate( radscr01(rad%kk) ) - !allocate( radscr02(rad%kk) ) - !allocate( radscr03(rad%kk) ) - !allocate( radscr04(rad%kk) ) - !allocate( radscr05(rad%kk) ) - !allocate( radscr06(rad%kk) ) - !allocate( radscr07(rad%kk) ) - !allocate( radscr08(rad%kk) ) - !allocate( radscr09(rad%kk) ) - !allocate( radscr10(rad%kk) ) - !allocate( radscr11(rad%kk) ) - !allocate( radscr12(rad%kk) ) - !allocate( radscr13(rad%kk) ) - !allocate( radscr14(rad%kk) ) - !allocate( radscr15(rad%kk) ) - !allocate( radscr16(rad%kk) ) - !allocate( radscr17(rad%kk) ) - - !radscr01 = 0.0_core_rknd - !radscr02 = 0.0_core_rknd - !radscr03 = 0.0_core_rknd - !radscr04 = 0.0_core_rknd - !radscr05 = 0.0_core_rknd - !radscr06 = 0.0_core_rknd - !radscr07 = 0.0_core_rknd - !radscr08 = 0.0_core_rknd - !radscr09 = 0.0_core_rknd - !radscr10 = 0.0_core_rknd - !radscr11 = 0.0_core_rknd - !radscr12 = 0.0_core_rknd - !radscr13 = 0.0_core_rknd - !radscr14 = 0.0_core_rknd - !radscr15 = 0.0_core_rknd - !radscr16 = 0.0_core_rknd - !radscr17 = 0.0_core_rknd - - - fname = trim( fname_rad_zt ) - if ( l_grads ) then - - ! Open GrADS files - call open_grads( iunit, fdir, fname, & - 1, rad_zt%kk, rad_zt%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - rad_zt%nn, rad_zt%f ) - - else ! Open NetCDF file -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, & - 1, rad_zt%kk, rad_zt%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - rad_zt%nn, rad_zt%f ) - -#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 rad_zm (radiation points) - - i = 1 - do while ( ichar(vars_rad_zm(i)(1:1)) /= 0 & - .and. len_trim(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 ", & - "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 - - rad_zm%nn = ntot - rad_zm%kk = nnrad_zm - - allocate( rad_zm%z( rad_zm%kk ) ) - rad_zm%z = grad_zm - - allocate( rad_zm%x( 1, 1, rad_zm%kk, rad_zm%nn ) ) - allocate( rad_zm%n( 1, 1, rad_zm%kk, rad_zm%nn ) ) - allocate( rad_zm%l_in_update( 1, 1, rad_zm%kk, rad_zm%nn ) ) - - call stats_zero( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n, rad_zm%l_in_update ) - - allocate( rad_zm%f%var( rad_zm%nn ) ) - allocate( rad_zm%f%z( rad_zm%kk ) ) - - ! Allocate scratch space - - !allocate( radscr01(rad%kk) ) - !allocate( radscr02(rad%kk) ) - !allocate( radscr03(rad%kk) ) - !allocate( radscr04(rad%kk) ) - !allocate( radscr05(rad%kk) ) - !allocate( radscr06(rad%kk) ) - !allocate( radscr07(rad%kk) ) - !allocate( radscr08(rad%kk) ) - !allocate( radscr09(rad%kk) ) - !allocate( radscr10(rad%kk) ) - !allocate( radscr11(rad%kk) ) - !allocate( radscr12(rad%kk) ) - !allocate( radscr13(rad%kk) ) - !allocate( radscr14(rad%kk) ) - !allocate( radscr15(rad%kk) ) - !allocate( radscr16(rad%kk) ) - !allocate( radscr17(rad%kk) ) - - !radscr01 = 0.0_core_rknd - !radscr02 = 0.0_core_rknd - !radscr03 = 0.0_core_rknd - !radscr04 = 0.0_core_rknd - !radscr05 = 0.0_core_rknd - !radscr06 = 0.0_core_rknd - !radscr07 = 0.0_core_rknd - !radscr08 = 0.0_core_rknd - !radscr09 = 0.0_core_rknd - !radscr10 = 0.0_core_rknd - !radscr11 = 0.0_core_rknd - !radscr12 = 0.0_core_rknd - !radscr13 = 0.0_core_rknd - !radscr14 = 0.0_core_rknd - !radscr15 = 0.0_core_rknd - !radscr16 = 0.0_core_rknd - !radscr17 = 0.0_core_rknd - - - fname = trim( fname_rad_zm ) - if ( l_grads ) then - - ! Open GrADS files - call open_grads( iunit, fdir, fname, & - 1, rad_zm%kk, rad_zm%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - rad_zm%nn, rad_zm%f ) - - else ! Open NetCDF file -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, & - 1, rad_zm%kk, rad_zm%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - rad_zm%nn, rad_zm%f ) - -#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 sfc (surface point) - - i = 1 - do while ( ichar(vars_sfc(i)(1:1)) /= 0 & - .and. len_trim(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 ", & - "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 - - sfc%nn = ntot - sfc%kk = 1 - - allocate( sfc%z( sfc%kk ) ) - sfc%z = gzm(1) - - allocate( sfc%x( 1, 1, sfc%kk, sfc%nn ) ) - allocate( sfc%n( 1, 1, sfc%kk, sfc%nn ) ) - allocate( sfc%l_in_update( 1, 1, sfc%kk, sfc%nn ) ) - - call stats_zero( sfc%kk, sfc%nn, sfc%x, sfc%n, sfc%l_in_update ) - - allocate( sfc%f%var( sfc%nn ) ) - allocate( sfc%f%z( sfc%kk ) ) - - fname = trim( fname_sfc ) - - if ( l_grads ) then - - ! Open GrADS files - call open_grads( iunit, fdir, fname, & - 1, sfc%kk, sfc%z, & - day, month, year, rlat, rlon, & - time_current+stats_tout, stats_tout, & - sfc%nn, sfc%f ) - - else ! Open NetCDF files -#ifdef NETCDF - call open_netcdf( 1, 1, fdir, fname, 1, sfc%kk, sfc%z, & ! In - day, month, year, rlat, rlon, & ! In - time_current+stats_tout, stats_tout, sfc%nn, & ! In - sfc%f ) ! 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( kk, nn, x, n, l_in_update ) - - ! Description: - ! Initialize stats to zero - ! References: - ! None - !----------------------------------------------------------------------- - use crmx_clubb_precision, only: & - stat_rknd, & ! Variable(s) - stat_nknd - - implicit none - - ! Input Variable(s) - integer, intent(in) :: kk, nn - - ! Output Variable(s) - 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_stat_rknd - n(:,:,:,:) = 0_stat_nknd - l_in_update(:,:,:,:) = .false. - end if - - return - end subroutine stats_zero - - !----------------------------------------------------------------------- - subroutine stats_avg( kk, nn, x, n ) - - ! Description: - ! Compute the average of stats fields - ! References: - ! None - !----------------------------------------------------------------------- - use crmx_clubb_precision, only: & - stat_rknd, & ! Variable(s) - stat_nknd - - implicit none - - ! External - intrinsic :: real - - ! Input Variable(s) - integer, intent(in) :: & - kk, & ! Number of levels in vertical (i.e. Z) dimension - nn ! Number of variables being sampled in x - - integer(kind=stat_nknd), dimension(1,1,kk,nn), intent(in) :: & - n ! The variable n is the number of samples per x per kk - - ! Output Variable(s) - real(kind=stat_rknd), dimension(1,1,kk,nn), intent(inout) :: & - x ! The variable x is a set of nn variables being averaged over n - - ! ---- Begin Code ---- - - ! Compute averages - where ( n(1,1,1:kk,1:nn) > 0 ) - x(1,1,1:kk,1:nn) = x(1,1,1:kk,1:nn) / real( n(1,1,1:kk,1:nn), kind=stat_rknd ) - end where - - return - end subroutine stats_avg - - !----------------------------------------------------------------------- - subroutine stats_begin_timestep( time_elapsed ) - - ! 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 crmx_stats_variables, only: & - l_stats, & ! Variable(s) - l_stats_samp, & - l_stats_last, & - stats_tsamp, & - stats_tout - - use crmx_clubb_precision, only: & - time_precision ! Variable(s) - - implicit none - - ! External - intrinsic :: mod - - ! Input Variable(s) - real(kind=time_precision), intent(in) :: & - time_elapsed ! Elapsed model time [s] - - 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( time_elapsed, stats_tsamp ) < 1.e-8_time_precision ) 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( time_elapsed, stats_tout ) < 1.e-8_time_precision ) 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 crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_stats_variables, only: & - zt, & ! Variable(s) - LH_zt, & - LH_sfc, & - zm, & - rad_zt, & - rad_zm, & - sfc, & - l_stats_last, & - stats_tsamp, & - stats_tout, & - l_output_rad_files, & - l_grads - - use crmx_clubb_precision, only: & - time_precision ! Variable(s) - - use crmx_output_grads, only: & - write_grads ! Procedure(s) - - use crmx_error_code, only: & - clubb_at_least_debug_level ! Procedure(s) - - use crmx_parameters_microphys, only: & - LH_microphys_disabled ! Constant - - use crmx_parameters_microphys, only: & - LH_microphys_type, & ! Variable(s) - LH_microphys_calls - -#ifdef NETCDF - use crmx_output_netcdf, only: & - write_netcdf ! Procedure(s) -#endif - - implicit none - - ! External - intrinsic :: floor - - ! Local Variables - - integer :: i, k - - logical :: l_error - - ! ---- Begin Code ---- - - ! 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, zt%nn - do k = 1, zt%kk - - if ( zt%n(1,1,k,i) /= 0 .and. & - zt%n(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(zt%f%var(i)%name), ' in zt ', & - 'at k = ', k, & - '; zt%n(',k,',',i,') = ', zt%n(1,1,k,i) - end if ! clubb_at_lest_debug_level 1 - - end if ! n /= 0 and n /= stats_tout/stats_tsamp - - end do ! k = 1 .. zt%kk - end do ! i = 1 .. zt%nn - - ! Look for errors by checking the number of sampling points - ! for each variable in the zm statistics at each vertical level. - do i = 1, zm%nn - do k = 1, zm%kk - - if ( zm%n(1,1,k,i) /= 0 .and. & - zm%n(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(zm%f%var(i)%name), ' in zm ', & - 'at k = ', k, & - '; zm%n(',k,',',i,') = ', zm%n(1,1,k,i) - end if ! clubb_at_least_debug_level 1 - - end if ! n /= 0 and n /= stats_tout/stats_tsamp - - end do ! k = 1 .. zm%kk - end do ! i = 1 .. zm%nn - - if ( LH_microphys_type /= LH_microphys_disabled ) then - ! Look for errors by checking the number of sampling points - ! for each variable in the LH_zt statistics at each vertical level. - do i = 1, LH_zt%nn - do k = 1, LH_zt%kk - - if ( LH_zt%n(1,1,k,i) /= 0 .and. & - LH_zt%n(1,1,k,i) /= floor( stats_tout/stats_tsamp ) .and. & - LH_zt%n(1,1,k,i) /= LH_microphys_calls * 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(LH_zt%f%var(i)%name), ' in LH_zt ', & - 'at k = ', k, & - '; LH_zt%n(',k,',',i,') = ', LH_zt%n(1,1,k,i) - end if ! clubb_at_lest_debug_level 1 - - end if ! n /= 0 and n /= LH_microphys_calls * stats_tout/stats_tsamp - - end do ! k = 1 .. LH_zt%kk - end do ! i = 1 .. LH_zt%nn - - ! Look for errors by checking the number of sampling points - ! for each variable in the LH_zt statistics at each vertical level. - do i = 1, LH_sfc%nn - do k = 1, LH_sfc%kk - - if ( LH_sfc%n(1,1,k,i) /= 0 .and. & - LH_sfc%n(1,1,k,i) /= floor( stats_tout/stats_tsamp ) .and. & - LH_sfc%n(1,1,k,i) /= LH_microphys_calls * 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(LH_sfc%f%var(i)%name), ' in LH_sfc ', & - 'at k = ', k, & - '; LH_sfc%n(',k,',',i,') = ', LH_sfc%n(1,1,k,i) - end if ! clubb_at_lest_debug_level 1 - - end if ! n /= 0 and n /= LH_microphys_calls * stats_tout/stats_tsamp - - end do ! k = 1 .. LH_sfc%kk - end do ! i = 1 .. LH_sfc%nn - end if ! LH_microphys_type /= LH_microphys_disabled - - - 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, rad_zt%nn - do k = 1, rad_zt%kk - - if ( rad_zt%n(1,1,k,i) /= 0 .and. & - rad_zt%n(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(rad_zt%f%var(i)%name), ' in rad_zt ', & - 'at k = ', k, & - '; rad_zt%n(',k,',',i,') = ', rad_zt%n(1,1,k,i) - end if ! clubb_at_lest_debug_level 1 - - end if ! n /= 0 and n /= stats_tout/stats_tsamp - - end do ! k = 1 .. rad_zt%kk - end do ! i = 1 .. rad_zt%nn - - ! 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, rad_zm%nn - do k = 1, rad_zm%kk - - if ( rad_zm%n(1,1,k,i) /= 0 .and. & - rad_zm%n(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(rad_zm%f%var(i)%name), ' in rad_zm ', & - 'at k = ', k, & - '; rad_zm%n(',k,',',i,') = ', rad_zm%n(1,1,k,i) - end if ! clubb_at_lest_debug_level 1 - - end if ! n /= 0 and n /= stats_tout/stats_tsamp - - end do ! k = 1 .. rad_zm%kk - end do ! i = 1 .. rad_zm%nn - - 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, sfc%nn - do k = 1, sfc%kk - - if ( sfc%n(1,1,k,i) /= 0 .and. & - sfc%n(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(sfc%f%var(i)%name), ' in sfc ', & - 'at k = ', k, & - '; sfc%n(',k,',',i,') = ', sfc%n(1,1,k,i) - end if ! clubb_at_lest_debug_level 1 - - end if ! n /= 0 and n /= stats_tout/stats_tsamp - - end do ! k = 1 .. sfc%kk - end do ! i = 1 .. sfc%nn - - ! 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( zt%kk, zt%nn, zt%x, zt%n ) - call stats_avg( zm%kk, zm%nn, zm%x, zm%n ) - if ( LH_microphys_type /= LH_microphys_disabled ) then - call stats_avg( LH_zt%kk, LH_zt%nn, LH_zt%x, LH_zt%n ) - call stats_avg( LH_sfc%kk, LH_sfc%nn, LH_sfc%x, LH_sfc%n ) - end if - if ( l_output_rad_files ) then - call stats_avg( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n ) - call stats_avg( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n ) - end if - call stats_avg( sfc%kk, sfc%nn, sfc%x, sfc%n ) - - ! Write to file - if ( l_grads ) then - call write_grads( zt%f ) - call write_grads( zm%f ) - if ( LH_microphys_type /= LH_microphys_disabled ) then - call write_grads( LH_zt%f ) - call write_grads( LH_sfc%f ) - end if - if ( l_output_rad_files ) then - call write_grads( rad_zt%f ) - call write_grads( rad_zm%f ) - end if - call write_grads( sfc%f ) - else ! l_netcdf -#ifdef NETCDF - call write_netcdf( zt%f ) - call write_netcdf( zm%f ) - if ( LH_microphys_type /= LH_microphys_disabled ) then - call write_netcdf( LH_zt%f ) - call write_netcdf( LH_sfc%f ) - end if - if ( l_output_rad_files ) then - call write_netcdf( rad_zt%f ) - call write_netcdf( rad_zm%f ) - end if - call write_netcdf( sfc%f ) -#else - stop "This program was not compiled with netCDF support" -#endif /* NETCDF */ - end if ! l_grads - - ! Reset sample fields - call stats_zero( zt%kk, zt%nn, zt%x, zt%n, zt%l_in_update ) - call stats_zero( zm%kk, zm%nn, zm%x, zm%n, zm%l_in_update ) - if ( LH_microphys_type /= LH_microphys_disabled ) then - call stats_zero( LH_zt%kk, LH_zt%nn, LH_zt%x, LH_zt%n, LH_zt%l_in_update ) - call stats_zero( LH_sfc%kk, LH_sfc%nn, LH_sfc%x, LH_sfc%n, LH_sfc%l_in_update ) - end if - if ( l_output_rad_files ) then - call stats_zero( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n, rad_zt%l_in_update ) - call stats_zero( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n, rad_zm%l_in_update ) - end if - call stats_zero( sfc%kk, sfc%nn, sfc%x, sfc%n, sfc%l_in_update ) - - - return - end subroutine stats_end_timestep - - !---------------------------------------------------------------------- - subroutine stats_accumulate & - ( um, vm, upwp, vpwp, up2, vp2, & - thlm, rtm, wprtp, wpthlp, & - wp2, wp3, rtp2, thlp2, 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 crmx_stats_variables, only: & - zt, & ! Variables - zm, & - 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 crmx_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 crmx_stats_variables, only: & - iwp2thvp, & ! Variable(s) - iwp2rcp, & - iwprtpthlp, & - isigma_sqd_w_zt, & - irho, & - irsat, & - irsati - - use crmx_stats_variables, only: & - imixt_frac, & ! Variable(s) - iw1, & - iw2, & - ivarnce_w1, & - ivarnce_w2, & - ithl1, & - ithl2, & - ivarnce_thl1, & - ivarnce_thl2, & - irt1, & - irt2, & - ivarnce_rt1, & - ivarnce_rt2, & - irc1, & - irc2, & - irsl1, & - irsl2, & - icloud_frac1, & - icloud_frac2 - - use crmx_stats_variables, only: & - is1, & - is2, & - istdev_s1, & - istdev_s2, & - istdev_t1, & - istdev_t2, & - icovar_st_1, & - icovar_st_2, & - icorr_st_1, & - icorr_st_2, & - icrt1, & - icrt2, & - icthl1, & - icthl2, & - irrtthl, & - is_mellor - - use crmx_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, & - ithlp2, & - irtpthlp, & - iwprtp, & - iwpthlp, & - iwp4, & - iwpthvp, & - irtpthvp - - use crmx_stats_variables, only: & - ithlpthvp, & - 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 crmx_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 crmx_stats_variables, only: & - isclrm, & ! Variable(s) - isclrm_f, & - iedsclrm, & - iedsclrm_f, & - isclrprtp, & - isclrp2, & - isclrpthvp, & - isclrpthlp, & - isclrprcp, & - iwpsclrp, & - iwp2sclrp, & - iwpsclrp2, & - iwpsclrprtp, & - iwpsclrpthlp, & - iwpedsclrp - - use crmx_stats_variables, only: & - icloud_frac_zm, & - iice_supersat_frac_zm, & - ircm_zm, & - irtm_zm, & - ithlm_zm - - use crmx_stats_variables, only: & - iwp3_on_wp2, & - iwp3_on_wp2_zt, & - iSkw_velocity - - use crmx_stats_variables, only: & - ia3_coef, & ! Variables - ia3_coef_zt - - use crmx_grid_class, only: & - gr ! Variable - - use crmx_grid_class, only: & - zt2zm ! Procedure(s) - - use crmx_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 crmx_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 crmx_variables_diagnostic_module, only: & - a3_coef, & ! Variable(s) - a3_coef_zt, & - wp3_zm, & - wp3_on_wp2, & - wp3_on_wp2_zt, & - Skw_velocity - - use crmx_pdf_parameter_module, only: & - pdf_parameter ! Type - - use crmx_T_in_K_module, only: & - thlm2T_in_K ! Procedure - - use crmx_constants_clubb, only: & - rc_tol, & ! Constant(s) - w_tol_sqd - - use crmx_parameters_model, only: & - sclr_dim, & ! Variable(s) - edsclr_dim - - use crmx_stats_type, only: & - stat_update_var, & ! Procedure(s) - stat_update_var_pt - - use crmx_fill_holes, only: & - vertical_avg, & ! Procedure(s) - vertical_integral - - use crmx_interpolation, only: & - lin_int ! Procedure - - use crmx_saturation, only: & - sat_mixrat_ice ! Procedure - - use crmx_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] - thlp2, & ! thl'^2 [K^2] - 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 :: i, 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] - s_mellor ! Mellor's 's' [kg/kg] - - real( kind = core_rknd ) :: xtmp - - ! ---- Begin Code ---- - - ! Sample fields - - if ( l_stats_samp ) then - - ! 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, zt ) - - call stat_update_var( ithlm, thlm, zt ) - call stat_update_var( ithvm, thvm, zt ) - call stat_update_var( irtm, rtm, zt ) - call stat_update_var( ircm, rcm, zt ) - call stat_update_var( ium, um, zt ) - call stat_update_var( ivm, vm, zt ) - call stat_update_var( iwm_zt, wm_zt, zt ) - call stat_update_var( iwm_zm, wm_zm, zm ) - call stat_update_var( iug, ug, zt ) - call stat_update_var( ivg, vg, zt ) - call stat_update_var( icloud_frac, cloud_frac, zt ) - call stat_update_var( iice_supersat_frac, ice_supersat_frac, zt) - call stat_update_var( ircm_in_layer, rcm_in_layer, zt ) - call stat_update_var( icloud_cover, cloud_cover, zt ) - call stat_update_var( ip_in_Pa, p_in_Pa, zt ) - call stat_update_var( iexner, exner, zt ) - call stat_update_var( irho_ds_zt, rho_ds_zt, zt ) - call stat_update_var( ithv_ds_zt, thv_ds_zt, zt ) - call stat_update_var( iLscale, Lscale, zt ) - call stat_update_var( iwp3, wp3, zt ) - call stat_update_var( iwpthlp2, wpthlp2, zt ) - call stat_update_var( iwp2thlp, wp2thlp, zt ) - call stat_update_var( iwprtp2, wprtp2, zt ) - call stat_update_var( iwp2rtp, wp2rtp, zt ) - call stat_update_var( iLscale_up, Lscale_up, zt ) - call stat_update_var( iLscale_down, Lscale_down, zt ) - call stat_update_var( itau_zt, tau_zt, zt ) - call stat_update_var( iKh_zt, Kh_zt, zt ) - call stat_update_var( iwp2thvp, wp2thvp, zt ) - call stat_update_var( iwp2rcp, wp2rcp, zt ) - call stat_update_var( iwprtpthlp, wprtpthlp, zt ) - call stat_update_var( isigma_sqd_w_zt, sigma_sqd_w_zt, zt ) - call stat_update_var( irho, rho, zt ) - call stat_update_var( irsat, rsat, zt ) - if ( irsati > 0 ) then - rsati = sat_mixrat_ice( p_in_Pa, T_in_K ) - call stat_update_var( irsati, rsati, zt ) - end if - - call stat_update_var( imixt_frac, pdf_params%mixt_frac, zt ) - call stat_update_var( iw1, pdf_params%w1, zt ) - call stat_update_var( iw2, pdf_params%w2, zt ) - call stat_update_var( ivarnce_w1, pdf_params%varnce_w1, zt ) - call stat_update_var( ivarnce_w2, pdf_params%varnce_w2, zt ) - call stat_update_var( ithl1, pdf_params%thl1, zt ) - call stat_update_var( ithl2, pdf_params%thl2, zt ) - call stat_update_var( ivarnce_thl1, pdf_params%varnce_thl1, zt ) - call stat_update_var( ivarnce_thl2, pdf_params%varnce_thl2, zt ) - call stat_update_var( irt1, pdf_params%rt1, zt ) - call stat_update_var( irt2, pdf_params%rt2, zt ) - call stat_update_var( ivarnce_rt1, pdf_params%varnce_rt1, zt ) - call stat_update_var( ivarnce_rt2, pdf_params%varnce_rt2, zt ) - call stat_update_var( irc1, pdf_params%rc1, zt ) - call stat_update_var( irc2, pdf_params%rc2, zt ) - call stat_update_var( irsl1, pdf_params%rsl1, zt ) - call stat_update_var( irsl2, pdf_params%rsl2, zt ) - call stat_update_var( icloud_frac1, pdf_params%cloud_frac1, zt ) - call stat_update_var( icloud_frac2, pdf_params%cloud_frac2, zt ) - call stat_update_var( is1, pdf_params%s1, zt ) - call stat_update_var( is2, pdf_params%s2, zt ) - call stat_update_var( istdev_s1, pdf_params%stdev_s1, zt ) - call stat_update_var( istdev_s2, pdf_params%stdev_s2, zt ) - call stat_update_var( istdev_t1, pdf_params%stdev_t1, zt ) - call stat_update_var( istdev_t2, pdf_params%stdev_t2, zt ) - call stat_update_var( icovar_st_1, pdf_params%covar_st_1, zt ) - call stat_update_var( icovar_st_2, pdf_params%covar_st_2, zt ) - call stat_update_var( icorr_st_1, pdf_params%corr_st_1, zt ) - call stat_update_var( icorr_st_2, pdf_params%corr_st_2, zt ) - call stat_update_var( irrtthl, pdf_params%rrtthl, zt ) - call stat_update_var( icrt1, pdf_params%crt1, zt ) - call stat_update_var( icrt2, pdf_params%crt2, zt ) - call stat_update_var( icthl1, pdf_params%cthl1, zt ) - call stat_update_var( icthl2, pdf_params%cthl2, zt ) - call stat_update_var( iwp2_zt, wp2_zt, zt ) - call stat_update_var( ithlp2_zt, thlp2_zt, zt ) - call stat_update_var( iwpthlp_zt, wpthlp_zt, zt ) - call stat_update_var( iwprtp_zt, wprtp_zt, zt ) - call stat_update_var( irtp2_zt, rtp2_zt, zt ) - call stat_update_var( irtpthlp_zt, rtpthlp_zt, zt ) - call stat_update_var( iup2_zt, up2_zt, zt ) - call stat_update_var( ivp2_zt, vp2_zt, zt ) - call stat_update_var( iupwp_zt, upwp_zt, zt ) - call stat_update_var( ivpwp_zt, vpwp_zt, zt ) - call stat_update_var( ia3_coef_zt, a3_coef_zt, zt ) - call stat_update_var( iwp3_on_wp2_zt, wp3_on_wp2_zt, zt ) - - if ( is_mellor > 0 ) then - ! Determine 's' from Mellor (1977) (extended liquid water) - s_mellor(:) = pdf_params%mixt_frac * pdf_params%s1 & - + (1.0_core_rknd-pdf_params%mixt_frac) * pdf_params%s2 - call stat_update_var( is_mellor, s_mellor, zt ) - end if - - if ( sclr_dim > 0 ) then - do i=1, sclr_dim - call stat_update_var( isclrm(i), sclrm(:,i), zt ) - call stat_update_var( isclrm_f(i), sclrm_forcing(:,i), zt ) - end do - end if - - if ( edsclr_dim > 0 ) then - do i=1, edsclr_dim - call stat_update_var( iedsclrm(i), edsclrm(:,i), zt ) - call stat_update_var( iedsclrm_f(i), edsclrm_forcing(:,i), zt ) - end do - end if - - ! zm variables - - call stat_update_var( iwp2, wp2, zm ) - call stat_update_var( iwp3_zm, wp3_zm, zm ) - call stat_update_var( irtp2, rtp2, zm ) - call stat_update_var( ithlp2, thlp2, zm ) - call stat_update_var( irtpthlp, rtpthlp, zm ) - call stat_update_var( iwprtp, wprtp, zm ) - call stat_update_var( iwpthlp, wpthlp, zm ) - call stat_update_var( iwp4, wp4, zm ) - call stat_update_var( iwpthvp, wpthvp, zm ) - call stat_update_var( irtpthvp, rtpthvp, zm ) - call stat_update_var( ithlpthvp, thlpthvp, zm ) - call stat_update_var( itau_zm, tau_zm, zm ) - call stat_update_var( iKh_zm, Kh_zm, zm ) - call stat_update_var( iwprcp, wprcp, zm ) - call stat_update_var( irc_coef, rc_coef, zm ) - call stat_update_var( ithlprcp, thlprcp, zm ) - call stat_update_var( irtprcp, rtprcp, zm ) - call stat_update_var( ircp2, rcp2, zm ) - call stat_update_var( iupwp, upwp, zm ) - call stat_update_var( ivpwp, vpwp, zm ) - call stat_update_var( ivp2, vp2, zm ) - call stat_update_var( iup2, up2, zm ) - call stat_update_var( irho_zm, rho_zm, zm ) - call stat_update_var( isigma_sqd_w, sigma_sqd_w, zm ) - call stat_update_var( irho_ds_zm, rho_ds_zm, zm ) - call stat_update_var( ithv_ds_zm, thv_ds_zm, zm ) - call stat_update_var( iem, em, zm ) - call stat_update_var( iFrad, Frad, zm ) - - call stat_update_var( iSkw_velocity, Skw_velocity, zm ) - call stat_update_var( ia3_coef, a3_coef, zm ) - call stat_update_var( iwp3_on_wp2, wp3_on_wp2, zm ) - - call stat_update_var( icloud_frac_zm, cloud_frac_zm, zm ) - call stat_update_var( iice_supersat_frac_zm, ice_supersat_frac_zm, zm ) - call stat_update_var( ircm_zm, rcm_zm, zm ) - call stat_update_var( irtm_zm, rtm_zm, zm ) - call stat_update_var( ithlm_zm, thlm_zm, zm ) - - if ( sclr_dim > 0 ) then - do i=1, sclr_dim - call stat_update_var( isclrp2(i), sclrp2(:,i), zm ) - call stat_update_var( isclrprtp(i), sclrprtp(:,i), zm ) - call stat_update_var( isclrpthvp(i), sclrpthvp(:,i), zm ) - call stat_update_var( isclrpthlp(i), sclrpthlp(:,i), zm ) - call stat_update_var( isclrprcp(i), sclrprcp(:,i), zm ) - call stat_update_var( iwpsclrp(i), wpsclrp(:,i), zm ) - call stat_update_var( iwp2sclrp(i), wp2sclrp(:,i), zm ) - call stat_update_var( iwpsclrp2(i), wpsclrp2(:,i), zm ) - call stat_update_var( iwpsclrprtp(i), wpsclrprtp(:,i), zm ) - call stat_update_var( iwpsclrpthlp(i), wpsclrpthlp(:,i), zm ) - end do - end if - if ( edsclr_dim > 0 ) then - do i=1, edsclr_dim - call stat_update_var( iwpedsclrp(i), wpedsclrp(:,i), 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, zm ) - - ! sfc variables - - ! Cloud cover - call stat_update_var_pt( icc, 1, maxval( cloud_frac(1:gr%nz) ), 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_int( rc_tol, rcm(k), & - rcm(k-1), gr%zt(k), gr%zt(k-1) ), sfc ) - - else - - ! Set the cloud base output to -10m, if it's clear. - call stat_update_var_pt( iz_cloud_base, 1, -10.0_core_rknd , sfc ) ! Known magic number - - 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, 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, 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) ), & - 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) ), & - 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) ), & - 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) ), & - 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) ), & - 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) ), & - 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) ), & - 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) ), & - 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) ), & - 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 crmx_parameters_model, only: & - hydromet_dim ! Variable(s) - - use crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_array_index, only: & - iirrainm, iirsnowm, iiricem, iirgraupelm, & ! Variable(s) - iiNrm, iiNsnowm, iiNim, iiNgraupelm - - use crmx_stats_variables, only: & - sfc, & ! Variable(s) - irrainm, & - irsnowm, & - iricem, & - irgraupelm, & - iNim, & - iNrm, & - iNsnowm, & - iNgraupelm, & - iswp, & - irwp, & - iiwp - - use crmx_fill_holes, only: & - vertical_integral ! Procedure(s) - - use crmx_stats_type, only: & - stat_update_var, & ! Procedure(s) - stat_update_var_pt - - use crmx_stats_variables, only: & - zt, & ! Variables - l_stats_samp - - use crmx_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 ( iirrainm > 0 ) then - call stat_update_var( irrainm, hydromet(:,iirrainm), zt ) - end if - - if ( iirsnowm > 0 ) then - call stat_update_var( irsnowm, hydromet(:,iirsnowm), zt ) - end if - - if ( iiricem > 0 ) then - call stat_update_var( iricem, hydromet(:,iiricem), zt ) - end if - - if ( iirgraupelm > 0 ) then - call stat_update_var( irgraupelm, & - hydromet(:,iirgraupelm), zt ) - end if - - if ( iiNim > 0 ) then - call stat_update_var( iNim, hydromet(:,iiNim), zt ) - end if - - if ( iiNrm > 0 ) then - call stat_update_var( iNrm, hydromet(:,iiNrm), zt ) - end if - - if ( iiNsnowm > 0 ) then - call stat_update_var( iNsnowm, hydromet(:,iiNsnowm), zt ) - end if - - if ( iiNgraupelm > 0 ) then - call stat_update_var( iNgraupelm, hydromet(:,iiNgraupelm), zt ) - end if - - ! Snow Water Path - if ( iswp > 0 .and. iirsnowm > 0 ) then - - ! Calculate snow water path - xtmp & - = vertical_integral & - ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - hydromet(2:gr%nz,iirsnowm), gr%invrs_dzt(2:gr%nz) ) - - call stat_update_var_pt( iswp, 1, xtmp, sfc ) - - end if ! iswp > 0 .and. iirsnowm > 0 - - ! Ice Water Path - if ( iiwp > 0 .and. iiricem > 0 ) then - - xtmp & - = vertical_integral & - ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - hydromet(2:gr%nz,iiricem), gr%invrs_dzt(2:gr%nz) ) - - call stat_update_var_pt( iiwp, 1, xtmp, sfc ) - - end if - - ! Rain Water Path - if ( irwp > 0 .and. iirrainm > 0 ) then - - xtmp & - = vertical_integral & - ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & - hydromet(2:gr%nz,iirrainm), gr%invrs_dzt(2:gr%nz) ) - - call stat_update_var_pt( irwp, 1, xtmp, sfc ) - - end if ! irwp > 0 .and. irrainm > 0 - end if ! l_stats_samp - - return - end subroutine stats_accumulate_hydromet -!------------------------------------------------------------------------------ - subroutine stats_accumulate_LH_tend( LH_hydromet_mc, LH_thlm_mc, LH_rvm_mc, LH_rcm_mc ) -! Description: -! Compute stats for the tendency of latin hypercube sample points. - -! References: -! None -!------------------------------------------------------------------------------ - use crmx_parameters_model, only: & - hydromet_dim ! Variable(s) - - use crmx_grid_class, only: & - gr ! Variable(s) - - use crmx_array_index, only: & - iirrainm, iirsnowm, iiricem, iirgraupelm, & ! Variable(s) - iiNrm, iiNsnowm, iiNim, iiNgraupelm, iiNcm - - use crmx_stats_variables, only: & - iLH_rrainm_mc, & ! Variable(s) - iLH_rsnowm_mc, & - iLH_ricem_mc, & - iLH_rgraupelm_mc, & - iLH_Ncm_mc, & - iLH_Nim_mc, & - iLH_Nrm_mc, & - iLH_Nsnowm_mc, & - iLH_Ngraupelm_mc, & - iLH_rcm_mc, & - iLH_rvm_mc, & - iLH_thlm_mc - - use crmx_stats_variables, only: & - iAKstd, & ! Variable(s) - iAKstd_cld, & - iAKm_rcm, & - iAKm_rcc, & - iAKm, & - iLH_AKm, & - iLH_rcm_avg - - use crmx_variables_diagnostic_module, only: & - AKm, & ! Variable(s) - lh_AKm, & - AKstd, & - lh_rcm_avg, & - AKstd_cld, & - AKm_rcm, & - AKm_rcc - - use crmx_stats_type, only: & - stat_update_var ! Procedure(s) - - use crmx_stats_variables, only: & - LH_zt, & ! Variables - l_stats_samp - - use crmx_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_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, LH_zt ) - call stat_update_var( iLH_rcm_mc, LH_rcm_mc, LH_zt ) - call stat_update_var( iLH_rvm_mc, LH_rvm_mc, LH_zt ) - - if ( iiNcm > 0 ) then - call stat_update_var( iLH_Ncm_mc, LH_hydromet_mc(:,iiNcm), LH_zt ) - end if - - if ( iirrainm > 0 ) then - call stat_update_var( iLH_rrainm_mc, LH_hydromet_mc(:,iirrainm), LH_zt ) - end if - - if ( iirsnowm > 0 ) then - call stat_update_var( iLH_rsnowm_mc, LH_hydromet_mc(:,iirsnowm), LH_zt ) - end if - - if ( iiricem > 0 ) then - call stat_update_var( iLH_ricem_mc, LH_hydromet_mc(:,iiricem), LH_zt ) - end if - - if ( iirgraupelm > 0 ) then - call stat_update_var( iLH_rgraupelm_mc, LH_hydromet_mc(:,iirgraupelm), LH_zt ) - end if - - if ( iiNim > 0 ) then - call stat_update_var( iLH_Nim_mc, LH_hydromet_mc(:,iiNim), LH_zt ) - end if - - if ( iiNrm > 0 ) then - call stat_update_var( iLH_Nrm_mc, LH_hydromet_mc(:,iiNrm), LH_zt ) - end if - - if ( iiNsnowm > 0 ) then - call stat_update_var( iLH_Nsnowm_mc, LH_hydromet_mc(:,iiNsnowm), LH_zt ) - end if - - if ( iiNgraupelm > 0 ) then - call stat_update_var( iLH_Ngraupelm_mc, LH_hydromet_mc(:,iiNgraupelm), LH_zt ) - end if - - call stat_update_var( iAKm, AKm, LH_zt ) - call stat_update_var( iLH_AKm, lh_AKm, LH_zt) - call stat_update_var( iLH_rcm_avg, lh_rcm_avg, LH_zt ) - call stat_update_var( iAKstd, AKstd, LH_zt ) - call stat_update_var( iAKstd_cld, AKstd_cld, LH_zt ) - - call stat_update_var( iAKm_rcm, AKm_rcm, LH_zt) - call stat_update_var( iAKm_rcc, AKm_rcc, 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 crmx_stats_variables, only: & - zt, & ! Variable(s) - LH_zt, & - LH_sfc, & - zm, & - rad_zt, & - rad_zm, & - sfc, & - l_netcdf, & - l_stats, & - l_output_rad_files - - use crmx_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 crmx_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: & - ! radscr01, & ! Variable(s) - ! radscr02, & - ! radscr03, & - ! radscr04, & - ! radscr05, & - ! radscr06, & - ! radscr07, & - ! radscr08, & - ! radscr09, & - ! radscr10, & - ! radscr11, & - ! radscr12, & - ! radscr13, & - ! radscr14, & - ! radscr15, & - ! radscr16, & - ! radscr17 - - use crmx_stats_variables, only: & - isclrm, & - isclrm_f, & - iedsclrm, & - iedsclrm_f, & - isclrprtp, & - isclrp2, & - isclrpthvp, & - isclrpthlp, & - isclrprcp, & - iwpsclrp, & - iwp2sclrp, & - iwpsclrp2, & - iwpsclrprtp, & - iwpsclrpthlp, & - iwpedsclrp - - use crmx_parameters_microphys, only: & - LH_microphys_disabled ! Constant(s) - - use crmx_parameters_microphys, only: & - LH_microphys_type ! Variable(s) - -#ifdef NETCDF - use crmx_output_netcdf, only: & - close_netcdf ! Procedure -#endif - - implicit none - - if ( l_stats .and. l_netcdf ) then -#ifdef NETCDF - call close_netcdf( zt%f ) - call close_netcdf( LH_zt%f ) - call close_netcdf( LH_sfc%f ) - call close_netcdf( zm%f ) - call close_netcdf( rad_zt%f ) - call close_netcdf( rad_zm%f ) - call close_netcdf( sfc%f ) -#else - stop "This program was not compiled with netCDF support" -#endif - end if - - if ( l_stats ) then - ! De-allocate all zt variables - deallocate( zt%z ) - - deallocate( zt%x ) - - deallocate( zt%n ) - deallocate( zt%l_in_update ) - - - deallocate( zt%f%var ) - deallocate( zt%f%z ) - deallocate( zt%f%rlat ) - deallocate( zt%f%rlon ) - - 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 ) - - if ( LH_microphys_type /= LH_microphys_disabled ) then - ! De-allocate all LH_zt variables - deallocate( LH_zt%z ) - - deallocate( LH_zt%x ) - - deallocate( LH_zt%n ) - deallocate( LH_zt%l_in_update ) - - - deallocate( LH_zt%f%var ) - deallocate( LH_zt%f%z ) - deallocate( LH_zt%f%rlat ) - deallocate( LH_zt%f%rlon ) - - ! De-allocate all LH_sfc variables - deallocate( LH_sfc%z ) - - deallocate( LH_sfc%x ) - - deallocate( LH_sfc%n ) - deallocate( LH_sfc%l_in_update ) - - - deallocate( LH_sfc%f%var ) - deallocate( LH_sfc%f%z ) - deallocate( LH_sfc%f%rlat ) - deallocate( LH_sfc%f%rlon ) - end if - - ! De-allocate all zm variables - deallocate( zm%z ) - - deallocate( zm%x ) - deallocate( zm%n ) - - deallocate( zm%f%var ) - deallocate( zm%f%z ) - deallocate( zm%f%rlat ) - deallocate( zm%f%rlon ) - deallocate( 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 ) - - if (l_output_rad_files) then - ! De-allocate all rad_zt variables - deallocate( rad_zt%z ) - - deallocate( rad_zt%x ) - deallocate( rad_zt%n ) - - deallocate( rad_zt%f%var ) - deallocate( rad_zt%f%z ) - deallocate( rad_zt%f%rlat ) - deallocate( rad_zt%f%rlon ) - deallocate( rad_zt%l_in_update ) - - ! De-allocate all rad_zm variables - deallocate( rad_zm%z ) - - deallocate( rad_zm%x ) - deallocate( rad_zm%n ) - - deallocate( rad_zm%f%var ) - deallocate( rad_zm%f%z ) - deallocate( rad_zm%l_in_update ) - - !deallocate ( radscr01 ) - !deallocate ( radscr02 ) - !deallocate ( radscr03 ) - !deallocate ( radscr04 ) - !deallocate ( radscr05 ) - !deallocate ( radscr06 ) - !deallocate ( radscr07 ) - !deallocate ( radscr08 ) - !deallocate ( radscr09 ) - !deallocate ( radscr10 ) - !deallocate ( radscr11 ) - !deallocate ( radscr12 ) - !deallocate ( radscr13 ) - !deallocate ( radscr14 ) - !deallocate ( radscr15 ) - !deallocate ( radscr16 ) - !deallocate ( radscr17 ) - end if ! l_output_rad_files - - ! De-allocate all sfc variables - deallocate( sfc%z ) - - deallocate( sfc%x ) - deallocate( sfc%n ) - deallocate( sfc%l_in_update ) - - deallocate( sfc%f%var ) - deallocate( sfc%f%z ) - deallocate( sfc%f%rlat ) - deallocate( sfc%f%rlon ) - - ! De-allocate scalar indices - 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 ! l_stats - - - return - end subroutine stats_finalize - -!=============================================================================== - -end module crmx_stats_subs diff --git a/src/physics/spcam/crm/CLUBB/crmx_stats_type.F90 b/src/physics/spcam/crm/CLUBB/crmx_stats_type.F90 deleted file mode 100644 index f9c27a287e..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stats_type.F90 +++ /dev/null @@ -1,524 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_type.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module crmx_stats_type - - ! Description: - ! Contains derived data type 'stats'. - ! Used for storing output statistics to disk. - !----------------------------------------------------------------------- - - use crmx_stat_file_module, only: & - stat_file ! Type - - use crmx_clubb_precision, only: & - stat_rknd, & ! Variable(s) - stat_nknd, & - core_rknd - - implicit none - - private ! Set Default Scope - - public :: stats, & - 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 - - ! Derived data types to store GrADS/netCDF statistics - type stats - - ! Number of fields to sample - integer :: nn - - ! Vertical extent of variable - integer :: kk - - ! Vertical levels - real( kind = core_rknd ), pointer, dimension(:) :: z - - ! Array to store sampled fields - - real(kind=stat_rknd), pointer, dimension(:,:,:,:) :: x - - integer(kind=stat_nknd), pointer, dimension(:,:,:,:) :: n - - ! Tracks if a field is in the process of an update - logical, pointer, dimension(:,:,:,:) :: l_in_update - - ! Data for GrADS / netCDF output - - type (stat_file) f - - end type stats - - contains - - !============================================================================= - subroutine stat_assign( var_index, var_name, & - var_description, var_units, grid_kind ) - - ! Description: - ! Assigns pointers for statistics variables in grid. - !----------------------------------------------------------------------- - - 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 [] - - ! Output Variable - - ! Which grid the variable is located on (zt, zm, or sfc ) - type(stats), intent(inout) :: grid_kind - - grid_kind%f%var(var_index)%ptr => grid_kind%x(:,:,:,var_index) - grid_kind%f%var(var_index)%name = var_name - grid_kind%f%var(var_index)%description = var_description - grid_kind%f%var(var_index)%units = var_units - - !Example of the old format - !changed by Joshua Fasching 23 August 2007 - - !zt%f%var(ithlm)%ptr => zt%x(:,k) - !zt%f%var(ithlm)%name = "thlm" - !zt%f%var(ithlm)%description = "thetal (K)" - !zt%f%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 crmx_clubb_precision, only: & - stat_rknd ! Constant - - 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%x(1,1,k,var_index) = & - grid_kind%x(1,1,k,var_index) + real( value(k), kind=stat_rknd ) - grid_kind%n(1,1,k,var_index) = & - grid_kind%n(1,1,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 crmx_clubb_precision, only: & - stat_rknd ! Constant - - 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%x(1,1,grid_level,var_index) = grid_kind%x(1,1,grid_level,var_index) & - + real( value, kind=stat_rknd ) - - grid_kind%n(1,1,grid_level,var_index) = grid_kind%n(1,1,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), zt ) - ! - ! !!! Perform clipping of rtm !!! - ! - ! call stat_end_update( irtm_bt, real(rtm / dt), 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 crmx_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 crmx_error_code, only: clubb_debug ! Procedure(s) - - use crmx_clubb_precision, only: & - stat_rknd ! Constant - - 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? - - if ( .not. grid_kind%l_in_update(1,1,grid_level,var_index) ) then ! Can we begin an update? - - grid_kind%x(1,1,grid_level, var_index) = & - grid_kind%x(1,1,grid_level, var_index) - real( value, kind=stat_rknd ) - - grid_kind%l_in_update(1,1,grid_level, var_index) = .true. ! Start Record - - else - - call clubb_debug( 1, & - "Beginning an update before finishing previous for variable: "// & - trim( grid_kind%f%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), zt ) - ! - ! !!! Perform clipping of rtm !!! - ! - ! call stat_end_update( irtm_bt, real(rtm / dt), 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 crmx_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 - - ! ---- Begin Code ---- - - do i = 1,gr%nz - call stat_end_update_pt & - ( var_index, i, value(i), 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 crmx_error_code, only: clubb_debug ! Procedure(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? - - if ( grid_kind%l_in_update(1,1,grid_level,var_index) ) then ! Can we end an update? - - call stat_update_var_pt & - ( var_index, grid_level, value, grid_kind ) - - grid_kind%l_in_update(1,1,grid_level,var_index) = .false. ! End Record - - else - - call clubb_debug( 1, "Ending before beginning update. For variable "// & - grid_kind%f%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 crmx_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 - - ! ---- Begin Code ---- - - do i = 1, gr%nz - - call stat_modify_pt( var_index, i, value(i), 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 crmx_clubb_precision, only: & - stat_rknd ! Constant - - 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%x(1,1,grid_level,var_index ) & - = grid_kind%x(1,1,grid_level,var_index ) + real( value, kind=stat_rknd ) - - end if - - return - end subroutine stat_modify_pt - -!=============================================================================== - -end module crmx_stats_type diff --git a/src/physics/spcam/crm/CLUBB/crmx_stats_variables.F90 b/src/physics/spcam/crm/CLUBB/crmx_stats_variables.F90 deleted file mode 100644 index d571408e67..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stats_variables.F90 +++ /dev/null @@ -1,1116 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: stats_variables.F90 6153 2013-04-09 22:13:27Z bmg2@uwm.edu $ -!------------------------------------------------------------------------------- - -! Description: -! Holds pointers and other variables for statistics to be written to -! GrADS files and netCDF files. -!------------------------------------------------------------------------------- -module crmx_stats_variables - - - use crmx_stats_type, only: & - stats ! Type - - use crmx_clubb_precision, only: & - time_precision, & ! Variable - core_rknd - - implicit none - - private ! Set Default Scope - - ! Sampling and output frequencies - real(kind=time_precision), public :: & - stats_tsamp, & ! Sampling interval [s] - stats_tout ! Output interval [s] - -!$omp threadprivate(stats_tsamp, stats_tout) - - logical, public :: & - l_stats, & ! Main flag to turn statistics on/off - l_output_rad_files, & ! Flag to turn off radiation statistics output - l_netcdf, & ! Output to NetCDF format - l_grads ! Output to GrADS format - -!$omp threadprivate(l_stats, l_netcdf, l_grads) - - logical, public :: & - l_stats_samp, & ! Sample flag for current time step - l_stats_last ! 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 zt grid - fname_LH_sfc, & ! Name of the stats file for LH variables on the zt grid - fname_zm, & ! Name of the stats file for momentum grid fields - fname_rad_zt, & ! Name of the stats file for the zt radiation grid fields - fname_rad_zm, & ! Name of the stats file for the zm radiation grid fields - fname_sfc ! Name of the stats file for surface only fields - -!$omp threadprivate(fname_zt, fname_zm, fname_LH_zt, fname_LH_sfc, fname_rad_zt, & -!$omp fname_rad_zm, fname_sfc) - -! Indices for statistics in zt file - - integer, public :: & - ithlm, & - ithvm, & - irtm, & - ircm, & - irvm, & - ium, & - ivm, & - iwm_zt, & - iwm_zm, & - 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, & - iwp3, & - iwpthlp2, & - iwp2thlp, & - iwprtp2, & - iwp2rtp - - integer, public :: & - iLscale_up, & - iLscale_down, & - iLscale_pert_1, & - iLscale_pert_2, & - itau_zt, & - iKh_zt, & - iwp2thvp, & - iwp2rcp, & - iwprtpthlp, & - isigma_sqd_w_zt, & - irho - - integer, public :: & - irr1, & - irr2, & - iNr1, & - iNr2, & - iLWP1, & - iLWP2, & - iprecip_frac, & - iprecip_frac_1, & - iprecip_frac_2 - - integer, public :: & - imu_rr_1, & - imu_rr_2, & - imu_Nr_1, & - imu_Nr_2, & - imu_Nc_1, & - imu_Nc_2, & - imu_rr_1_n, & - imu_rr_2_n, & - imu_Nr_1_n, & - imu_Nr_2_n, & - imu_Nc_1_n, & - imu_Nc_2_n, & - isigma_rr_1, & - isigma_rr_2, & - isigma_Nr_1, & - isigma_Nr_2, & - isigma_Nc_1, & - isigma_Nc_2, & - isigma_rr_1_n, & - isigma_rr_2_n, & - isigma_Nr_1_n, & - isigma_Nr_2_n, & - isigma_Nc_1_n, & - isigma_Nc_2_n - - integer, public :: & - icorr_srr_1, & - icorr_srr_2, & - icorr_sNr_1, & - icorr_sNr_2, & - icorr_sNc_1, & - icorr_sNc_2, & - icorr_trr_1, & - icorr_trr_2, & - icorr_tNr_1, & - icorr_tNr_2, & - icorr_tNc_1, & - icorr_tNc_2, & - icorr_rrNr_1, & - icorr_rrNr_2, & - icorr_srr_1_n, & - icorr_srr_2_n, & - icorr_sNr_1_n, & - icorr_sNr_2_n, & - icorr_sNc_1_n, & - icorr_sNc_2_n, & - icorr_trr_1_n, & - icorr_trr_2_n, & - icorr_tNr_1_n, & - icorr_tNr_2_n, & - icorr_tNc_1_n, & - icorr_tNc_2_n, & - icorr_rrNr_1_n, & - icorr_rrNr_2_n - - integer, public :: & ! janhft 09/25/12 - icorr_sw, & - icorr_wrr, & - icorr_wNr, & - icorr_wNc - - integer, public :: & - iNcm, & ! Brian - iNcnm, & - iNcm_in_cloud, & - iNc_activated, & - isnowslope, & ! Adam Smith, 22 April 2008 - ised_rcm, & ! Brian - irsat, & ! Brian - irsati, & - irrainm, & ! Brian - im_vol_rad_rain, & ! Brian - im_vol_rad_cloud, & ! COAMPS only. dschanen 6 Dec 2006 - irain_rate_zt, & ! Brian - iAKm, & ! analytic Kessler. Vince Larson 22 May 2005 - iLH_AKm, & ! LH Kessler. Vince Larson 22 May 2005 - iradht, & ! Radiative heating. - iradht_LW, & ! " " Long-wave component - iradht_SW, & ! " " Short-wave component - irel_humidity - - integer, public :: & - iAKstd, & - iAKstd_cld, & - iAKm_rcm, & - iAKm_rcc - -!$omp threadprivate(ithlm, ithvm, irtm, ircm, irvm, ium, ivm, ium_ref, ivm_ref, & -!$omp iwm_zt, iwm_zm, iug, ivg, icloud_frac, ircm_in_layer, ircm_in_cloud, icloud_cover, & -!$omp ip_in_Pa, iexner, irho_ds_zt, ithv_ds_zt, iLscale, iwp3, & -!$omp iwpthlp2, iwp2thlp, iwprtp2, iwp2rtp, iLscale_up, iLscale_down, & -!$omp iLscale_pert_1, iLscale_pert_2, & -!$omp itau_zt, iKh_zt, iwp2thvp, iwp2rcp, iwprtpthlp, isigma_sqd_w_zt, irho, & -!$omp irr1, irr2, iNr1, iNr2, iLWP1, iLWP2, & -!$omp iprecip_frac, iprecip_frac_1, iprecip_frac_2, & -!$omp irel_humidity, iNcm, iNcnm, isnowslope, & -!$omp ised_rcm, irsat, irsati, irrainm, & -!$omp im_vol_rad_rain, im_vol_rad_cloud, & -!$omp irain_rate_zt, iAKm, iLH_AKm, & -!$omp iradht, iradht_LW, iradht_SW, & -!$omp iAKstd, iAKstd_cld, iAKm_rcm, iAKm_rcc ) - -!$omp threadprivate( imu_rr_1, imu_rr_2, imu_Nr_1, imu_Nr_2, & -!$omp imu_Nc_1, imu_Nc_2, imu_rr_1_n, imu_rr_2_n, imu_Nr_1_n, imu_Nr_2_n, & -!$omp imu_Nc_1_n, imu_Nc_2_n, isigma_rr_1, isigma_rr_2, isigma_Nr_1, & -!$omp isigma_Nr_2, isigma_Nc_1, isigma_Nc_2, isigma_rr_1_n, isigma_rr_2_n, & -!$omp isigma_Nr_1_n, isigma_Nr_2_n, isigma_Nc_1_n, isigma_Nc_2_n, & -!$omp icorr_srr_1, icorr_srr_2, icorr_sNr_1, icorr_sNr_2, & -!$omp icorr_sNc_1, icorr_sNc_2, icorr_trr_1, icorr_trr_2, & -!$omp icorr_tNr_1, icorr_tNr_2, icorr_tNc_1, icorr_tNc_2, & -!$omp icorr_rrNr_1, icorr_rrNr_2, icorr_srr_1_n, icorr_srr_2_n, & -!$omp icorr_sNr_1_n, icorr_sNr_2_n, icorr_sNc_1_n, icorr_sNc_2_n, & -!$omp icorr_trr_1_n, icorr_trr_2_n, icorr_tNr_1_n, icorr_tNr_2_n, & -!$omp icorr_tNc_1_n, icorr_tNc_2_n, icorr_rrNr_1_n, icorr_rrNr_2_n, & -!$omp icorr_sw, icorr_wrr, icorr_wNr, icorr_wNc ) - - integer, public :: & - irfrzm -!$omp threadprivate(irfrzm) - - ! Skewness functions on zt grid - integer, public :: & - iC11_Skw_fnc - -!$omp threadprivate(iC11_Skw_fnc) - - integer, public :: & - icloud_frac_zm, & - iice_supersat_frac_zm, & - ircm_zm, & - irtm_zm, & - ithlm_zm - -!$omp threadprivate(icloud_frac_zm, ircm_zm, irtm_zm, ithlm_zm) - - integer, public :: & - iLH_rcm_avg - -!$omp threadprivate(iLH_rcm_avg) - - integer, public :: & - iNrm, & ! Rain droplet number concentration - iNim, & ! Ice number concentration - iNsnowm, & ! Snow number concentration - iNgraupelm ! Graupel number concentration -!$omp threadprivate(iNrm, iNim, iNsnowm, iNgraupelm) - - integer, public :: & - iT_in_K ! Absolute temperature -!$omp threadprivate(iT_in_K) - - integer, public :: & - ieff_rad_cloud, & - ieff_rad_ice, & - ieff_rad_snow, & - ieff_rad_rain, & - ieff_rad_graupel - -!$omp threadprivate(ieff_rad_cloud, ieff_rad_ice, ieff_rad_snow) -!$omp threadprivate(ieff_rad_rain, ieff_rad_graupel) - - integer, public :: & - irsnowm, & - irgraupelm, & - iricem, & - idiam, & ! Diameter of ice crystal [m] - imass_ice_cryst, & ! Mass of a single ice crystal [kg] - ircm_icedfs, & ! Change in liquid water due to ice [kg/kg/s] - iu_T_cm ! Fallspeed of ice crystal in cm/s [cm s^{-1}] - -!$omp threadprivate(irsnowm, irgraupelm, iricem, idiam) -!$omp threadprivate(imass_ice_cryst, ircm_icedfs, iu_T_cm) - - - ! thlm/rtm budget terms - integer, public :: & - irtm_bt, & ! rtm total time tendency - irtm_ma, & ! rtm mean advect. term - irtm_ta, & ! rtm turb. advect. term - irtm_forcing, & ! rtm large scale forcing term - irtm_mc, & ! rtm change from microphysics - irtm_sdmp, & ! rtm change from sponge damping - irvm_mc, & ! rvm change from microphysics - ircm_mc, & ! rcm change from microphysics - ircm_sd_mg_morr, & ! rcm sedimentation tendency - irtm_mfl, & ! rtm change due to monotonic flux limiter - irtm_tacl, & ! rtm correction from turbulent advection (wprtp) clipping - irtm_cl, & ! rtm clipping term - irtm_pd, & ! thlm postive definite adj term - ithlm_bt, & ! thlm total time tendency - ithlm_ma, & ! thlm mean advect. term - ithlm_ta, & ! thlm turb. advect. term - ithlm_forcing, & ! thlm large scale forcing term - ithlm_sdmp, & ! thlm change from sponge damping - ithlm_mc, & ! thlm change from microphysics - ithlm_mfl, & ! thlm change due to monotonic flux limiter - ithlm_tacl, & ! thlm correction from turbulent advection (wpthlp) clipping - ithlm_cl ! 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, & - ithlm_mfl_max, & - iwpthlp_entermfl, & - iwpthlp_exit_mfl, & - iwpthlp_mfl_min, & - iwpthlp_mfl_max, & - irtm_mfl_min, & - irtm_mfl_max, & - iwprtp_enter_mfl, & - iwprtp_exit_mfl, & - iwprtp_mfl_min, & - iwprtp_mfl_max, & - ithlm_enter_mfl, & - ithlm_exit_mfl, & - ithlm_old, & - ithlm_without_ta, & - irtm_enter_mfl, & - irtm_exit_mfl, & - irtm_old, & - irtm_without_ta - -!$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, & - iwp3_ma, & - iwp3_ta, & - iwp3_tp, & - iwp3_ac, & - iwp3_bp1, & - iwp3_bp2, & - iwp3_pr1, & - iwp3_pr2, & - iwp3_dp1, & - iwp3_4hd, & - iwp3_cl - -!$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_4hd, iwp3_cl) - - ! Rain mixing ratio budgets - integer, public :: & - irrainm_bt, & - irrainm_ma, & - irrainm_sd, & - irrainm_ts, & - irrainm_sd_morr, & - irrainm_dff, & - irrainm_cond, & - irrainm_auto, & - irrainm_accr, & - irrainm_cond_adj, & - irrainm_src_adj, & - irrainm_tsfl, & - irrainm_mc, & - irrainm_hf, & - irrainm_wvhf, & - irrainm_cl - -!$omp threadprivate(irrainm_bt, irrainm_ma, irrainm_sd, irrainm_ts) -!$omp threadprivate(irrainm_sd_morr, irrainm_dff) -!$omp threadprivate(irrainm_cond, irrainm_auto, irrainm_accr) -!$omp threadprivate(irrainm_cond_adj, irrainm_src_adj, irrainm_tsfl) -!$omp threadprivate(irrainm_mc, irrainm_hf, irrainm_wvhf, irrainm_cl) - - integer, public :: & - iNrm_bt, & - iNrm_ma, & - iNrm_sd, & - iNrm_ts, & - iNrm_dff, & - iNrm_cond, & - iNrm_auto, & - iNrm_cond_adj, & - iNrm_src_adj, & - iNrm_tsfl, & - iNrm_mc, & - iNrm_cl - -!$omp threadprivate(iNrm_bt, iNrm_ma, iNrm_sd, iNrm_ts, iNrm_dff, iNrm_cond) -!$omp threadprivate(iNrm_auto, iNrm_cond_adj, iNrm_src_adj, iNrm_tsfl) -!$omp threadprivate(iNrm_mc, iNrm_cl) - - - ! Snow/Ice/Graupel mixing ratio budgets - integer, public :: & - irsnowm_bt, & - irsnowm_ma, & - irsnowm_sd, & - irsnowm_sd_morr, & - irsnowm_dff, & - irsnowm_mc, & - irsnowm_hf, & - irsnowm_wvhf, & - irsnowm_cl - -!$omp threadprivate(irsnowm_bt, irsnowm_ma, irsnowm_sd, irsnowm_sd_morr, irsnowm_dff) -!$omp threadprivate(irsnowm_mc, irsnowm_hf, irsnowm_wvhf, irsnowm_cl) - - integer, public :: & - irgraupelm_bt, & - irgraupelm_ma, & - irgraupelm_sd, & - irgraupelm_sd_morr, & - irgraupelm_dff, & - irgraupelm_mc, & - irgraupelm_hf, & - irgraupelm_wvhf, & - irgraupelm_cl - -!$omp threadprivate(irgraupelm_bt, irgraupelm_ma, irgraupelm_sd, irgraupelm_sd_morr) -!$omp threadprivate(irgraupelm_dff, irgraupelm_mc) -!$omp threadprivate(irgraupelm_hf, irgraupelm_wvhf, irgraupelm_cl) - - integer, public :: & - iricem_bt, & - iricem_ma, & - iricem_sd, & - iricem_sd_mg_morr, & - iricem_dff, & - iricem_mc, & - iricem_hf, & - iricem_wvhf, & - iricem_cl - -!$omp threadprivate(iricem_bt, iricem_ma, iricem_sd, iricem_sd_mg_morr, iricem_dff) -!$omp threadprivate(iricem_mc, iricem_hf, iricem_wvhf, iricem_cl) - - integer, public :: & - iNsnowm_bt, & - iNsnowm_ma, & - iNsnowm_sd, & - iNsnowm_dff, & - iNsnowm_mc, & - iNsnowm_cl - -!$omp threadprivate(iNsnowm_bt, iNsnowm_ma, iNsnowm_sd, iNsnowm_dff, & -!$omp iNsnowm_mc, iNsnowm_cl) - - integer, public :: & - iNgraupelm_bt, & - iNgraupelm_ma, & - iNgraupelm_sd, & - iNgraupelm_dff, & - iNgraupelm_mc, & - iNgraupelm_cl - -!$omp threadprivate(iNgraupelm_bt, iNgraupelm_ma, iNgraupelm_sd, & -!$omp iNgraupelm_dff, iNgraupelm_mc, iNgraupelm_cl) - - integer, public :: & - iNim_bt, & - iNim_ma, & - iNim_sd, & - iNim_dff, & - iNim_mc, & - iNim_cl - -!$omp threadprivate(iNim_bt, iNim_ma, iNim_sd, iNim_dff, & -!$omp iNim_mc, iNim_cl) - - integer, public :: & - iNcm_bt, & - iNcm_ma, & - iNcm_dff, & - iNcm_mc, & - iNcm_cl, & - iNcm_act - -!$omp threadprivate(iNcm_bt, iNcm_ma, iNcm_dff, & -!$omp iNcm_mc, iNcm_cl) - - ! 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, & ! Covariance of w and KK evaporation tendency. - irt_KK_evap_covar_zt, & ! Covariance of r_t and KK evaporation tendency. - ithl_KK_evap_covar_zt, & ! Covariance of theta_l and KK evap. tendency. - iw_KK_auto_covar_zt, & ! Covariance of w and KK autoconversion tendency. - irt_KK_auto_covar_zt, & ! Covariance of r_t and KK autoconversion tendency. - ithl_KK_auto_covar_zt, & ! Covariance of theta_l and KK autoconv. tendency. - iw_KK_accr_covar_zt, & ! Covariance of w and KK accretion tendency. - irt_KK_accr_covar_zt, & ! Covariance of r_t and KK accretion tendency. - ithl_KK_accr_covar_zt, & ! Covariance of theta_l and KK accretion tendency. - irr_KK_mvr_covar_zt, & ! Covariance of r_r and KK mean volume radius. - iNr_KK_mvr_covar_zt ! Covariance of N_r and KK 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 ) - - ! Wind budgets - integer, public :: & - ivm_bt, & - ivm_ma, & - ivm_ta, & - ivm_gf, & - ivm_cf, & - ivm_f, & - ivm_sdmp, & - ivm_ndg - -!$omp threadprivate(ivm_bt, ivm_ma, ivm_ta, ivm_gf, ivm_cf, ivm_f, ivm_sdmp, ivm_ndg) - - integer, public :: & - ium_bt, & - ium_ma, & - ium_ta, & - ium_gf, & - ium_cf, & - ium_f, & - ium_sdmp, & - ium_ndg - -!$omp threadprivate(ium_bt, ium_ma, ium_ta, ium_gf, ium_cf, ium_f, ium_sdmp, ium_ndg) - - - ! PDF parameters - integer, public :: & - imixt_frac, & - iw1, & - iw2, & - ivarnce_w1, & - ivarnce_w2, & - ithl1, & - ithl2, & - ivarnce_thl1, & - ivarnce_thl2, & - irt1, & - irt2, & - ivarnce_rt1, & - ivarnce_rt2, & - irc1, & - irc2, & - irsl1, & - irsl2, & - icloud_frac1, & - icloud_frac2 - - integer, public :: & - is1, & - is2, & - istdev_s1, & - istdev_s2, & - istdev_t1, & - istdev_t2, & - icovar_st_1, & - icovar_st_2, & - icorr_st_1, & - icorr_st_2, & - irrtthl, & - icrt1, & - icrt2, & - icthl1, & - icthl2 - -!$omp threadprivate(imixt_frac, iw1, iw2, ivarnce_w1, ivarnce_w2, ithl1, ithl2, ivarnce_thl1, & -!$omp ivarnce_thl2, irt1, irt2, ivarnce_rt1, ivarnce_rt2, irc1, irc2, & -!$omp irsl1, irsl2, icloud_frac1, icloud_frac2, is1, is2, istdev_s1, istdev_s2, & -!$omp istdev_t1, istdev_t2, icovar_st_1, icovar_st_2, icorr_st_1, icorr_st_2, irrtthl, & -!$omp icrt1, icrt2, icthl1, icthl2 ) - - integer, public :: & - iwp2_zt, & - ithlp2_zt, & - iwpthlp_zt, & - iwprtp_zt, & - irtp2_zt, & - irtpthlp_zt, & - iup2_zt, & - ivp2_zt, & - iupwp_zt, & - ivpwp_zt - -!$omp threadprivate(iwp2_zt, ithlp2_zt, iwpthlp_zt, iwprtp_zt, irtp2_zt, irtpthlp_zt, & -!$omp iup2_zt, ivp2_zt, iupwp_zt, ivpwp_zt) - - integer, public :: & - is_mellor -!$omp threadprivate(is_mellor) - - integer, target, allocatable, dimension(:), public :: & - isclrm, & ! Passive scalar mean (1) - isclrm_f ! Passive scalar forcing (1) - -! Used to calculate clear-sky radiative fluxes. - integer, public :: & - ifulwcl, ifdlwcl, ifdswcl, ifuswcl - -!$omp threadprivate(isclrm, isclrm_f) - - 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, & ! Latin hypercube estimate of thlm_mc - iLH_rvm_mc, & ! Latin hypercube estimate of rvm_mc - iLH_rcm_mc, & ! Latin hypercube estimate of rcm_mc - iLH_Ncm_mc, & ! Latin hypercube estimate of Ncm_mc - iLH_rrainm_mc, & ! Latin hypercube estimate of rrainm_mc - iLH_Nrm_mc, & ! Latin hypercube estimate of Nrm_mc - iLH_rsnowm_mc, & ! Latin hypercube estimate of rsnowm_mc - iLH_Nsnowm_mc, & ! Latin hypercube estimate of Nsnowm_mc - iLH_rgraupelm_mc, & ! Latin hypercube estimate of rgraupelm_mc - iLH_Ngraupelm_mc, & ! Latin hypercube estimate of Ngraupelm_mc - iLH_ricem_mc, & ! Latin hypercube estimate of ricem_mc - iLH_Nim_mc ! Latin hypercube estimate of Nim_mc -!$omp threadprivate( iLH_thlm_mc, iLH_rvm_mc, iLH_rcm_mc, iLH_Ncm_mc, & -!$omp iLH_rrainm_mc, iLH_Nrm_mc, iLH_rsnowm_mc, iLH_Nsnowm_mc, & -!$omp iLH_rgraupelm_mc, iLH_Ngraupelm_mc, iLH_ricem_mc, iLH_Nim_mc ) - - integer, public :: & - iLH_rrainm_auto, & ! Latin hypercube estimate of autoconversion - iLH_rrainm_accr ! Latin hypercube estimate of accretion -!$omp threadprivate( iLH_rrainm_auto, iLH_rrainm_accr ) - - integer, public :: & - iLH_Vrr, & ! Latin hypercube estimate of rrainm sedimentation velocity - iLH_VNr ! Latin hypercube estimate of Nrm sedimentation velocity -!$omp threadprivate(iLH_Vrr, iLH_VNr) - - integer, public :: & - iLH_rrainm, & - iLH_Nrm, & - iLH_ricem, & - iLH_Nim, & - iLH_rsnowm, & - iLH_Nsnowm, & - iLH_rgraupelm, & - iLH_Ngraupelm, & - iLH_thlm, & - iLH_rcm, & - iLH_Ncm, & - iLH_rvm, & - iLH_wm, & - iLH_cloud_frac - -!$omp threadprivate(iLH_rrainm, iLH_Nrm, iLH_ricem, iLH_Nim, iLH_rsnowm, iLH_Nsnowm, & -!$omp iLH_rgraupelm, iLH_Ngraupelm, & -!$omp iLH_thlm, iLH_rcm, iLH_Ncm, iLH_rvm, iLH_wm, iLH_cloud_frac ) - - integer, public :: & - iLH_wp2_zt, & - iLH_Nrp2_zt, & - iLH_Ncp2_zt, & - iLH_rcp2_zt, & - iLH_rtp2_zt, & - iLH_thlp2_zt, & - iLH_rrainp2_zt - -!$omp threadprivate(iLH_wp2_zt, iLH_Nrp2_zt, iLH_Ncp2_zt, iLH_rcp2_zt, iLH_rtp2_zt, & -!$omp iLH_thlp2_zt, iLH_rrainp2_zt) - - ! Indices for statistics in zm file - integer, public :: & - iwp2, & - irtp2, & - ithlp2, & - irtpthlp, & - iwprtp, & - iwpthlp, & - iwp4, & - iwpthvp, & - irtpthvp, & - ithlpthvp, & - itau_zm, & - iKh_zm, & - iwprcp, & - irc_coef, & - ithlprcp, & - irtprcp, & - ircp2, & - iupwp, & - ivpwp - - integer, public :: & - irho_zm, & - isigma_sqd_w, & - irho_ds_zm, & - ithv_ds_zm, & - iem, & - ishear, & ! Brian - imean_w_up, & - imean_w_down, & - iFrad, & - iFrad_LW, & ! Brian - iFrad_SW, & ! Brian - iFrad_LW_up, & - iFrad_SW_up, & - iFrad_LW_down, & - iFrad_SW_down, & - iFprec, & ! Brian - iFcsed ! Brian - -!$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(irho_zm, isigma_sqd_w, irho_ds_zm, ithv_ds_zm, iem, ishear) -!$omp threadprivate(iFrad, iFrad_LW, iFrad_SW, iFrad_SW_up, iFrad_SW_down) -!$omp threadprivate(iFrad_LW_up, iFrad_LW_down, iFprec, iFcsed) - - ! Skewness Functions on zm grid - integer, public :: & - igamma_Skw_fnc, & - iC6rt_Skw_fnc, & - iC6thl_Skw_fnc, & - iC7_Skw_fnc, & - iC1_Skw_fnc - -!$omp threadprivate(igamma_Skw_fnc, iC6rt_Skw_fnc, iC6thl_Skw_fnc) -!$omp threadprivate(iC7_Skw_fnc, iC1_Skw_fnc) - - ! Sedimentation velocities - integer, public :: & - iVNr, & - iVrr, & - iVNc, & - iVrc, & - iVNsnow, & - iVrsnow, & - iVNice, & - iVrice, & - iVrgraupel - - ! Covariance of sedimentation velocity and hydrometeor, . - integer, public :: & - iVrrprrp, & - iVNrpNrp, & - iVrrprrp_net, & - iVNrpNrp_net - - -!$omp threadprivate(iVNr, iVrr, iVNc, iVrc, iVNsnow, iVrsnow, iVNice, iVrice, iVrgraupel) -!$omp threadprivate(iVrrprrp, iVNrpNrp, iVrrprrp_net, iVNrpNrp_net) - - integer, public :: & - iwp2_bt, & - iwp2_ma, & - iwp2_ta, & - iwp2_ac, & - iwp2_bp, & - iwp2_pr1, & - iwp2_pr2, & - iwp2_pr3, & - iwp2_dp1, & - iwp2_dp2, & - iwp2_4hd, & - iwp2_pd, & - iwp2_cl, & - iwp2_sf - -!$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, iwp2_4hd) -!$omp threadprivate(iwp2_pd, iwp2_cl) - - integer, public :: & - 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 - -!$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, & - iwpthlp_ma, & - iwpthlp_ta, & - iwpthlp_tp, & - iwpthlp_ac, & - iwpthlp_bp, & - iwpthlp_pr1, & - iwpthlp_pr2, & - iwpthlp_pr3, & - iwpthlp_dp1, & - iwpthlp_mfl, & - iwpthlp_cl, & - iwpthlp_sicl, & - iwpthlp_forcing, & - iwpthlp_mc - -!$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, & - irtp2_ma, & - irtp2_ta, & - irtp2_tp, & - irtp2_dp1, & - irtp2_dp2, & - irtp2_pd, & - irtp2_cl, & - irtp2_sf, & - irtp2_forcing, & - irtp2_mc - -!$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, & - ithlp2_ma, & - ithlp2_ta, & - ithlp2_tp, & - ithlp2_dp1, & - ithlp2_dp2, & - ithlp2_pd, & - ithlp2_cl, & - ithlp2_sf, & - ithlp2_forcing, & - ithlp2_mc - -!$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, & - irtpthlp_ma, & - irtpthlp_ta, & - irtpthlp_tp1, & - irtpthlp_tp2, & - irtpthlp_dp1, & - irtpthlp_dp2, & - irtpthlp_cl, & - irtpthlp_sf, & - irtpthlp_forcing, & - irtpthlp_mc - -!$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, & - ivp2 - -!$omp threadprivate(iup2, ivp2) - - integer, public :: & - iup2_bt, & - iup2_ta, & - iup2_tp, & - iup2_ma, & - iup2_dp1, & - iup2_dp2, & - iup2_pr1, & - iup2_pr2, & - iup2_pd, & - iup2_cl, & - iup2_sf, & - ivp2_bt, & - ivp2_ta, & - ivp2_tp, & - ivp2_ma, & - ivp2_dp1, & - ivp2_dp2, & - ivp2_pr1, & - ivp2_pr2, & - ivp2_pd, & - ivp2_cl, & - ivp2_sf - -!$omp threadprivate(iup2_bt, iup2_ta, iup2_tp, iup2_ma, iup2_dp1) -!$omp threadprivate(iup2_dp2, iup2_pr1, iup2_pr2, iup2_cl) -!$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) - -! 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 rad_zt file - integer, public :: & - iT_in_K_rad, & - ircil_rad, & - io3l_rad, & - irsnowm_rad, & - ircm_in_cloud_rad, & - icloud_frac_rad, & - iice_supersat_frac_rad, & - iradht_rad, & - iradht_LW_rad, & - iradht_SW_rad - -!$omp threadprivate(iT_in_K_rad, ircil_rad, io3l_rad) -!$omp threadprivate(irsnowm_rad, ircm_in_cloud_rad, icloud_frac_rad) -!$omp threadprivate(iradht_rad, iradht_LW_rad, iradht_SW_rad) - - ! Indices for statistics in rad_zm file - integer, public :: & - iFrad_LW_rad, & - iFrad_SW_rad, & - iFrad_SW_up_rad, & - iFrad_LW_up_rad, & - iFrad_SW_down_rad, & - iFrad_LW_down_rad - -!$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 sfc file - - integer, public :: & - iustar, & - isoil_heat_flux,& - iveg_T_in_K,& - isfc_soil_T_in_K, & - ideep_soil_T_in_K,& - ilh, & - ish, & - icc, & - ilwp, & - ivwp, & ! nielsenb - iiwp, & ! nielsenb - iswp, & ! nielsenb - irwp, & - iz_cloud_base, & - iz_inversion, & - irain_rate_sfc, & ! Brian - irain_flux_sfc, & ! Brian - irrainm_sfc, & ! Brian - iwpthlp_sfc - - integer, public :: & - iwprtp_sfc, & - iupwp_sfc, & - ivpwp_sfc, & - ithlm_vert_avg, & - irtm_vert_avg, & - ium_vert_avg, & - ivm_vert_avg, & - iwp2_vert_avg, & ! nielsenb - iup2_vert_avg, & - ivp2_vert_avg, & - irtp2_vert_avg, & - ithlp2_vert_avg, & - iT_sfc ! kcwhite - - integer, public :: & - 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 - - integer, public :: & - imorr_rain_rate, & - imorr_snow_rate - - integer, public :: & - irtm_spur_src, & - ithlm_spur_src -!$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 irain_rate_sfc, irain_flux_sfc, irrainm_sfc, & -!$omp iwpthlp_sfc, 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, & -!$omp 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, & -!$omp imorr_rain_rate, imorr_snow_rate) - - integer, public :: & - iSkw_velocity, & ! Skewness velocity - iwp3_zm, & - ia3_coef, & - ia3_coef_zt -!$omp threadprivate(iSkw_velocity, iwp3_zm, ia3_coef, ia3_coef_zt) - - integer, public :: & - iwp3_on_wp2, & ! w'^3 / w'^2 [m/s] - iwp3_on_wp2_zt ! w'^3 / w'^2 [m/s] -!$omp threadprivate(iwp3_on_wp2, iwp3_on_wp2_zt) - - integer, public :: & - iLH_morr_rain_rate, & - iLH_morr_snow_rate -!$omp threadprivate( iLH_morr_rain_rate, iLH_morr_snow_rate ) - - integer, public :: & - iLH_vwp, & - iLH_lwp -!$omp threadprivate( iLH_vwp, iLH_lwp ) - - ! Variables that contains all the statistics - - type (stats), target, public :: zt, & ! zt grid - zm, & ! zm grid - LH_zt, & ! LH_zt grid - LH_sfc, & ! LH_sfc grid - rad_zt, & ! rad_zt grid - rad_zm, & ! rad_zm grid - sfc ! sfc - -!$omp threadprivate(zt, zm, rad_zt, rad_zm, 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) - - real( kind = core_rknd ), dimension(:), allocatable, public :: & - radscr01, radscr02, radscr03, & - radscr04, radscr05, radscr06, & - radscr07, radscr08, radscr09, & - radscr10, radscr11, radscr12, & - radscr13, radscr14, radscr15, & - radscr16, radscr17 - -!$omp threadprivate(radscr01, radscr02, radscr03, radscr04, radscr05) -!$omp threadprivate(radscr06, radscr07, radscr08, radscr09, radscr10) -!$omp threadprivate(radscr11, radscr12, radscr13, radscr14, radscr15) -!$omp threadprivate(radscr16, radscr17) - -end module crmx_stats_variables diff --git a/src/physics/spcam/crm/CLUBB/crmx_stats_zm.F90 b/src/physics/spcam/crm/CLUBB/crmx_stats_zm.F90 deleted file mode 100644 index a762e43cf0..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stats_zm.F90 +++ /dev/null @@ -1,1724 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_zm.F90 6146 2013-04-05 18:02:22Z raut@uwm.edu $ -module crmx_stats_zm - - 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 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 crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_stats_variables, only: & - zm, & - iwp2, & - irtp2, & - ithlp2, & - irtpthlp, & - iwprtp, & - iwpthlp, & - iwp3_zm, & - iwp4, & - iwpthvp, & - irtpthvp, & - ithlpthvp, & - itau_zm, & - iKh_zm, & - iwprcp, & - irc_coef, & - ithlprcp, & - irtprcp, & - ircp2 - - use crmx_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 - - use crmx_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 crmx_stats_variables, only: & - iVNr, & - iVrr, & - iVNc, & - iVrc, & - iVNice, & - iVrice, & - iVNsnow, & - iVrsnow, & - iVrgraupel, & - iVrrprrp, & - iVNrpNrp, & - iVrrprrp_net, & - iVNrpNrp_net - - use crmx_stats_variables, only: & - iwp2_bt, & - iwp2_ma, & - iwp2_ta, & - iwp2_ac, & - iwp2_bp, & - iwp2_pr1, & - iwp2_pr2, & - iwp2_pr3, & - iwp2_dp1, & - iwp2_dp2, & - iwp2_4hd, & - iwp2_cl, & - iwp2_pd, & - iwp2_sf - - use crmx_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 crmx_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 crmx_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 crmx_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 crmx_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 crmx_stats_variables, only: & - iwm_zm, & ! Variable - icloud_frac_zm, & - iice_supersat_frac_zm, & - ircm_zm, & - irtm_zm, & - ithlm_zm - - use crmx_stats_variables, only: & - isclrprtp, & - isclrp2, & - isclrpthvp, & - isclrpthlp, & - isclrprcp, & - iwpsclrp, & - iwp2sclrp, & - iwpsclrp2, & - iwpsclrprtp, & - iwpsclrpthlp, & - iwpedsclrp - - use crmx_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 - - use crmx_stats_type, only: & - stat_assign ! Procedure - - use crmx_parameters_model, only: & - sclr_dim, & - edsclr_dim - -! use error_code, only: & -! clubb_at_least_debug_level ! Function - - implicit none - - ! Input Variable - ! zm variable names - - character(len= * ), dimension(nvarmax_zm), intent(in) :: vars_zm - - ! Output Variable - logical, intent(inout) :: l_error - - ! Local Varables - integer :: i,j, k - - logical :: l_found - - character(len=50) :: sclr_idx - -! Default initialization for array indices for zm - - iwp2 = 0 - irtp2 = 0 - ithlp2 = 0 - irtpthlp = 0 - iwprtp = 0 - iwpthlp = 0 - iwp3_zm = 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 - 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 ! Brian - iFrad_SW_up = 0 ! Brian - iFrad_LW_down = 0 ! Brian - iFrad_SW_down = 0 ! Brian - iFprec = 0 ! Brian - iFcsed = 0 ! Brian - - - iup2 = 0 - ivp2 = 0 - - 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_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_cl = 0 - ivp2_sf = 0 - - ! Sedimentation velocities - iVNr = 0 - iVrr = 0 - iVNc = 0 - iVrc = 0 - iVNice = 0 - iVrice = 0 - iVrgraupel = 0 - iVNsnow = 0 - iVrsnow = 0 - - ! Covariance of sedimentation velocity and hydrometeor, - iVrrprrp = 0 - iVNrpNrp = 0 - iVrrprrp_net = 0 - iVNrpNrp_net = 0 - - ! Vertical velocity budgets - 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_4hd = 0 - iwp2_cl = 0 - iwp2_pd = 0 - iwp2_sf = 0 - - ! Flux budgets - 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 - - 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 - - ! Variance budgets - irtp2_bt = 0 - irtp2_ma = 0 - irtp2_ta = 0 - irtp2_tp = 0 - irtp2_dp1 = 0 - irtp2_dp2 = 0 - irtp2_cl = 0 - irtp2_pd = 0 - irtp2_sf = 0 - irtp2_forcing = 0 - irtp2_mc = 0 - - ithlp2_bt = 0 - ithlp2_ma = 0 - ithlp2_ta = 0 - ithlp2_tp = 0 - ithlp2_dp1 = 0 - ithlp2_dp2 = 0 - ithlp2_cl = 0 - ithlp2_pd = 0 - ithlp2_sf = 0 - ithlp2_forcing = 0 - ithlp2_mc = 0 - - 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 - - !Monatonic flux limiter diagnostic output - iwpthlp_mfl_min = 0 - iwpthlp_mfl_max = 0 - iwpthlp_entermfl = 0 - iwpthlp_exit_mfl = 0 - iwprtp_mfl_min = 0 - iwprtp_mfl_max = 0 - iwprtp_enter_mfl = 0 - iwprtp_exit_mfl = 0 - - ! Skewness velocity - iSkw_velocity = 0 - - ! Skewness function - igamma_Skw_fnc = 0 - iC6rt_Skw_fnc = 0 - iC6thl_Skw_fnc = 0 - iC7_Skw_fnc = 0 - iC1_Skw_fnc = 0 - - ia3_coef = 0 - iwp3_on_wp2 = 0 - - 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)) - -! Assign pointers for statistics variables zm - - 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 zm - - k = 1 - do i=1,zm%nn - - select case ( trim(vars_zm(i)) ) - - case ('wp2') - iwp2 = k - call stat_assign(iwp2,"wp2", & - "w'^2, Variance of vertical air velocity [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - - case ('rtp2') - irtp2 = k - call stat_assign(irtp2,"rtp2", & - "rt'^2, Variance of rt [(kg/kg)^2]","(kg/kg)^2",zm) - k = k + 1 - - case ('thlp2') - ithlp2 = k - call stat_assign(ithlp2,"thlp2", & - "thl'^2, Variance of thl [K^2]","K^2",zm) - k = k + 1 - - case ('rtpthlp') - irtpthlp = k - call stat_assign(irtpthlp,"rtpthlp", & - "rt'thl', Covariance of rt and thl [(kg K)/kg]","(kg K)/kg",zm) - k = k + 1 - - case ('wprtp') - iwprtp = k - - call stat_assign(iwprtp,"wprtp", & - "w'rt', Vertical turbulent flux of rt [(kg/kg) m/s]","(m kg)/(s kg)",zm) - k = k + 1 - - case ('wpthlp') - iwpthlp = k - - call stat_assign(iwpthlp,"wpthlp", & - "w'thl', Vertical turbulent flux of thl [K m/s]","(m K)/s",zm) - k = k + 1 - - case ('wp3_zm') - iwp3_zm = k - call stat_assign( iwp3_zm, "wp3_zm", & - "w'^3 interpolated to moment. levels [m^3/s^3]", "(m^3)/(s^3)", zm ) - k = k + 1 - - case ('wp4') - iwp4 = k - call stat_assign(iwp4,"wp4", & - "w'^4 [m^4/s^4]","(m^4)/(s^4)",zm) - k = k + 1 - - case ('wpthvp') - iwpthvp = k - call stat_assign(iwpthvp,"wpthvp", & - "Buoyancy flux [K m/s]","K m/s",zm) - k = k + 1 - - case ('rtpthvp') - irtpthvp = k - call stat_assign(irtpthvp,"rtpthvp", & - "rt'thv' [(kg/kg) K]","(kg/kg) K",zm) - k = k + 1 - - case ('thlpthvp') - ithlpthvp = k - call stat_assign(ithlpthvp,"thlpthvp", & - "thl'thv' [K^2]","K^2",zm) - k = k + 1 - - case ('tau_zm') - itau_zm = k - - call stat_assign(itau_zm,"tau_zm", & - "Time-scale tau on momentum levels [s]","s",zm) - k = k + 1 - - case ('Kh_zm') - iKh_zm = k - - call stat_assign(iKh_zm,"Kh_zm", & - "Eddy diffusivity on momentum levels [m^2/s]","m^2/s",zm) - k = k + 1 - - case ('wprcp') - iwprcp = k - call stat_assign(iwprcp,"wprcp", & - "w' rc' [(m/s) (kg/kg)]","(m/s) (kg/kg)",zm) - k = k + 1 - - case ('rc_coef') - irc_coef = k - call stat_assign(irc_coef, "rc_coef", & - "Coefficient of X' R_l' in Eq. (34)", "[-]", zm) - k = k + 1 - - case ('thlprcp') - ithlprcp = k - call stat_assign(ithlprcp,"thlprcp", & - "thl' rc' [K (kg/kg)]","K (kg/kg)",zm) - k = k + 1 - - case ('rtprcp') - irtprcp = k - - call stat_assign(irtprcp,"rtprcp", & - "rt'rc' [(kg^2)/(kg^2)]","(kg^2)/(kg^2)",zm) - k = k + 1 - - case ('rcp2') - ircp2 = k - call stat_assign(ircp2,"rcp2", & - "rc'^2 [(kg^2)/(kg^2)]","(kg^2)/(kg^2)",zm) - k = k + 1 - case ('upwp') - iupwp = k - call stat_assign(iupwp,"upwp", & - "u'w', Vertical east-west momentum flux [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - case ('vpwp') - ivpwp = k - call stat_assign(ivpwp,"vpwp", & - "v'w', Vertical north-south momentum flux [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - case ('rho_zm') - irho_zm = k - call stat_assign(irho_zm,"rho_zm", & - "Density on momentum levels [kg/m^3]","kg m^{-3}",zm) - k = k + 1 - case ('sigma_sqd_w') - isigma_sqd_w = k - call stat_assign(isigma_sqd_w,"sigma_sqd_w", & - "Nondimensionalized w variance of Gaussian component [-]","-",zm) - k = k + 1 - case ('rho_ds_zm') - irho_ds_zm = k - call stat_assign(irho_ds_zm,"rho_ds_zm", & - "Dry, static, base-state density [kg/m^3]","kg m^{-3}",zm) - k = k + 1 - case ('thv_ds_zm') - ithv_ds_zm = k - call stat_assign(ithv_ds_zm,"thv_ds_zm", & - "Dry, base-state theta_v [K]","K",zm) - k = k + 1 - case ('em') - iem = k - call stat_assign(iem,"em", & - "Turbulent kinetic energy, usu. 0.5*(u'^2+v'^2+w'^2) [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - case ('shear') ! Brian - ishear = k - call stat_assign(ishear,"shear", & - "Wind shear production term [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - case ('mean_w_up') - imean_w_up = k - call stat_assign(imean_w_up, "mean_w_up", & - "Mean w >= w_ref [m/s]", "m/s", zm) - k = k + 1 - case ('mean_w_down') - imean_w_down = k - call stat_assign(imean_w_down, "mean_w_down", & - "Mean w <= w_ref [m/s]", "m/s", zm) - k = k + 1 - case ('Frad') - iFrad = k - call stat_assign(iFrad,"Frad", & - "Total (sw+lw) net (up+down) radiative flux [W/m^2]","W/m^2",zm) - k = k + 1 - case ('Frad_LW') ! Brian - iFrad_LW = k - call stat_assign(iFrad_LW,"Frad_LW", & - "Net long-wave radiative flux [W/m^2]","W/m^2",zm) - k = k + 1 - case ('Frad_SW') ! Brian - iFrad_SW = k - - call stat_assign(iFrad_SW,"Frad_SW", & - "Net short-wave radiative flux [W/m^2]","W/m^2",zm) - k = k + 1 - - case ('Frad_LW_up') ! Brian - iFrad_LW_up = k - call stat_assign(iFrad_LW_up,"Frad_LW_up", & - "Long-wave upwelling radiative flux [W/m^2]","W/m^2",zm) - k = k + 1 - case ('Frad_SW_up') ! Brian - iFrad_SW_up = k - - call stat_assign(iFrad_SW_up,"Frad_SW_up", & - "Short-wave upwelling radiative flux [W/m^2]","W/m^2",zm) - k = k + 1 - - case ('Frad_LW_down') ! Brian - iFrad_LW_down = k - call stat_assign(iFrad_LW_down,"Frad_LW_down", & - "Long-wave downwelling radiative flux [W/m^2]", "W/m^2", zm ) - k = k + 1 - case ('Frad_SW_down') ! Brian - iFrad_SW_down = k - - call stat_assign(iFrad_SW_down,"Frad_SW_down", & - "Short-wave downwelling radiative flux [W/m^2]", "W/m^2", zm ) - k = k + 1 - - - case ('Fprec') ! Brian - iFprec = k - - call stat_assign(iFprec,"Fprec", & - "Rain flux [W/m^2]","W/m^2",zm) - k = k + 1 - - case ('Fcsed') ! Brian - iFcsed = k - - call stat_assign(iFcsed,"Fcsed", & - "cloud water sedimentation flux [kg/(s*m^2)]", & - "kg/(s*m^2)",zm) - k = k + 1 - - case ('VNr') - iVNr = k - - call stat_assign(iVNr,"VNr", & - "rrainm concentration fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrr') - iVrr = k - - call stat_assign(iVrr,"Vrr", & - "rrainm mixing ratio fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('VNc') - iVNc = k - - call stat_assign(iVNc,"VNc", & - "Nrm concentration fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrc') - iVrc = k - - call stat_assign(iVrc,"Vrc", & - "Nrm mixing ratio fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('VNsnow') - iVNsnow = k - - call stat_assign(iVNsnow,"VNsnow", & - "Snow concentration fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrsnow') - iVrsnow = k - - call stat_assign(iVrsnow,"Vrsnow", & - "Snow mixing ratio fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrgraupel') - iVrgraupel = k - - call stat_assign(iVrgraupel,"Vrgraupel", & - "Graupel sedimentation velocity [m/s]","m/s",zm) - k = k + 1 - - case ('VNice') - iVNice = k - - call stat_assign(iVNice,"VNice", & - "Cloud ice concentration fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrice') - iVrice = k - - call stat_assign(iVrice,"Vrice", & - "Cloud ice mixing ratio fallspeed [m/s]","m/s",zm) - k = k + 1 - - case ('Vrrprrp') - iVrrprrp = k - - call stat_assign( iVrrprrp, "Vrrprrp", & - "Covariance of V_rr (r_r sed. vel.) and r_r [(m/s)(kg/kg)]", & - "(m/s)(kg/kg)", zm ) - k = k + 1 - - case ('VNrpNrp') - iVNrpNrp = k - - call stat_assign( iVNrpNrp, "VNrpNrp", & - "Covariance of V_Nr (N_r sed. vel.) and N_r [(m/s)(num/kg)]", & - "(m/s)(num/kg)", zm ) - k = k + 1 - - case ('Vrrprrp_net') - iVrrprrp_net = k - - call stat_assign( iVrrprrp_net, "Vrrprrp_net", & - "Adjusted value of < V_rr'r_r' > (turb. sed. flux limiter)" & - //" [(m/s)(kg/kg)]", "(m/s)(kg/kg)", zm ) - k = k + 1 - - case ('VNrpNrp_net') - iVNrpNrp_net = k - - call stat_assign( iVNrpNrp_net, "VNrpNrp_net", & - "Adjusted value of < V_Nr'N_r' > (turb. sed. flux limiter)" & - //" [(m/s)(num/kg)]", "(m/s)(num/kg)", zm ) - k = k + 1 - - case ('wp2_bt') - iwp2_bt = k - - call stat_assign(iwp2_bt,"wp2_bt", & - "wp2 budget: wp2 time tendency [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_ma') - iwp2_ma = k - - call stat_assign(iwp2_ma,"wp2_ma", & - "wp2 budget: wp2 vertical mean advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_ta') - iwp2_ta = k - - call stat_assign(iwp2_ta,"wp2_ta", & - "wp2 budget: wp2 turbulent advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_ac') - iwp2_ac = k - - call stat_assign(iwp2_ac,"wp2_ac", & - "wp2 budget: wp2 accumulation term [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_bp') - iwp2_bp = k - - call stat_assign(iwp2_bp,"wp2_bp", & - "wp2 budget: wp2 buoyancy production [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_pr1') - iwp2_pr1 = k - - call stat_assign(iwp2_pr1,"wp2_pr1", & - "wp2 budget: wp2 pressure term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_pr2') - iwp2_pr2 = k - call stat_assign(iwp2_pr2,"wp2_pr2", & - "wp2 budget: wp2 pressure term 2 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_pr3') - iwp2_pr3 = k - call stat_assign(iwp2_pr3,"wp2_pr3", & - "wp2 budget: wp2 pressure term 3 [m^2/s^3]","m^2/s^3",zm) - - k = k + 1 - - case ('wp2_dp1') - iwp2_dp1 = k - call stat_assign(iwp2_dp1,"wp2_dp1", & - "wp2 budget: wp2 dissipation term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('wp2_dp2') - iwp2_dp2 = k - call stat_assign(iwp2_dp2,"wp2_dp2", & - "wp2 budget: wp2 dissipation term 2 [m^2/s^3]","m^2/s^3",zm) - - k = k + 1 - - case ('wp2_4hd') - iwp2_4hd = k - call stat_assign(iwp2_4hd,"wp2_4hd", & - "wp2 budget: wp2 4th-order hyper-diffusion [m^2/s^3]","m^2/s^3",zm) - - k = k + 1 - - case ('wp2_cl') - iwp2_cl = k - - call stat_assign(iwp2_cl,"wp2_cl", & - "wp2 budget: wp2 clipping term [m^2/s^3]","m^2/s^3",zm) - - k = k + 1 - - case ('wp2_pd') - iwp2_pd = k - - call stat_assign(iwp2_pd,"wp2_pd", & - "wp2 budget: wp2 positive definite adjustment [m^2/s^3]","m2/s3",zm) - - k = k + 1 - - case ('wp2_sf') - iwp2_sf = k - - call stat_assign( iwp2_sf, "wp2_sf", & - "wp2 budget: wp2 surface variance [m^2/s^3]","m2/s3",zm) - - k = k + 1 - - case ('wprtp_bt') - iwprtp_bt = k - call stat_assign(iwprtp_bt,"wprtp_bt", & - "wprtp budget: wprtp time tendency [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_ma') - iwprtp_ma = k - - call stat_assign(iwprtp_ma,"wprtp_ma", & - "wprtp budget: wprtp mean advection [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_ta') - iwprtp_ta = k - - call stat_assign(iwprtp_ta,"wprtp_ta", & - "wprtp budget: wprtp turbulent advection [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_tp') - iwprtp_tp = k - - call stat_assign(iwprtp_tp,"wprtp_tp", & - "wprtp budget: wprtp turbulent production [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_ac') - iwprtp_ac = k - - call stat_assign(iwprtp_ac,"wprtp_ac", & - "wprtp budget: wprtp accumulation term [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_bp') - iwprtp_bp = k - - call stat_assign(iwprtp_bp,"wprtp_bp", & - "wprtp budget: wprtp buoyancy production [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_pr1') - iwprtp_pr1 = k - - call stat_assign(iwprtp_pr1,"wprtp_pr1", & - "wprtp budget: wprtp pressure term 1 [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_pr2') - iwprtp_pr2 = k - - call stat_assign(iwprtp_pr2,"wprtp_pr2", & - "wprtp budget: wprtp pressure term 2 [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_pr3') - iwprtp_pr3 = k - - call stat_assign(iwprtp_pr3,"wprtp_pr3", & - "wprtp budget: wprtp pressure term 3 [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_dp1') - iwprtp_dp1 = k - - call stat_assign(iwprtp_dp1,"wprtp_dp1", & - "wprtp budget: wprtp dissipation term 1 [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_mfl') - iwprtp_mfl = k - - call stat_assign(iwprtp_mfl,"wprtp_mfl", & - "wprtp budget: wprtp monotonic flux limiter [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_cl') - iwprtp_cl = k - - call stat_assign(iwprtp_cl,"wprtp_cl", & - "wprtp budget: wprtp clipping term [(m kg)/(s^2 kg)]","(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_sicl') - iwprtp_sicl = k - - call stat_assign(iwprtp_sicl,"wprtp_sicl", & - "wprtp budget: wprtp semi-implicit clipping term [(m kg)/(s^2 kg)]", & - "(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_pd') - iwprtp_pd = k - - call stat_assign(iwprtp_pd,"wprtp_pd", & - "wprtp budget: wprtp flux corrected trans. term [(m kg)/(s^2 kg)]", & - "(m kg)/(s^2 kg)",zm) - k = k + 1 - - case ('wprtp_forcing') - iwprtp_forcing = k - - call stat_assign( iwprtp_forcing, "wprtp_forcing", & - "wprtp budget: wprtp forcing (includes microphysics tendency) [(m kg/kg)/s^2]", & - "(m kg/kg)/s^2", zm ) - k = k + 1 - - case ('wprtp_mc') - iwprtp_mc = k - - call stat_assign( iwprtp_mc, "wprtp_mc", & - "Microphysics tendency for wprtp (not in budget) [(m kg/kg)/s^2]", & - "(m kg/kg)/s^2", zm ) - k = k + 1 - - case ('wpthlp_bt') - iwpthlp_bt = k - - call stat_assign(iwpthlp_bt,"wpthlp_bt", & - "wpthlp budget: [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_ma') - iwpthlp_ma = k - call stat_assign(iwpthlp_ma,"wpthlp_ma", & - "wpthlp budget: wpthlp mean advection [(m K)/s^2]","(m K)/s^2",zm) - - k = k + 1 - - case ('wpthlp_ta') - iwpthlp_ta = k - call stat_assign(iwpthlp_ta,"wpthlp_ta", & - "wpthlp budget: wpthlp turbulent advection [(m K)/s^2]","(m K)/s^2",zm) - - k = k + 1 - - case ('wpthlp_tp') - iwpthlp_tp = k - call stat_assign(iwpthlp_tp,"wpthlp_tp", & - "wpthlp budget: wpthlp turbulent production [(m K)/s^2]","(m K)/s^2",zm) - - k = k + 1 - - case ('wpthlp_ac') - iwpthlp_ac = k - call stat_assign(iwpthlp_ac,"wpthlp_ac", & - "wpthlp budget: wpthlp accumulation term [(m K)/s^2]","(m K)/s^2",zm) - - k = k + 1 - - case ('wpthlp_bp') - iwpthlp_bp = k - call stat_assign(iwpthlp_bp,"wpthlp_bp", & - "wpthlp budget: wpthlp buoyancy production [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_pr1') - iwpthlp_pr1 = k - - call stat_assign(iwpthlp_pr1,"wpthlp_pr1", & - "wpthlp budget: wpthlp pressure term 1 [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_pr2') - iwpthlp_pr2 = k - - call stat_assign(iwpthlp_pr2,"wpthlp_pr2", & - "wpthlp budget: wpthlp pressure term 2 [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_pr3') - iwpthlp_pr3 = k - call stat_assign(iwpthlp_pr3,"wpthlp_pr3", & - "wpthlp budget: wpthlp pressure term 3 [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_dp1') - iwpthlp_dp1 = k - call stat_assign(iwpthlp_dp1,"wpthlp_dp1", & - "wpthlp budget: wpthlp dissipation term 1 [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_mfl') - iwpthlp_mfl = k - call stat_assign(iwpthlp_mfl,"wpthlp_mfl", & - "wpthlp budget: wpthlp monotonic flux limiter [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_cl') - iwpthlp_cl = k - call stat_assign(iwpthlp_cl,"wpthlp_cl", & - "wpthlp budget: wpthlp clipping term [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_sicl') - iwpthlp_sicl = k - call stat_assign(iwpthlp_sicl,"wpthlp_sicl", & - "wpthlp budget: wpthlp semi-implicit clipping term [(m K)/s^2]","(m K)/s^2",zm) - k = k + 1 - - case ('wpthlp_forcing') - iwpthlp_forcing = k - - call stat_assign( iwpthlp_forcing, "wpthlp_forcing", & - "wpthlp budget: wpthlp forcing (includes microphysics tendency) [(m K)/s^2]", & - "(m K)/s^2", zm ) - k = k + 1 - - case ('wpthlp_mc') - iwpthlp_mc = k - - call stat_assign( iwpthlp_mc, "wpthlp_mc", & - "Microphysics tendency for wpthlp (not in budget) [(m K)/s^2]", & - "(m K)/s^2", zm ) - k = k + 1 - - ! Variance budgets - case ('rtp2_bt') - irtp2_bt = k - call stat_assign(irtp2_bt,"rtp2_bt", & - "rtp2 budget: rtp2 time tendency [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_ma') - irtp2_ma = k - call stat_assign(irtp2_ma,"rtp2_ma", & - "rtp2 budget: rtp2 mean advection [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_ta') - irtp2_ta = k - call stat_assign(irtp2_ta,"rtp2_ta", & - "rtp2 budget: rtp2 turbulent advection [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_tp') - irtp2_tp = k - call stat_assign(irtp2_tp,"rtp2_tp", & - "rtp2 budget: rtp2 turbulent production [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_dp1') - irtp2_dp1 = k - call stat_assign(irtp2_dp1,"rtp2_dp1", & - "rtp2 budget: rtp2 dissipation term 1 [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_dp2') - irtp2_dp2 = k - call stat_assign(irtp2_dp2,"rtp2_dp2", & - "rtp2 budget: rtp2 dissipation term 2 [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - case ('rtp2_cl') - irtp2_cl = k - call stat_assign(irtp2_cl,"rtp2_cl", & - "rtp2 budget: rtp2 clipping term [(kg^2)/(kg^2 s)]","(kg^2)/(kg^2 s)",zm) - k = k + 1 - - case ('rtp2_pd') - irtp2_pd = k - call stat_assign( irtp2_pd, "rtp2_pd", & - "rtp2 budget: rtp2 positive definite adjustment [(kg^2)/(kg^2 s)]", & - "(kg^2)/(kg^2 s)", zm ) - k = k + 1 - - case ('rtp2_sf') - irtp2_sf = k - call stat_assign( irtp2_sf, "rtp2_sf", & - "rtp2 budget: rtp2 surface variance [(kg^2)/(kg^2 s)]", & - "(kg^2)/(kg^2 s)", zm ) - k = k + 1 - - case ('rtp2_forcing') - irtp2_forcing = k - - call stat_assign( irtp2_forcing, "rtp2_forcing", & - "rtp2 budget: rtp2 forcing (includes microphysics tendency) [(kg/kg)^2/s]", & - "(kg/kg)^2/s", zm ) - k = k + 1 - - case ('rtp2_mc') - irtp2_mc = k - - call stat_assign( irtp2_mc, "rtp2_mc", & - "Microphysics tendency for rtp2 (not in budget) [(kg/kg)^2/s]", & - "(kg/kg)^2/s", zm ) - k = k + 1 - - case ('thlp2_bt') - ithlp2_bt = k - call stat_assign(ithlp2_bt,"thlp2_bt", & - "thlp2 budget: thlp2 time tendency [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_ma') - ithlp2_ma = k - call stat_assign(ithlp2_ma,"thlp2_ma", & - "thlp2 budget: thlp2 mean advection [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_ta') - ithlp2_ta = k - call stat_assign(ithlp2_ta,"thlp2_ta", & - "thlp2 budget: thlp2 turbulent advection [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_tp') - ithlp2_tp = k - call stat_assign(ithlp2_tp,"thlp2_tp", & - "thlp2 budget: thlp2 turbulent production [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_dp1') - ithlp2_dp1 = k - call stat_assign(ithlp2_dp1,"thlp2_dp1", & - "thlp2 budget: thlp2 dissipation term 1 [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_dp2') - ithlp2_dp2 = k - call stat_assign(ithlp2_dp2,"thlp2_dp2", & - "thlp2 budget: thlp2 dissipation term 2 [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - case ('thlp2_cl') - ithlp2_cl = k - call stat_assign(ithlp2_cl,"thlp2_cl", & - "thlp2 budget: thlp2 clipping term [(K^2)/s]","(K^2)/s",zm) - k = k + 1 - - case ('thlp2_pd') - ithlp2_pd = k - call stat_assign( ithlp2_pd, "thlp2_pd", & - "thlp2 budget: thlp2 positive definite adjustment [(K^2)/s]", "K^2/s", zm ) - k = k + 1 - - case ('thlp2_sf') - ithlp2_sf = k - call stat_assign( ithlp2_sf, "thlp2_sf", & - "thlp2 budget: thlp2 surface variance [(K^2)/s]", "K^2/s", zm ) - k = k + 1 - case ('thlp2_forcing') - ithlp2_forcing = k - call stat_assign( ithlp2_forcing, "thlp2_forcing", & - "thlp2 budget: thlp2 forcing (includes microphysics tendency) [K^2/s]", & - "K^2/s", zm ) - k = k + 1 - case ('thlp2_mc') - ithlp2_mc = k - call stat_assign( ithlp2_mc, "thlp2_mc", & - "Microphysics tendency for thlp2 (not in budget) [K^2/s]", & - "K^2/s", zm ) - k = k + 1 - - case ('rtpthlp_bt') - irtpthlp_bt = k - call stat_assign(irtpthlp_bt,"rtpthlp_bt", & - "rtpthlp budget: rtpthlp time tendency [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_ma') - irtpthlp_ma = k - call stat_assign(irtpthlp_ma,"rtpthlp_ma", & - "rtpthlp budget: rtpthlp mean advection [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_ta') - irtpthlp_ta = k - call stat_assign(irtpthlp_ta,"rtpthlp_ta", & - "rtpthlp budget: rtpthlp turbulent advection [](kg K)/(kg s)","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_tp1') - irtpthlp_tp1 = k - call stat_assign(irtpthlp_tp1,"rtpthlp_tp1", & - "rtpthlp budget: rtpthlp turbulent production 1 [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_tp2') - irtpthlp_tp2 = k - call stat_assign(irtpthlp_tp2,"rtpthlp_tp2", & - "rtpthlp budget: rtpthlp turbulent production 2 [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_dp1') - irtpthlp_dp1 = k - call stat_assign(irtpthlp_dp1,"rtpthlp_dp1", & - "rtpthlp budget: rtpthlp dissipation term 1 [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_dp2') - irtpthlp_dp2 = k - call stat_assign(irtpthlp_dp2,"rtpthlp_dp2", & - "rtpthlp budget: rtpthlp dissipation term 2 [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_cl') - irtpthlp_cl = k - call stat_assign(irtpthlp_cl,"rtpthlp_cl", & - "rtpthlp budget: rtpthlp clipping term [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_sf') - irtpthlp_sf = k - call stat_assign(irtpthlp_sf,"rtpthlp_sf", & - "rtpthlp budget: rtpthlp surface variance [(kg K)/(kg s)]","(kg K)/(kg s)",zm) - k = k + 1 - case ('rtpthlp_forcing') - irtpthlp_forcing = k - call stat_assign( irtpthlp_forcing, "rtpthlp_forcing", & - "rtpthlp budget: rtpthlp forcing (includes microphysics tendency) [(K kg/kg)/s]", & - "(K kg/kg)/s", zm ) - k = k + 1 - case ('rtpthlp_mc') - irtpthlp_mc = k - call stat_assign( irtpthlp_mc, "rtpthlp_mc", & - "Microphysics tendency for rtpthlp (not in budget) [(K kg/kg)/s]", & - "(K kg/kg)/s", zm ) - k = k + 1 - - case ('up2') - iup2 = k - call stat_assign(iup2,"up2", & - "u'^2 (momentum levels) [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - - case ('vp2') - ivp2 = k - call stat_assign(ivp2,"vp2", & - "v'^2 (momentum levels) [m^2/s^2]","m^2/s^2",zm) - k = k + 1 - - case ('up2_bt') - iup2_bt = k - call stat_assign(iup2_bt,"up2_bt", & - "up2 budget: up2 time tendency [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_ma') - iup2_ma = k - call stat_assign(iup2_ma,"up2_ma", & - "up2 budget: up2 mean advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_ta') - iup2_ta = k - call stat_assign(iup2_ta,"up2_ta", & - "up2 budget: up2 turbulent advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_tp') - iup2_tp = k - call stat_assign(iup2_tp,"up2_tp", & - "up2 budget: up2 turbulent production [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_dp1') - iup2_dp1 = k - call stat_assign(iup2_dp1,"up2_dp1", & - "up2 budget: up2 dissipation term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_dp2') - iup2_dp2 = k - call stat_assign(iup2_dp2,"up2_dp2", & - "up2 budget: up2 dissipation term 2 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_pr1') - iup2_pr1 = k - call stat_assign(iup2_pr1,"up2_pr1", & - "up2 budget: up2 pressure term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_pr2') - iup2_pr2 = k - call stat_assign(iup2_pr2,"up2_pr2", & - "up2 budget: up2 pressure term 2 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_cl') - iup2_cl = k - call stat_assign(iup2_cl,"up2_cl", & - "up2 budget: up2 clipping [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('up2_pd') - iup2_pd = k - call stat_assign( iup2_pd, "up2_pd", & - "up2 budget: up2 positive definite adjustment [m^2/s^3]", "m^2/s^3", zm ) - k = k + 1 - - case ('up2_sf') - iup2_sf = k - call stat_assign(iup2_sf,"up2_sf", & - "up2 budget: up2 surface variance [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_bt') - ivp2_bt = k - call stat_assign(ivp2_bt,"vp2_bt", & - "vp2 budget: vp2 time tendency [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_ma') - ivp2_ma = k - call stat_assign(ivp2_ma,"vp2_ma", & - "vp2 budget: vp2 mean advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_ta') - ivp2_ta = k - call stat_assign(ivp2_ta,"vp2_ta", & - "vp2 budget: vp2 turbulent advection [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_tp') - ivp2_tp = k - call stat_assign(ivp2_tp,"vp2_tp", & - "vp2 budget: vp2 turbulent production [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_dp1') - ivp2_dp1 = k - call stat_assign(ivp2_dp1,"vp2_dp1", & - "vp2 budget: vp2 dissipation term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_dp2') - ivp2_dp2 = k - call stat_assign(ivp2_dp2,"vp2_dp2", & - "vp2 budget: vp2 dissipation term 2 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_pr1') - ivp2_pr1 = k - call stat_assign(ivp2_pr1,"vp2_pr1", & - "vp2 budget: vp2 pressure term 1 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_pr2') - ivp2_pr2 = k - call stat_assign(ivp2_pr2,"vp2_pr2", & - "vp2 budget: vp2 pressure term 2 [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_cl') - ivp2_cl = k - call stat_assign(ivp2_cl,"vp2_cl", & - "vp2 budget: vp2 clipping [m^2/s^3]","m^2/s^3",zm) - k = k + 1 - - case ('vp2_pd') - ivp2_pd = k - call stat_assign( ivp2_pd, "vp2_pd", & - "vp2 budget: vp2 positive definite adjustment [m^2/s^3]", "m^2/s^3", zm ) - k = k + 1 - - case ('vp2_sf') - ivp2_sf = k - call stat_assign( ivp2_sf, "vp2_sf", & - "vp2 budget: vp2 surface variance [m^2/s^3]", "m^2/s^3", zm ) - k = k + 1 - - case ('wpthlp_entermfl') - iwpthlp_entermfl = k - call stat_assign( iwpthlp_entermfl, "wpthlp_entermfl", & - "Wpthlp entering flux limiter [(m K)/s]", "(m K)/s", zm ) - k = k + 1 - - case ('wpthlp_exit_mfl') - iwpthlp_exit_mfl = k - call stat_assign( iwpthlp_exit_mfl, "wpthlp_exit_mfl", & - "Wpthlp exiting flux limiter [](m K)/s", "(m K)/s", zm ) - k = k + 1 - - case ('wpthlp_mfl_min') - iwpthlp_mfl_min = k - call stat_assign( iwpthlp_mfl_min, "wpthlp_mfl_min", & - "Minimum allowable wpthlp [(m K)/s]", "(m K)/s", zm ) - k = k + 1 - - case ('wpthlp_mfl_max') - iwpthlp_mfl_max = k - call stat_assign( iwpthlp_mfl_max, "wpthlp_mfl_max", & - "Maximum allowable wpthlp ((m K)/s) [(m K)/s]", "(m K)/s", zm ) - k = k + 1 - - case ('wprtp_mfl_min') - iwprtp_mfl_min = k - call stat_assign( iwprtp_mfl_min, "wprtp_mfl_min", & - "Minimum allowable wprtp [(m kg)/(s kg)]", "(m kg)/(s kg)", zm ) - k = k + 1 - - case ('wprtp_mfl_max') - iwprtp_mfl_max = k - call stat_assign( iwprtp_mfl_max, "wprtp_mfl_max", & - "Maximum allowable wprtp [(m kg)/(s kg)]", "(m kg)/(s kg)", zm ) - k = k + 1 - - case ('wprtp_enter_mfl') - iwprtp_enter_mfl = k - call stat_assign( iwprtp_enter_mfl, "wprtp_enter_mfl", & - "Wprtp entering flux limiter [(m kg)/(s kg)]", "(m kg)/(s kg)", zm ) - k = k + 1 - - case ('wprtp_exit_mfl') - iwprtp_exit_mfl = k - call stat_assign( iwprtp_exit_mfl, "wprtp_exit_mfl", & - "Wprtp exiting flux limiter [(m kg)/(s kg)]", "(m kg)/(s kg)", zm ) - k = k + 1 - - case ('wm_zm') - iwm_zm = k - call stat_assign( iwm_zm, "wm_zm", & - "Vertical (w) wind [m/s]", "m/s", zm ) - k = k + 1 - - case ('cloud_frac_zm') - icloud_frac_zm = k - call stat_assign( icloud_frac_zm, "cloud_frac_zm", & - "Cloud fraction", "count", zm ) - k = k + 1 - - case ('ice_supersat_frac_zm') - iice_supersat_frac_zm = k - call stat_assign( iice_supersat_frac_zm, "ice_supersat_frac_zm", & - "Ice cloud fraction", "count", zm ) - k = k + 1 - - case ('rcm_zm') - ircm_zm = k - call stat_assign( ircm_zm, "rcm_zm", & - "Total water mixing ratio [kg/kg]", "kg/kg", zm ) - k = k + 1 - - case ('rtm_zm') - irtm_zm = k - call stat_assign( irtm_zm, "rtm_zm", & - "Total water mixing ratio [kg/kg]", "kg/kg", zm ) - k = k + 1 - - case ('thlm_zm') - ithlm_zm = k - call stat_assign( ithlm_zm, "thlm_zm", & - "Liquid potential temperature [K]", "K", zm ) - k = k + 1 - - case ( 'Skw_velocity' ) - iSkw_velocity = k - call stat_assign( iSkw_velocity, "Skw_velocity", & - "Skewness velocity [m/s]", "m/s", zm ) - k = k + 1 - - case ( 'gamma_Skw_fnc' ) - igamma_Skw_fnc = k - call stat_assign( igamma_Skw_fnc, "gamma_Skw_fnc", & - "Gamma as a function of skewness [-]", "count", zm ) - k = k + 1 - - case ( 'C6rt_Skw_fnc' ) - iC6rt_Skw_fnc = k - call stat_assign( iC6rt_Skw_fnc, "C6rt_Skw_fnc", & - "C_6rt parameter with Sk_w applied [-]", "count", zm ) - k = k + 1 - - case ( 'C6thl_Skw_fnc' ) - iC6thl_Skw_fnc = k - call stat_assign( iC6thl_Skw_fnc, "C6thl_Skw_fnc", & - "C_6thl parameter with Sk_w applied [-]", "count", zm ) - k = k + 1 - - case ( 'C7_Skw_fnc' ) - iC7_Skw_fnc = k - call stat_assign( iC7_Skw_fnc, "C7_Skw_fnc", & - "C_7 parameter with Sk_w applied [-]", "count", zm ) - k = k + 1 - - case ( 'C1_Skw_fnc' ) - iC1_Skw_fnc = k - call stat_assign( iC1_Skw_fnc, "C1_Skw_fnc", & - "C_1 parameter with Sk_w applied [-]", "count", zm ) - k = k + 1 - - case ( 'a3_coef' ) - ia3_coef = k - call stat_assign( ia3_coef, "a3_coef", & - "Quantity in formula 25 from Equations for CLUBB [-]", "count", zm ) - k = k + 1 - - case ( 'wp3_on_wp2' ) - iwp3_on_wp2 = k - call stat_assign( iwp3_on_wp2, "wp3_on_wp2", & - "Smoothed version of wp3 / wp2 [m/s]", "m/s", zm ) - k = k + 1 - - case default - l_found = .false. - - j = 1 - - do while( j <= sclr_dim .and. .not. l_found ) - write( sclr_idx, * ) j - sclr_idx = adjustl(sclr_idx) - - if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'prtp'.and. .not. l_found ) then - isclrprtp(j) = k - - call stat_assign(isclrprtp(j),"sclr"//trim(sclr_idx)//"prtp", & - "scalar("//trim(sclr_idx)//")'rt'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'p2'.and. .not. l_found ) then - isclrp2(j) = k - call stat_assign(isclrp2(j) ,"sclr"//trim(sclr_idx)//"p2", & - "scalar("//trim(sclr_idx)//")'^2'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'pthvp'.and. .not. l_found ) then - isclrpthvp(j) = k - call stat_assign(isclrpthvp(j),"sclr"//trim(sclr_idx)//"pthvp", & - "scalar("//trim(sclr_idx)//")'th_v'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'pthlp'.and. .not. l_found ) then - isclrpthlp(j) = k - - call stat_assign(isclrpthlp(j),"sclr"//trim(sclr_idx)//"pthlp", & - "scalar("//trim(sclr_idx)//")'th_l'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'sclr'//trim(sclr_idx)//'prcp'.and. .not. l_found ) then - - isclrprcp(j) = k - - call stat_assign(isclrprcp(j),"sclr"//trim(sclr_idx)//"prcp", & - "scalar("//trim(sclr_idx)//")'rc'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'p'.and. .not. l_found ) then - iwpsclrp(j) = k - - call stat_assign(iwpsclrp(j),"wpsclr"//trim(sclr_idx)//"p", & - "'w'scalar("//trim(sclr_idx)//")","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'p2'.and. .not. l_found ) then - - iwpsclrp2(j) = k - - call stat_assign(iwpsclrp2(j),"wpsclr"//trim(sclr_idx)//"p2", & - "'w'scalar("//trim(sclr_idx)//")'^2'","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'wp2sclr'//trim(sclr_idx)//'p'.and. .not. l_found ) then - - iwp2sclrp(j) = k - - call stat_assign(iwp2sclrp(j) ,"wp2sclr"//trim(sclr_idx)//"p", & - "'w'^2 scalar("//trim(sclr_idx)//")","unknown",zm) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'prtp'.and. .not. l_found ) then - iwpsclrprtp(j) = k - - call stat_assign( iwpsclrprtp(j),"wpsclr"//trim(sclr_idx)//"prtp", & - "'w' scalar("//trim(sclr_idx)//")'rt'","unknown",zm ) - k = k + 1 - l_found = .true. - end if - if( trim(vars_zm(i)) == 'wpsclr'//trim(sclr_idx)//'pthlp'.and. .not. l_found ) then - iwpsclrpthlp(j) = k - - call stat_assign(iwpsclrpthlp(j),"wpsclr"//trim(sclr_idx)//"pthlp", & - "'w' scalar("//trim(sclr_idx)//")'th_l'","unknown",zm) - k = k + 1 - l_found = .true. - end if - j = j + 1 - end do - - j = 1 - - do while( j <= edsclr_dim .and. .not. l_found ) - - write( sclr_idx, * ) j - sclr_idx = adjustl(sclr_idx) - - if( trim(vars_zm(i)) == 'wpedsclr'//trim(sclr_idx)//'p'.and. .not. l_found ) then - iwpedsclrp(j) = k - - call stat_assign(iwpedsclrp(j),"wpedsclr"//trim(sclr_idx)//"p", & - "eddy scalar("//trim(sclr_idx)//")'w'","unknown",zm) - k = k + 1 - l_found = .true. - end if - - j = j + 1 - - end do - - if( .not. l_found ) then - write(fstderr,*) 'Error: unrecognized variable in vars_zm: ', trim(vars_zm(i)) - l_error = .true. ! This will stop the run. - end if - end select - - end do - -! Non-interative diagnostics (zm) -! iwp4, ircp2 - -! if ( .not. clubb_at_least_debug_level( 1 ) ) then -! if ( iwp4 + ircp2 + ishear > 0 ) then -! write(fstderr,'(a)') & -! "Warning: at debug level 0. Non-interactive diagnostics will not be computed, " -! write(fstderr,'(a)') "but some appear in the stats_zm namelist variable." -! end if -! end if - - return - end subroutine stats_init_zm - -end module crmx_stats_zm diff --git a/src/physics/spcam/crm/CLUBB/crmx_stats_zt.F90 b/src/physics/spcam/crm/CLUBB/crmx_stats_zt.F90 deleted file mode 100644 index ea9ee63fea..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_stats_zt.F90 +++ /dev/null @@ -1,3221 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: stats_zt.F90 6153 2013-04-09 22:13:27Z bmg2@uwm.edu $ - -module crmx_stats_zt - - implicit none - - private ! Default Scope - - public :: stats_init_zt - -! Constant parameters - integer, parameter, public :: nvarmax_zt = 350 ! Maximum variables allowed - - contains - -!----------------------------------------------------------------------- - subroutine stats_init_zt( vars_zt, l_error ) - -! Description: -! Initializes array indices for 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 crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_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 crmx_stats_variables, only: & - iwp3, & ! Variable(s) - iwpthlp2, & - iwp2thlp, & - iwprtp2, & - iwp2rtp, & - iLscale_up, & - iLscale_down, & - itau_zt, & - iKh_zt, & - iwp2thvp, & - iwp2rcp, & - iwprtpthlp, & - isigma_sqd_w_zt - - use crmx_stats_variables, only: & - irr1, & ! Variable(s) - irr2, & - iNr1, & - iNr2, & - iLWP1, & - iLWP2, & - iprecip_frac, & - iprecip_frac_1, & - iprecip_frac_2 - - use crmx_stats_variables, only: & - imu_rr_1, & ! Variable(s) - imu_rr_2, & - imu_Nr_1, & - imu_Nr_2, & - imu_Nc_1, & - imu_Nc_2, & - imu_rr_1_n, & - imu_rr_2_n, & - imu_Nr_1_n, & - imu_Nr_2_n, & - imu_Nc_1_n, & - imu_Nc_2_n, & - isigma_rr_1, & - isigma_rr_2, & - isigma_Nr_1, & - isigma_Nr_2, & - isigma_Nc_1, & - isigma_Nc_2, & - isigma_rr_1_n, & - isigma_rr_2_n, & - isigma_Nr_1_n, & - isigma_Nr_2_n, & - isigma_Nc_1_n, & - isigma_Nc_2_n - - use crmx_stats_variables, only: & - icorr_srr_1, & ! Variable(s) - icorr_srr_2, & - icorr_sNr_1, & - icorr_sNr_2, & - icorr_sNc_1, & - icorr_sNc_2, & - icorr_trr_1, & - icorr_trr_2, & - icorr_tNr_1, & - icorr_tNr_2, & - icorr_tNc_1, & - icorr_tNc_2, & - icorr_rrNr_1, & - icorr_rrNr_2, & - icorr_srr_1_n, & - icorr_srr_2_n, & - icorr_sNr_1_n, & - icorr_sNr_2_n, & - icorr_sNc_1_n, & - icorr_sNc_2_n, & - icorr_trr_1_n, & - icorr_trr_2_n, & - icorr_tNr_1_n, & - icorr_tNr_2_n, & - icorr_tNc_1_n, & - icorr_tNc_2_n, & - icorr_rrNr_1_n, & - icorr_rrNr_2_n - - use crmx_stats_variables, only: & ! janhft 09/25/12 - icorr_sw, & ! Variable(s) - icorr_wrr, & - icorr_wNr, & - icorr_wNc - - use crmx_stats_variables, only: & - irel_humidity, & - irho, & - iNcm, & - iNcm_in_cloud, & - iNc_activated, & - iNcnm, & - isnowslope, & - ised_rcm, & - irsat, & - irsati, & - irrainm, & - iNrm, & - irain_rate_zt, & - iradht, & - iradht_LW, & - iradht_SW, & - idiam, & - imass_ice_cryst, & - ircm_icedfs, & - iu_T_cm, & - im_vol_rad_rain, & - im_vol_rad_cloud, & - irsnowm, & - irgraupelm, & - iricem - - use crmx_stats_variables, only: & - ieff_rad_cloud, & - ieff_rad_ice, & - ieff_rad_snow, & - ieff_rad_rain, & - ieff_rad_graupel - - use crmx_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 crmx_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_4hd, & - iwp3_cl - - ! Monotonic flux limiter diagnostic variables - use crmx_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 crmx_stats_variables, only: & - irrainm_bt, & - irrainm_ma, & - irrainm_sd, & - irrainm_ts, & - irrainm_sd_morr, & - irrainm_dff, & - irrainm_cond, & - irrainm_auto, & - irrainm_accr, & - irrainm_cond_adj, & - irrainm_src_adj, & - irrainm_tsfl, & - irrainm_mc, & - irrainm_hf - - use crmx_stats_variables, only: & - irrainm_wvhf, & - irrainm_cl, & - iNrm_bt, & - iNrm_ma, & - iNrm_sd, & - iNrm_ts, & - iNrm_dff, & - iNrm_cond, & - iNrm_auto, & - iNrm_cond_adj, & - iNrm_src_adj, & - iNrm_tsfl, & - iNrm_mc, & - iNrm_cl - - use crmx_stats_variables, only: & - irsnowm_bt, & - irsnowm_ma, & - irsnowm_sd, & - irsnowm_sd_morr, & - irsnowm_dff, & - irsnowm_mc, & - irsnowm_hf, & - irsnowm_wvhf, & - irsnowm_cl, & - irgraupelm_bt, & - irgraupelm_ma, & - irgraupelm_sd, & - irgraupelm_sd_morr, & - irgraupelm_dff, & - irgraupelm_mc - - use crmx_stats_variables, only: & - irgraupelm_hf, & - irgraupelm_wvhf, & - irgraupelm_cl, & - iricem_bt, & - iricem_ma, & - iricem_sd, & - iricem_sd_mg_morr, & - iricem_dff, & - iricem_mc, & - iricem_hf, & - iricem_wvhf, & - iricem_cl - - use crmx_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 crmx_stats_variables, only: & - imixt_frac, & ! Variable(s) - iw1, & - iw2, & - ivarnce_w1, & - ivarnce_w2, & - ithl1, & - ithl2, & - ivarnce_thl1, & - ivarnce_thl2, & - irt1, & - irt2, & - ivarnce_rt1, & - ivarnce_rt2, & - irc1, & - irc2, & - irsl1, & - irsl2, & - icloud_frac1, & - icloud_frac2 - - use crmx_stats_variables, only: & - is1, & - is2, & - istdev_s1, & - istdev_s2, & - istdev_t1, & - istdev_t2, & - icovar_st_1, & - icovar_st_2, & - icorr_st_1, & - icorr_st_2, & - irrtthl, & - icrt1, & - icrt2, & - icthl1, & - icthl2 - - - use crmx_stats_variables, only: & - iwp2_zt, & - ithlp2_zt, & - iwpthlp_zt, & - iwprtp_zt, & - irtp2_zt, & - irtpthlp_zt, & - iup2_zt, & - ivp2_zt, & - iupwp_zt, & - ivpwp_zt - - use crmx_stats_variables, only: & - zt, & - isclrm, & - isclrm_f, & - iedsclrm, & - iedsclrm_f - - use crmx_stats_variables, only: & - iNsnowm, & ! Variable(s) - iNrm, & - iNgraupelm, & - iNim, & - iNsnowm_bt, & - iNsnowm_mc, & - iNsnowm_ma, & - iNsnowm_dff, & - iNsnowm_sd, & - iNsnowm_cl, & - iNgraupelm_bt, & - iNgraupelm_mc, & - iNgraupelm_ma, & - iNgraupelm_dff, & - iNgraupelm_sd, & - iNgraupelm_cl, & - iNim_bt, & - iNim_mc, & - iNim_ma, & - iNim_dff, & - iNim_sd, & - iNim_cl - - use crmx_stats_variables, only: & - iNcm_bt, & - iNcm_mc, & - iNcm_ma, & - iNcm_dff, & - iNcm_cl, & - iNcm_act - - use crmx_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 - - use crmx_stats_variables, only: & - ieff_rad_cloud, & - ieff_rad_ice, & - ieff_rad_snow, & - ieff_rad_rain, & - ieff_rad_graupel - - use crmx_stats_variables, only: & - iC11_Skw_fnc, & ! Variable(s) - is_mellor, & - iwp3_on_wp2_zt, & - ia3_coef_zt - - use crmx_stats_variables, only: & - iLscale_pert_1, & ! Variable(s) - iLscale_pert_2 - - use crmx_stats_type, only: & - stat_assign ! Procedure - - use crmx_parameters_model, only: & - sclr_dim,& ! Variable(s) - edsclr_dim - -!use error_code, only: & -! clubb_at_least_debug_level ! Function - - - implicit none - - ! Input Variable - character(len= * ), dimension(nvarmax_zt), intent(in) :: vars_zt - - ! Output Variable - logical, intent(inout) :: l_error - - ! Local Varables - integer :: i, j, k - - logical :: l_found - - character(len=50) :: sclr_idx - -! Default initialization for array indices for zt - - ithlm = 0 - iT_in_K = 0 - ithvm = 0 - irtm = 0 - ircm = 0 - irfrzm = 0 - irvm = 0 - ium = 0 - ivm = 0 - iwm_zt = 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 - iwpthlp2 = 0 - iwp2thlp = 0 - iwprtp2 = 0 - iwp2rtp = 0 - iLscale_up = 0 - iLscale_down = 0 - itau_zt = 0 - iKh_zt = 0 - iwp2thvp = 0 - iwp2rcp = 0 - iwprtpthlp = 0 - isigma_sqd_w_zt = 0 - irho = 0 - irel_humidity = 0 - iNcm = 0 ! Brian - iNcm_in_cloud = 0 - iNc_activated = 0 - iNcnm = 0 - iNim = 0 - isnowslope = 0 ! Adam Smith, 22 April 2008 - ised_rcm = 0 ! Brian - irsat = 0 ! Brian - irrainm = 0 ! Brian - irain_rate_zt = 0 ! Brian - iradht = 0 - iradht_LW = 0 - iradht_SW = 0 - - ! Number concentrations - iNsnowm = 0 ! Adam Smith, 22 April 2008 - iNrm = 0 ! Brian - iNgraupelm = 0 - iNim = 0 - - idiam = 0 - imass_ice_cryst = 0 - ircm_icedfs = 0 - iu_T_cm = 0 - - irr1 = 0 - irr2 = 0 - iNr1 = 0 - iNr2 = 0 - iLWP1 = 0 - iLWP2 = 0 - iprecip_frac = 0 - iprecip_frac_1 = 0 - iprecip_frac_2 = 0 - - imu_rr_1 = 0 - imu_rr_2 = 0 - imu_Nr_1 = 0 - imu_Nr_2 = 0 - imu_Nc_1 = 0 - imu_Nc_2 = 0 - imu_rr_1_n = 0 - imu_rr_2_n = 0 - imu_Nr_1_n = 0 - imu_Nr_2_n = 0 - imu_Nc_1_n = 0 - imu_Nc_2_n = 0 - isigma_rr_1 = 0 - isigma_rr_2 = 0 - isigma_Nr_1 = 0 - isigma_Nr_2 = 0 - isigma_Nc_1 = 0 - isigma_Nc_2 = 0 - isigma_rr_1_n = 0 - isigma_rr_2_n = 0 - isigma_Nr_1_n = 0 - isigma_Nr_2_n = 0 - isigma_Nc_1_n = 0 - isigma_Nc_2_n = 0 - icorr_srr_1 = 0 - icorr_srr_2 = 0 - icorr_sNr_1 = 0 - icorr_sNr_2 = 0 - icorr_sNc_1 = 0 - icorr_sNc_2 = 0 - icorr_trr_1 = 0 - icorr_trr_2 = 0 - icorr_tNr_1 = 0 - icorr_tNr_2 = 0 - icorr_tNc_1 = 0 - icorr_tNc_2 = 0 - icorr_rrNr_1 = 0 - icorr_rrNr_2 = 0 - icorr_srr_1_n = 0 - icorr_srr_2_n = 0 - icorr_sNr_1_n = 0 - icorr_sNr_2_n = 0 - icorr_sNc_1_n = 0 - icorr_sNc_2_n = 0 - icorr_trr_1_n = 0 - icorr_trr_2_n = 0 - icorr_tNr_1_n = 0 - icorr_tNr_2_n = 0 - icorr_tNc_1_n = 0 - icorr_tNc_2_n = 0 - icorr_rrNr_1_n = 0 - icorr_rrNr_2_n = 0 - - ! Correlations - icorr_sw = 0 - icorr_wrr = 0 - icorr_wNr = 0 - icorr_wNc = 0 - - ! From K&K microphysics - im_vol_rad_rain = 0 ! Brian - im_vol_rad_cloud = 0 - - ! From Morrison microphysics - ieff_rad_cloud = 0 - ieff_rad_ice = 0 - ieff_rad_snow = 0 - ieff_rad_rain = 0 - ieff_rad_graupel = 0 - - irsnowm = 0 - irgraupelm = 0 - iricem = 0 - - irtm_bt = 0 - irtm_ma = 0 - irtm_ta = 0 - irtm_forcing = 0 - irtm_sdmp = 0 - irtm_mc = 0 - ircm_mc = 0 ! For the change due to COAMPS/Morrison microphysics - ircm_sd_mg_morr = 0 - irvm_mc = 0 ! For the change due to COAMPS/Morrison microphysics - irtm_mfl = 0 - irtm_tacl = 0 - irtm_cl = 0 ! Josh - irtm_pd = 0 - ithlm_bt = 0 - ithlm_ma = 0 - ithlm_ta = 0 - ithlm_forcing = 0 - ithlm_mc = 0 - ithlm_sdmp = 0 - ithlm_mfl = 0 - ithlm_tacl = 0 - ithlm_cl = 0 ! Josh - - ithlm_mfl_min = 0 - ithlm_mfl_max = 0 - irtm_mfl_min = 0 - irtm_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 - - 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_4hd = 0 - iwp3_cl = 0 - - irrainm_bt = 0 - irrainm_ma = 0 - irrainm_sd = 0 - irrainm_ts = 0 - irrainm_sd_morr = 0 - irrainm_dff = 0 - irrainm_cond = 0 - irrainm_auto = 0 - irrainm_accr = 0 - irrainm_cond_adj = 0 - irrainm_src_adj = 0 - irrainm_tsfl = 0 - irrainm_mc = 0 - irrainm_hf = 0 - irrainm_wvhf = 0 - irrainm_cl = 0 - - iNrm_bt = 0 - iNrm_ma = 0 - iNrm_sd = 0 - iNrm_ts = 0 - iNrm_dff = 0 - iNrm_cond = 0 - iNrm_auto = 0 - iNrm_cond_adj = 0 - iNrm_src_adj = 0 - iNrm_tsfl = 0 - iNrm_mc = 0 - iNrm_cl = 0 - - iNsnowm_bt = 0 - iNsnowm_ma = 0 - iNsnowm_sd = 0 - iNsnowm_dff = 0 - iNsnowm_mc = 0 - iNsnowm_cl = 0 - - iNim_bt = 0 - iNim_ma = 0 - iNim_sd = 0 - iNim_dff = 0 - iNim_mc = 0 - iNim_cl = 0 - - iNcm_bt = 0 - iNcm_ma = 0 - iNcm_dff = 0 - iNcm_mc = 0 - iNcm_cl = 0 - iNcm_act = 0 - - irsnowm_bt = 0 - irsnowm_ma = 0 - irsnowm_sd = 0 - irsnowm_sd_morr = 0 - irsnowm_dff = 0 - irsnowm_mc = 0 - irsnowm_hf = 0 - irsnowm_wvhf = 0 - irsnowm_cl = 0 - - irgraupelm_bt = 0 - irgraupelm_ma = 0 - irgraupelm_sd = 0 - irgraupelm_sd_morr = 0 - irgraupelm_dff = 0 - irgraupelm_mc = 0 - irgraupelm_hf = 0 - irgraupelm_wvhf = 0 - irgraupelm_cl = 0 - - iricem_bt = 0 - iricem_ma = 0 - iricem_sd = 0 - iricem_sd_mg_morr = 0 - iricem_dff = 0 - iricem_mc = 0 - iricem_hf = 0 - iricem_wvhf = 0 - iricem_cl = 0 - - iw_KK_evap_covar_zt = 0 - irt_KK_evap_covar_zt = 0 - ithl_KK_evap_covar_zt = 0 - iw_KK_auto_covar_zt = 0 - irt_KK_auto_covar_zt = 0 - ithl_KK_auto_covar_zt = 0 - iw_KK_accr_covar_zt = 0 - irt_KK_accr_covar_zt = 0 - ithl_KK_accr_covar_zt = 0 - irr_KK_mvr_covar_zt = 0 - iNr_KK_mvr_covar_zt = 0 - - ivm_bt = 0 - ivm_ma = 0 - ivm_gf = 0 - ivm_cf = 0 - ivm_ta = 0 - ivm_f = 0 - ivm_sdmp = 0 - ivm_ndg = 0 - - ium_bt = 0 - ium_ma = 0 - ium_gf = 0 - ium_cf = 0 - ium_ta = 0 - ium_f = 0 - ium_sdmp = 0 - ium_ndg = 0 - - imixt_frac = 0 - iw1 = 0 - iw2 = 0 - ivarnce_w1 = 0 - ivarnce_w2 = 0 - ithl1 = 0 - ithl2 = 0 - ivarnce_thl1 = 0 - ivarnce_thl2 = 0 - irt1 = 0 - irt2 = 0 - ivarnce_rt1 = 0 - ivarnce_rt2 = 0 - irc1 = 0 - irc2 = 0 - irsl1 = 0 - irsl2 = 0 - icloud_frac1 = 0 - icloud_frac2 = 0 - is1 = 0 - is2 = 0 - istdev_s1 = 0 - istdev_s2 = 0 - istdev_t1 = 0 - istdev_t2 = 0 - icovar_st_1 = 0 - icovar_st_2 = 0 - icorr_st_1 = 0 - icorr_st_2 = 0 - irrtthl = 0 - icrt1 = 0 - icrt2 = 0 - icthl1 = 0 - icthl2 = 0 - - is_mellor = 0 - - 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 - - iC11_Skw_fnc = 0 - ia3_coef_zt = 0 - iwp3_on_wp2_zt = 0 - - iLscale_pert_1 = 0 - iLscale_pert_2 = 0 - - 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 zt - - k = 1 - do i=1,zt%nn - - select case ( trim(vars_zt(i)) ) - case ('thlm') - ithlm = k - call stat_assign( ithlm, "thlm", & - "Liquid water potential temperature (theta_l) [K]", "K", zt) - k = k + 1 - - case ('T_in_K') - iT_in_K = k - call stat_assign( iT_in_K, "T_in_K", & - "Absolute temperature [K]", "K", zt ) - k = k + 1 - - case ('thvm') - ithvm = k - call stat_assign( ithvm, "thvm", & - "Virtual potential temperature [K]", "K", zt ) - k = k + 1 - - case ('rtm') - irtm = k - - call stat_assign( irtm, "rtm", & - "Total (vapor+liquid) water mixing ratio [kg/kg]", "kg/kg", zt ) - - !zt%f%var(irtm)%ptr => zt%x(:,k) - !zt%f%var(irtm)%name = "rtm" - !zt%f%var(irtm)%description - != "total water mixing ratio (kg/kg)" - !zt%f%var(irtm)%units = "kg/kg" - - k = k + 1 - - case ('rcm') - ircm = k - call stat_assign( ircm, "rcm", & - "Cloud water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rfrzm') - irfrzm = k - call stat_assign( irfrzm, "rfrzm", & - "Total ice phase water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rvm') - irvm = k - call stat_assign( irvm, "rvm", & - "Vapor water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - case ('rel_humidity') - irel_humidity = k - call stat_assign( irel_humidity, "rel_humidity", & - "Relative humidity w.r.t. liquid (range [0,1]) [-]", "[-]", zt ) - k = k + 1 - case ('um') - ium = k - call stat_assign( ium, "um", & - "East-west (u) wind [m/s]", "m/s", zt ) - k = k + 1 - case ('vm') - ivm = k - call stat_assign( ivm, "vm", & - "North-south (v) wind [m/s]", "m/s", zt ) - k = k + 1 - case ('wm_zt') - iwm_zt = k - call stat_assign( iwm_zt, "wm", & - "Vertical (w) wind [m/s]", "m/s", zt ) - k = k + 1 - case ('um_ref') - ium_ref = k - call stat_assign( ium_ref, "um_ref", & - "reference u wind (m/s) [m/s]", "m/s", zt) - k = k + 1 - case ('vm_ref') - ivm_ref = k - call stat_assign( ivm_ref, "vm_ref", & - "reference v wind (m/s) [m/s]", "m/s", zt) - k = k + 1 - case ('ug') - iug = k - call stat_assign( iug, "ug", & - "u geostrophic wind [m/s]", "m/s", zt) - k = k + 1 - case ('vg') - ivg = k - call stat_assign( ivg, "vg", & - "v geostrophic wind [m/s]", "m/s", zt ) - k = k + 1 - case ('cloud_frac') - icloud_frac = k - call stat_assign( icloud_frac, "cloud_frac", & - "Cloud fraction (between 0 and 1) [-]", "count", zt ) - k = k + 1 - - case ('ice_supersat_frac') - iice_supersat_frac = k - call stat_assign( iice_supersat_frac, "ice_supersat_frac", & - "Ice cloud fraction (between 0 and 1) [-]", "count", zt ) - k = k + 1 - - case ('rcm_in_layer') - ircm_in_layer = k - call stat_assign( ircm_in_layer, "rcm_in_layer", & - "rcm in cloud layer [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rcm_in_cloud') - ircm_in_cloud = k - call stat_assign( ircm_in_cloud, "rcm_in_cloud", & - "in-cloud value of rcm (for microphysics) [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('cloud_cover') - icloud_cover = k - call stat_assign( icloud_cover, "cloud_cover", & - "Cloud cover (between 0 and 1) [-]", "count", zt ) - k = k + 1 - case ('p_in_Pa') - ip_in_Pa = k - call stat_assign( ip_in_Pa, "p_in_Pa", & - "Pressure [Pa]", "Pa", zt ) - k = k + 1 - case ('exner') - iexner = k - call stat_assign( iexner, "exner", & - "Exner function = (p/p0)**(rd/cp) [-]", "count", zt ) - k = k + 1 - case ('rho_ds_zt') - irho_ds_zt = k - call stat_assign( irho_ds_zt, "rho_ds_zt", & - "Dry, static, base-state density [kg/m^3]", "kg m^{-3}", zt ) - k = k + 1 - case ('thv_ds_zt') - ithv_ds_zt = k - call stat_assign( ithv_ds_zt, "thv_ds_zt", & - "Dry, base-state theta_v [K]", "K", zt ) - k = k + 1 - case ('Lscale') - iLscale = k - call stat_assign( iLscale, "Lscale", & - "Mixing length [m]", "m", zt ) - k = k + 1 - case ('thlm_forcing') - ithlm_forcing = k - call stat_assign( ithlm_forcing, "thlm_forcing", & - "thlm budget: thetal forcing (includes thlm_mc and radht) [K s^{-1}]", "K s^{-1}", zt ) - k = k + 1 - case ('thlm_mc') - ithlm_mc = k - call stat_assign( ithlm_mc, "thlm_mc", & - "Change in thlm due to microphysics (not in budget) [K s^{-1}]", "K s^{-1}", zt ) - k = k + 1 - case ('rtm_forcing') - irtm_forcing = k - call stat_assign( irtm_forcing, "rtm_forcing", & - "rtm budget: rt forcing (includes rtm_mc) [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", & - zt ) - k = k + 1 - - case ('rtm_mc') - irtm_mc = k - call stat_assign( irtm_mc, "rtm_mc", & - "Change in rt due to microphysics (not in budget) [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rvm_mc') - irvm_mc = k - call stat_assign( irvm_mc, "rvm_mc", & - "Time tendency of vapor mixing ratio due to microphysics [kg/kg/s]", "kg/(kg s)", zt ) - k = k + 1 - - case ('rcm_mc') - ircm_mc = k - call stat_assign( ircm_mc, "rcm_mc", & - "Time tendency of liquid water mixing ratio due microphysics [kg/kg/s]", & - "kg/kg/s", zt ) - k = k + 1 - - case ('rcm_sd_mg_morr') - ircm_sd_mg_morr = k - call stat_assign( ircm_sd_mg_morr, "rcm_sd_mg_morr", & - "rcm sedimentation when using morrision or MG microphysics (not in budget," & - // " included in rcm_mc) [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('thlm_mfl_min') - ithlm_mfl_min = k - call stat_assign( ithlm_mfl_min, "thlm_mfl_min", & - "Minimum allowable thlm [K]", "K", zt ) - k = k + 1 - - case ('thlm_mfl_max') - ithlm_mfl_max = k - call stat_assign( ithlm_mfl_max, "thlm_mfl_max", & - "Maximum allowable thlm [K]", "K", zt ) - k = k + 1 - - case ('thlm_enter_mfl') - ithlm_enter_mfl = k - call stat_assign( ithlm_enter_mfl, "thlm_enter_mfl", & - "Thlm before flux-limiter [K]", "K", zt ) - k = k + 1 - - case ('thlm_exit_mfl') - ithlm_exit_mfl = k - call stat_assign( ithlm_exit_mfl, "thlm_exit_mfl", & - "Thlm exiting flux-limiter [K]", "K", zt ) - k = k + 1 - - case ('thlm_old') - ithlm_old = k - call stat_assign( ithlm_old, "thlm_old", & - "Thlm at previous timestep [K]", "K", zt ) - k = k + 1 - - case ('thlm_without_ta') - ithlm_without_ta = k - call stat_assign( ithlm_without_ta, "thlm_without_ta", & - "Thlm without turbulent advection contribution [K]", "K", zt ) - k = k + 1 - - case ('rtm_mfl_min') - irtm_mfl_min = k - call stat_assign( irtm_mfl_min, "rtm_mfl_min", & - "Minimum allowable rtm [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rtm_mfl_max') - irtm_mfl_max = k - call stat_assign( irtm_mfl_max, "rtm_mfl_max", & - "Maximum allowable rtm [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rtm_enter_mfl') - irtm_enter_mfl = k - call stat_assign( irtm_enter_mfl, "rtm_enter_mfl", & - "Rtm before flux-limiter [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rtm_exit_mfl') - irtm_exit_mfl = k - call stat_assign( irtm_exit_mfl, "rtm_exit_mfl", & - "Rtm exiting flux-limiter [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rtm_old') - irtm_old = k - call stat_assign( irtm_old, "rtm_old", & - "Rtm at previous timestep [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rtm_without_ta') - irtm_without_ta = k - call stat_assign( irtm_without_ta, "rtm_without_ta", & - "Rtm without turbulent advection contribution [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('wp3') - iwp3 = k - call stat_assign( iwp3, "wp3", & - "w third order moment [m^3/s^3]", "m^3/s^3", zt ) - k = k + 1 - - case ('wpthlp2') - iwpthlp2 = k - call stat_assign( iwpthlp2, "wpthlp2", & - "w'thl'^2 [(m K^2)/s]", "(m K^2)/s", zt ) - k = k + 1 - - case ('wp2thlp') - iwp2thlp = k - call stat_assign( iwp2thlp, "wp2thlp", & - "w'^2thl' [(m^2 K)/s^2]", "(m^2 K)/s^2", zt ) - k = k + 1 - - case ('wprtp2') - iwprtp2 = k - call stat_assign( iwprtp2, "wprtp2", & - "w'rt'^2 [(m kg)/(s kg)]", "(m kg)/(s kg)", zt ) - k = k + 1 - - case ('wp2rtp') - iwp2rtp = k - call stat_assign( iwp2rtp, "wp2rtp", & - "w'^2rt' [(m^2 kg)/(s^2 kg)]", "(m^2 kg)/(s^2 kg)", zt ) - k = k + 1 - - case ('Lscale_up') - iLscale_up = k - call stat_assign( iLscale_up, "Lscale_up", & - "Upward mixing length [m]", "m", zt ) - k = k + 1 - - case ('Lscale_down') - iLscale_down = k - call stat_assign( iLscale_down, "Lscale_down", & - "Downward mixing length [m]", "m", zt ) - k = k + 1 - - case ('Lscale_pert_1') - iLscale_pert_1 = k - call stat_assign( iLscale_pert_1, "Lscale_pert_1", & - "Mixing length using a perturbed value of rtm/thlm [m]", "m", zt ) - k = k + 1 - - case ('Lscale_pert_2') - iLscale_pert_2 = k - call stat_assign( iLscale_pert_2, "Lscale_pert_2", & - "Mixing length using a perturbed value of rtm/thlm [m]", "m", zt ) - k = k + 1 - - case ('tau_zt') - itau_zt = k - call stat_assign( itau_zt, "tau_zt", & - "Dissipation time [s]", "s", zt ) - k = k + 1 - - case ('Kh_zt') - iKh_zt = k - call stat_assign( iKh_zt, "Kh_zt", & - "Eddy diffusivity [m^2/s]", "m^2/s", zt ) - k = k + 1 - - case ('wp2thvp') - iwp2thvp = k - call stat_assign( iwp2thvp, "wp2thvp", & - "w'^2thv' [K m^2/s^2]", "K m^2/s^2", zt ) - k = k + 1 - - case ('wp2rcp') - iwp2rcp = k - call stat_assign( iwp2rcp, "wp2rcp", & - "w'^2rc' [(m^2 kg)/(s^2 kg)]", "(m^2 kg)/(s^2 kg)", zt ) - k = k + 1 - - case ('wprtpthlp') - iwprtpthlp = k - call stat_assign( iwprtpthlp, "wprtpthlp", & - "w'rt'thl' [(m kg K)/(s kg)]", "(m kg K)/(s kg)", zt ) - k = k + 1 - - case ('sigma_sqd_w_zt') - isigma_sqd_w_zt = k - call stat_assign( isigma_sqd_w_zt, "sigma_sqd_w_zt", & - "Nondimensionalized w variance of Gaussian component [-]", "-", zt ) - k = k + 1 - - case ('rho') - irho = k - call stat_assign( irho, "rho", & - "Air density [kg/m^3]", "kg m^{-3}", zt ) - k = k + 1 - - case ('Ncm') ! Brian - iNcm = k - call stat_assign( iNcm, "Ncm", & - "Cloud droplet number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('Ncm_in_cloud') - iNcm_in_cloud = k - - call stat_assign( iNcm_in_cloud, "Ncm_in_cloud", & - "In cloud droplet concentration [num/kg]", "num/kg", zt ) - - k = k + 1 - - case ('Nc_activated') - iNc_activated = k - - call stat_assign( iNc_activated, "Nc_activated", & - "Droplets activated by GFDL activation [num/kg]", "num/kg", zt ) - - k = k + 1 - - case ('Ncnm') - iNcnm = k - call stat_assign( iNcnm, "Ncnm", & - "Cloud nuclei number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('Nim') ! Brian - iNim = k - call stat_assign( iNim, "Nim", & - "Ice crystal number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('snowslope') ! Adam Smith, 22 April 2008 - isnowslope = k - call stat_assign( isnowslope, "snowslope", & - "COAMPS microphysics snow slope parameter [1/m]", & - "1/m", zt ) - k = k + 1 - - case ('Nsnowm') ! Adam Smith, 22 April 2008 - iNsnowm = k - call stat_assign( iNsnowm, "Nsnowm", & - "Snow particle number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('Ngraupelm') - iNgraupelm = k - call stat_assign( iNgraupelm, "Ngraupelm", & - "Graupel number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('sed_rcm') ! Brian - ised_rcm = k - call stat_assign( ised_rcm, "sed_rcm", & - "d(rcm)/dt due to cloud sedimentation [kg / (m^2 s)]", & - "kg / [m^2 s]", zt ) - k = k + 1 - - case ('rsat') ! Brian - irsat = k - call stat_assign( irsat, "rsat", & - "Saturation mixing ratio over liquid [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rsati') - irsati = k - call stat_assign( irsati, "rsati", & - "Saturation mixing ratio over ice [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rrainm') ! Brian - irrainm = k - call stat_assign( irrainm, "rrainm", & - "Rain water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rsnowm') - irsnowm = k - call stat_assign( irsnowm, "rsnowm", & - "Snow water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('ricem') - iricem = k - call stat_assign( iricem, "ricem", & - "Pristine ice water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rgraupelm') - irgraupelm = k - call stat_assign( irgraupelm, "rgraupelm", & - "Graupel water mixing ratio [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('Nrm') ! Brian - iNrm = k - call stat_assign( iNrm, "Nrm", & - "Rain drop number concentration [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ('m_vol_rad_rain') ! Brian - im_vol_rad_rain = k - call stat_assign( im_vol_rad_rain, "mvrr", & - "Rain drop mean volume radius [m]", "m", zt ) - k = k + 1 - - case ('m_vol_rad_cloud') - im_vol_rad_cloud = k - call stat_assign( im_vol_rad_cloud, "m_vol_rad_cloud", & - "Cloud drop mean volume radius [m]", "m", zt ) - k = k + 1 - - case ('eff_rad_cloud') - ieff_rad_cloud = k - call stat_assign( ieff_rad_cloud, "eff_rad_cloud", & - "Cloud drop effective volume radius [microns]", "microns", zt ) - k = k + 1 - - case ('eff_rad_ice') - ieff_rad_ice = k - - call stat_assign( ieff_rad_ice, "eff_rad_ice", & - "Ice effective volume radius [microns]", "microns", zt ) - k = k + 1 - - case ('eff_rad_snow') - ieff_rad_snow = k - call stat_assign( ieff_rad_snow, "eff_rad_snow", & - "Snow effective volume radius [microns]", "microns", zt ) - k = k + 1 - - case ('eff_rad_rain') - ieff_rad_rain = k - call stat_assign( ieff_rad_rain, "eff_rad_rain", & - "Rain drop effective volume radius [microns]", "microns", zt ) - k = k + 1 - - case ('eff_rad_graupel') - ieff_rad_graupel = k - call stat_assign( ieff_rad_graupel, "eff_rad_graupel", & - "Graupel effective volume radius [microns]", "microns", zt ) - k = k + 1 - - case ('rain_rate_zt') ! Brian - irain_rate_zt = k - - call stat_assign( irain_rate_zt, "rain_rate_zt", & - "Rain rate [mm/day]", "mm/day", zt ) - k = k + 1 - - case ('radht') - iradht = k - - call stat_assign( iradht, "radht", & - "Total (sw+lw) radiative heating rate [K/s]", "K/s", zt ) - k = k + 1 - - case ('radht_LW') - iradht_LW = k - - call stat_assign( iradht_LW, "radht_LW", & - "Long-wave radiative heating rate [K/s]", "K/s", zt ) - - k = k + 1 - - case ('radht_SW') - iradht_SW = k - call stat_assign( iradht_SW, "radht_SW", & - "Short-wave radiative heating rate [K/s]", "K/s", zt ) - k = k + 1 - - case ('diam') - idiam = k - - call stat_assign( idiam, "diam", & - "Ice crystal diameter [m]", "m", zt ) - k = k + 1 - - case ('mass_ice_cryst') - imass_ice_cryst = k - call stat_assign( imass_ice_cryst, "mass_ice_cryst", & - "Mass of a single ice crystal [kg]", "kg", zt ) - k = k + 1 - - case ('rcm_icedfs') - - ircm_icedfs = k - call stat_assign( ircm_icedfs, "rcm_icedfs", & - "Change in liquid due to ice [kg/kg/s]", "kg/kg/s", zt ) - k = k + 1 - - case ('u_T_cm') - iu_T_cm = k - call stat_assign( iu_T_cm, "u_T_cm", & - "Ice crystal fallspeed [cm s^{-1}]", "cm s^{-1}", zt ) - k = k + 1 - - case ('rtm_bt') - irtm_bt = k - - call stat_assign( irtm_bt, "rtm_bt", & - "rtm budget: rtm time tendency [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt) - k = k + 1 - - case ('rtm_ma') - irtm_ma = k - - call stat_assign( irtm_ma, "rtm_ma", & - "rtm budget: rtm vertical mean advection [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt) - k = k + 1 - - case ('rtm_ta') - irtm_ta = k - - call stat_assign( irtm_ta, "rtm_ta", & - "rtm budget: rtm turbulent advection [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt) - k = k + 1 - - case ('rtm_mfl') - irtm_mfl = k - - call stat_assign( irtm_mfl, "rtm_mfl", & - "rtm budget: rtm correction due to monotonic flux limiter [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt) - k = k + 1 - - case ('rtm_tacl') - irtm_tacl = k - - call stat_assign( irtm_tacl, "rtm_tacl", & - "rtm budget: rtm correction due to ta term (wprtp) clipping [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt) - - k = k + 1 - - case ('rtm_cl') - irtm_cl = k - - call stat_assign( irtm_cl, "rtm_cl", & - "rtm budget: rtm clipping [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt) - - k = k + 1 - case ('rtm_sdmp') - irtm_sdmp = k - - call stat_assign( irtm_sdmp, "rtm_sdmp", & - "rtm budget: rtm correction due to sponge damping [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt) - k = k + 1 - - - case ('rtm_pd') - irtm_pd = k - - call stat_assign( irtm_pd, "rtm_pd", & - "rtm budget: rtm positive definite adjustment [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt) - - k = k + 1 - - case ('thlm_bt') - ithlm_bt = k - - call stat_assign( ithlm_bt, "thlm_bt", & - "thlm budget: thlm time tendency [K s^{-1}]", "K s^{-1}", zt) - k = k + 1 - - case ('thlm_ma') - ithlm_ma = k - - call stat_assign( ithlm_ma, "thlm_ma", & - "thlm budget: thlm vertical mean advection [K s^{-1}]", "K s^{-1}", zt) - k = k + 1 - - case ('thlm_sdmp') - ithlm_sdmp = k - - call stat_assign( ithlm_sdmp, "thlm_sdmp", & - "thlm budget: thlm correction due to sponge damping [K s^{-1}]", "K s^{-1}", zt) - k = k + 1 - - - case ('thlm_ta') - ithlm_ta = k - - call stat_assign( ithlm_ta, "thlm_ta", & - "thlm budget: thlm turbulent advection [K s^{-1}]", "K s^{-1}", zt) - k = k + 1 - - case ('thlm_mfl') - ithlm_mfl = k - - call stat_assign( ithlm_mfl, "thlm_mfl", & - "thlm budget: thlm correction due to monotonic flux limiter [K s^{-1}]", & - "K s^{-1}", zt) - k = k + 1 - - case ('thlm_tacl') - ithlm_tacl = k - - call stat_assign( ithlm_tacl, "thlm_tacl", & - "thlm budget: thlm correction due to ta term (wpthlp) clipping [K s^{-1}]", & - "K s^{-1}", zt) - k = k + 1 - - case ('thlm_cl') - ithlm_cl = k - - call stat_assign( ithlm_cl, "thlm_cl", & - "thlm budget: thlm_cl [K s^{-1}]", "K s^{-1}", zt) - k = k + 1 - - case ('wp3_bt') - iwp3_bt = k - - call stat_assign( iwp3_bt, "wp3_bt", & - "wp3 budget: wp3 time tendency [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_ma') - iwp3_ma = k - - call stat_assign( iwp3_ma, "wp3_ma", & - "wp3 budget: wp3 vertical mean advection [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_ta') - iwp3_ta = k - - call stat_assign( iwp3_ta, "wp3_ta", & - "wp3 budget: wp3 turbulent advection [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - - k = k + 1 - - case ('wp3_tp') - iwp3_tp = k - call stat_assign( iwp3_tp, "wp3_tp", & - "wp3 budget: wp3 turbulent transport [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_ac') - iwp3_ac = k - call stat_assign( iwp3_ac, "wp3_ac", & - "wp3 budget: wp3 accumulation term [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_bp1') - iwp3_bp1 = k - call stat_assign( iwp3_bp1, "wp3_bp1", & - "wp3 budget: wp3 buoyancy production [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_bp2') - iwp3_bp2 = k - call stat_assign( iwp3_bp2, "wp3_bp2", & - "wp3 budget: wp3 2nd buoyancy production term [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_pr1') - iwp3_pr1 = k - call stat_assign( iwp3_pr1, "wp3_pr1", & - "wp3 budget: wp3 pressure term 1 [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_pr2') - iwp3_pr2 = k - call stat_assign( iwp3_pr2, "wp3_pr2", & - "wp3 budget: wp3 pressure term 2 [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - - k = k + 1 - - case ('wp3_dp1') - iwp3_dp1 = k - call stat_assign( iwp3_dp1, "wp3_dp1", & - "wp3 budget: wp3 dissipation term 1 [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_4hd') - iwp3_4hd = k - call stat_assign( iwp3_4hd, "wp3_4hd", & - "wp3 budget: wp3 4th-order hyper-diffusion [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('wp3_cl') - iwp3_cl = k - call stat_assign( iwp3_cl, "wp3_cl", & - "wp3 budget: wp3 clipping term [m^{3} s^{-4}]", "m^{3} s^{-4}", zt ) - k = k + 1 - - case ('rrainm_bt') - irrainm_bt = k - call stat_assign( irrainm_bt, "rrainm_bt", & - "rrainm budget: rrainm time tendency [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_ma') - irrainm_ma = k - - call stat_assign( irrainm_ma, "rrainm_ma", & - "rrainm budget: rrainm vertical mean advection [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_sd') - irrainm_sd = k - - call stat_assign( irrainm_sd, "rrainm_sd", & - "rrainm budget: rrainm sedimentation [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_ts') - irrainm_ts = k - - call stat_assign( irrainm_ts, "rrainm_ts", & - "rrainm budget: rrainm turbulent sedimentation" & - //" [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_sd_morr') - irrainm_sd_morr = k - - call stat_assign( irrainm_sd_morr, "rrainm_sd_morr", & - "rrainm sedimentation when using morrision microphysics (not in budget, included" & - // " in rrainm_mc) [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_dff') - irrainm_dff = k - - call stat_assign( irrainm_dff, "rrainm_dff", & - "rrainm budget: rrainm diffusion [kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_cond') - irrainm_cond = k - - call stat_assign( irrainm_cond, "rrainm_cond", & - "rrainm evaporation rate [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_auto') - irrainm_auto = k - - call stat_assign( irrainm_auto, "rrainm_auto", & - "rrainm autoconversion rate [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_accr') - irrainm_accr = k - call stat_assign( irrainm_accr, "rrainm_accr", & - "rrainm accretion rate [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_cond_adj') - irrainm_cond_adj = k - - call stat_assign( irrainm_cond_adj, "rrainm_cond_adj", & - "rrainm evaporation adjustment due to over-evaporation " // & - "[kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_src_adj') - irrainm_src_adj = k - - call stat_assign( irrainm_src_adj, "rrainm_src_adj", & - "rrainm source term adjustment due to over-depletion " // & - "[kg kg^{-1} s^{-1}]", "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_tsfl') - irrainm_tsfl = k - - call stat_assign( irrainm_tsfl, "rrainm_tsfl", & - "rrainm budget: rrainm turbulent sedimentation flux limiter" & - //" [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_hf') - irrainm_hf = k - call stat_assign( irrainm_hf, "rrainm_hf", & - "rrainm budget: rrainm hole-filling term [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_wvhf') - irrainm_wvhf = k - call stat_assign( irrainm_wvhf, "rrainm_wvhf", & - "rrainm budget: rrainm water vapor hole-filling term [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_cl') - irrainm_cl = k - call stat_assign( irrainm_cl, "rrainm_cl", & - "rrainm budget: rrainm clipping term [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('rrainm_mc') - irrainm_mc = k - - call stat_assign( irrainm_mc, "rrainm_mc", & - "rrainm budget: Change in rrainm due to microphysics [kg kg^{-1} s^{-1}]", & - "kg kg^{-1} s^{-1}", zt ) - k = k + 1 - - case ('Nrm_bt') - iNrm_bt = k - call stat_assign( iNrm_bt, "Nrm_bt", & - "Nrm budget: Nrm time tendency [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nrm_ma') - iNrm_ma = k - - call stat_assign( iNrm_ma, "Nrm_ma", & - "Nrm budget: Nrm vertical mean advection [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_sd') - iNrm_sd = k - - call stat_assign( iNrm_sd, "Nrm_sd", & - "Nrm budget: Nrm sedimentation [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nrm_ts') - iNrm_ts = k - - call stat_assign( iNrm_ts, "Nrm_ts", & - "Nrm budget: Nrm turbulent sedimentation [(num/kg)/s]", & - "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_dff') - iNrm_dff = k - call stat_assign( iNrm_dff, "Nrm_dff", & - "Nrm budget: Nrm diffusion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nrm_cond') - iNrm_cond = k - - call stat_assign( iNrm_cond, "Nrm_cond", & - "Nrm evaporation rate [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_auto') - iNrm_auto = k - - call stat_assign( iNrm_auto, "Nrm_auto", & - "Nrm autoconversion rate [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nrm_cond_adj') - iNrm_cond_adj = k - - call stat_assign( iNrm_cond_adj, "Nrm_cond_adj", & - "Nrm evaporation adjustment due to over-evaporation [(num/kg)/s]", & - "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_src_adj') - iNrm_src_adj = k - - call stat_assign( iNrm_src_adj, "Nrm_src_adj", & - "Nrm source term adjustment due to over-depletion [(num/kg)/s]", & - "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_tsfl') - iNrm_tsfl = k - - call stat_assign( iNrm_tsfl, "Nrm_tsfl", & - "Nrm budget: Nrm turbulent sedimentation flux limiter" & - //" [(num/kg)/s]", & - "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_cl') - iNrm_cl = k - call stat_assign( iNrm_cl, "Nrm_cl", & - "Nrm budget: Nrm clipping term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nrm_mc') - iNrm_mc = k - call stat_assign( iNrm_mc, "Nrm_mc", & - "Nrm budget: Change in Nrm due to microphysics (Not in budget) [(num/kg)/s]", & - "(num/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_bt') - irsnowm_bt = k - call stat_assign( irsnowm_bt, "rsnowm_bt", & - "rsnowm budget: rsnowm time tendency [(kg/kg)/s]", "(kg/kg)/s", zt ) - - k = k + 1 - - case ('rsnowm_ma') - irsnowm_ma = k - - call stat_assign( irsnowm_ma, "rsnowm_ma", & - "rsnowm budget: rsnowm vertical mean advection [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_sd') - irsnowm_sd = k - call stat_assign( irsnowm_sd, "rsnowm_sd", & - "rsnowm budget: rsnowm sedimentation [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_sd_morr') - irsnowm_sd_morr = k - call stat_assign( irsnowm_sd_morr, "rsnowm_sd_morr", & - "rsnowm sedimentation when using morrison microphysics (Not in budget, included in" & - // " rsnowm_mc) [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_dff') - irsnowm_dff = k - - call stat_assign( irsnowm_dff, "rsnowm_dff", & - "rsnowm budget: rsnowm diffusion [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_mc') - irsnowm_mc = k - - call stat_assign( irsnowm_mc, "rsnowm_mc", & - "rsnowm budget: Change in rsnowm due to microphysics [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_hf') - irsnowm_hf = k - - call stat_assign( irsnowm_hf, "rsnowm_hf", & - "rsnowm budget: rsnowm hole-filling term [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_wvhf') - irsnowm_wvhf = k - - call stat_assign( irsnowm_wvhf, "rsnowm_wvhf", & - "rsnowm budget: rsnowm water vapor hole-filling term [(kg/kg)/s]", & - "(kg/kg)/s", zt ) - k = k + 1 - - case ('rsnowm_cl') - irsnowm_cl = k - - call stat_assign( irsnowm_cl, "rsnowm_cl", & - "rsnowm budget: rsnowm clipping term [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('Nsnowm_bt') - iNsnowm_bt = k - call stat_assign( iNsnowm_bt, "Nsnowm_bt", & - "Nsnowm budget: [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nsnowm_ma') - iNsnowm_ma = k - - call stat_assign( iNsnowm_ma, "Nsnowm_ma", & - "Nsnowm budget: Nsnowm mean advection [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nsnowm_sd') - iNsnowm_sd = k - - call stat_assign( iNsnowm_sd, "Nsnowm_sd", & - "Nsnowm budget: Nsnowm sedimentation [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nsnowm_dff') - iNsnowm_dff = k - call stat_assign( iNsnowm_dff, "Nsnowm_dff", & - "Nsnowm budget: Nsnowm diffusion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nsnowm_mc') - iNsnowm_mc = k - call stat_assign( iNsnowm_mc, "Nsnowm_mc", & - "Nsnowm budget: Nsnowm microphysics [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nsnowm_cl') - iNsnowm_cl = k - - call stat_assign( iNsnowm_cl, "Nsnowm_cl", & - "Nsnowm budget: Nsnowm clipping term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('ricem_bt') - iricem_bt = k - - call stat_assign( iricem_bt, "ricem_bt", & - "ricem budget: ricem time tendency [(kg/kg)/s]", "(kg/kg)/s", zt ) - - k = k + 1 - - case ('ricem_ma') - iricem_ma = k - - call stat_assign( iricem_ma, "ricem_ma", & - "ricem budget: ricem vertical mean advection [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_sd') - iricem_sd = k - - call stat_assign( iricem_sd, "ricem_sd", & - "ricem budget: ricem sedimentation [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_sd_mg_morr') - iricem_sd_mg_morr = k - - call stat_assign( iricem_sd_mg_morr, "ricem_sd_mg_morr", & - "ricem sedimentation when using morrison or MG microphysics (not in budget," & - // " included in ricem_mc) [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_dff') - iricem_dff = k - - call stat_assign( iricem_dff, "ricem_dff", & - "ricem budget: ricem diffusion [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_mc') - iricem_mc = k - - call stat_assign( iricem_mc, "ricem_mc", & - "ricem budget: Change in ricem due to microphysics [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_hf') - iricem_hf = k - - call stat_assign( iricem_hf, "ricem_hf", & - "ricem budget: ricem hole-filling term [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_wvhf') - iricem_wvhf = k - - call stat_assign( iricem_wvhf, "ricem_wvhf", & - "ricem budget: ricem water vapor hole-filling term [(kg/kg)/s]", & - "(kg/kg)/s", zt ) - k = k + 1 - - case ('ricem_cl') - iricem_cl = k - - call stat_assign( iricem_cl, "ricem_cl", & - "ricem budget: ricem clipping term [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_bt') - irgraupelm_bt = k - - call stat_assign( irgraupelm_bt, "rgraupelm_bt", & - "rgraupelm budget: rgraupelm time tendency [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_ma') - irgraupelm_ma = k - - call stat_assign( irgraupelm_ma, "rgraupelm_ma", & - "rgraupelm budget: rgraupelm vertical mean advection [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_sd') - irgraupelm_sd = k - - call stat_assign( irgraupelm_sd, "rgraupelm_sd", & - "rgraupelm budget: rgraupelm sedimentation [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_sd_morr') - irgraupelm_sd_morr = k - - call stat_assign( irgraupelm_sd_morr, "rgraupelm_sd_morr", & - "rgraupelm sedimentation when using morrison microphysics (not in budget, included" & - // " in rgraupelm_mc) [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_dff') - irgraupelm_dff = k - - call stat_assign( irgraupelm_dff, "rgraupelm_dff", & - "rgraupelm budget: rgraupelm diffusion [(kg/kg)/s]", "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_mc') - irgraupelm_mc = k - - call stat_assign( irgraupelm_mc, "rgraupelm_mc", & - "rgraupelm budget: Change in rgraupelm due to microphysics [(kg/kg)/s]", & - "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_hf') - irgraupelm_hf = k - - call stat_assign( irgraupelm_hf, "rgraupelm_hf", & - "rgraupelm budget: rgraupelm hole-filling term [(kg/kg)/s]", & - "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_wvhf') - irgraupelm_wvhf = k - - call stat_assign( irgraupelm_wvhf, "rgraupelm_wvhf", & - "rgraupelm budget: rgraupelm water vapor hole-filling term [(kg/kg)/s]", & - "(kg/kg)/s", zt ) - k = k + 1 - - case ('rgraupelm_cl') - irgraupelm_cl = k - - call stat_assign( irgraupelm_cl, "rgraupelm_cl", & - "rgraupelm budget: rgraupelm clipping term [(kg/kg)/s]", & - "(kg/kg)/s", zt ) - k = k + 1 - - case ('Ngraupelm_bt') - iNgraupelm_bt = k - call stat_assign( iNgraupelm_bt, "Ngraupelm_bt", & - "Ngraupelm budget: [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ngraupelm_ma') - iNgraupelm_ma = k - - call stat_assign( iNgraupelm_ma, "Ngraupelm_ma", & - "Ngraupelm budget: Ngraupelm mean advection [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Ngraupelm_sd') - iNgraupelm_sd = k - - call stat_assign( iNgraupelm_sd, "Ngraupelm_sd", & - "Ngraupelm budget: Ngraupelm sedimentation [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ngraupelm_dff') - iNgraupelm_dff = k - call stat_assign( iNgraupelm_dff, "Ngraupelm_dff", & - "Ngraupelm budget: Ngraupelm diffusion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ngraupelm_mc') - iNgraupelm_mc = k - - call stat_assign( iNgraupelm_mc, "Ngraupelm_mc", & - "Ngraupelm budget: Ngraupelm microphysics term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Ngraupelm_cl') - iNgraupelm_cl = k - - call stat_assign( iNgraupelm_cl, "Ngraupelm_cl", & - "Ngraupelm budget: Ngraupelm clipping term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nim_bt') - iNim_bt = k - call stat_assign( iNim_bt, "Nim_bt", & - "Nim budget: [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nim_ma') - iNim_ma = k - - call stat_assign( iNim_ma, "Nim_ma", & - "Nim budget: Nim mean advection [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nim_sd') - iNim_sd = k - - call stat_assign( iNim_sd, "Nim_sd", & - "Nim budget: Nim sedimentation [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nim_dff') - iNim_dff = k - call stat_assign( iNim_dff, "Nim_dff", & - "Nim budget: Nim diffusion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Nim_mc') - iNim_mc = k - - call stat_assign( iNim_mc, "Nim_mc", & - "Nim budget: Nim microphysics term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Nim_cl') - iNim_cl = k - - call stat_assign( iNim_cl, "Nim_cl", & - "Nim budget: Nim clipping term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Ncm_bt') - iNcm_bt = k - call stat_assign( iNcm_bt, "Ncm_bt", & - "Ncm budget: Cloud droplet number concentration budget [(num/kg)/s]", & - "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ncm_ma') - iNcm_ma = k - - call stat_assign( iNcm_ma, "Ncm_ma", & - "Ncm budget: Ncm vertical mean advection [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Ncm_act') - iNcm_act = k - - call stat_assign( iNcm_act, "Ncm_act", & - "Ncm budget: Change in Ncm due to activation [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ncm_dff') - iNcm_dff = k - call stat_assign( iNcm_dff, "Ncm_dff", & - "Ncm budget: Ncm diffusion [(num/kg)/s]", "(num/kg)/s", zt ) - - k = k + 1 - - case ('Ncm_mc') - iNcm_mc = k - - call stat_assign( iNcm_mc, "Ncm_mc", & - "Ncm budget: Change in Ncm due to microphysics [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('Ncm_cl') - iNcm_cl = k - - call stat_assign( iNcm_cl, "Ncm_cl", & - "Ncm budget: Ncm clipping term [(num/kg)/s]", "(num/kg)/s", zt ) - k = k + 1 - - case ('w_KK_evap_covar_zt') - iw_KK_evap_covar_zt = k - - call stat_assign( iw_KK_evap_covar_zt, "w_KK_evap_covar_zt", & - "Covariance of w and KK evaporation rate", "m*(kg/kg)/s^2", zt ) - k = k + 1 - - case ('rt_KK_evap_covar_zt') - irt_KK_evap_covar_zt = k - - call stat_assign( irt_KK_evap_covar_zt, "rt_KK_evap_covar_zt", & - "Covariance of r_t and KK evaporation rate", "(kg/kg)^2/s", zt ) - k = k + 1 - - case ('thl_KK_evap_covar_zt') - ithl_KK_evap_covar_zt = k - - call stat_assign( ithl_KK_evap_covar_zt, "thl_KK_evap_covar_zt", & - "Covariance of theta_l and KK evaporation rate", "K*(kg/kg)/s", zt ) - k = k + 1 - - case ('w_KK_auto_covar_zt') - iw_KK_auto_covar_zt = k - - call stat_assign( iw_KK_auto_covar_zt, "w_KK_auto_covar_zt", & - "Covariance of w and KK autoconversion rate", "m*(kg/kg)/s^2", zt ) - k = k + 1 - - case ('rt_KK_auto_covar_zt') - irt_KK_auto_covar_zt = k - - call stat_assign( irt_KK_auto_covar_zt, "rt_KK_auto_covar_zt", & - "Covariance of r_t and KK autoconversion rate", "(kg/kg)^2/s", zt ) - k = k + 1 - - case ('thl_KK_auto_covar_zt') - ithl_KK_auto_covar_zt = k - - call stat_assign( ithl_KK_auto_covar_zt, "thl_KK_auto_covar_zt", & - "Covariance of theta_l and KK autoconversion rate", "K*(kg/kg)/s", & - zt ) - k = k + 1 - - case ('w_KK_accr_covar_zt') - iw_KK_accr_covar_zt = k - - call stat_assign( iw_KK_accr_covar_zt, "w_KK_accr_covar_zt", & - "Covariance of w and KK accretion rate", "m*(kg/kg)/s^2", zt ) - k = k + 1 - - case ('rt_KK_accr_covar_zt') - irt_KK_accr_covar_zt = k - - call stat_assign( irt_KK_accr_covar_zt, "rt_KK_accr_covar_zt", & - "Covariance of r_t and KK accretion rate", "(kg/kg)^2/s", zt ) - k = k + 1 - - case ('thl_KK_accr_covar_zt') - ithl_KK_accr_covar_zt = k - - call stat_assign( ithl_KK_accr_covar_zt, "thl_KK_accr_covar_zt", & - "Covariance of theta_l and KK accretion rate", "K*(kg/kg)/s", zt ) - k = k + 1 - - case ('rr_KK_mvr_covar_zt') - irr_KK_mvr_covar_zt = k - - call stat_assign( irr_KK_mvr_covar_zt, "rr_KK_mvr_covar_zt", & - "Covariance of r_r and KK rain drop mean volume radius [(kg/kg)m]", & - "(kg/kg)m", zt ) - k = k + 1 - - case ('Nr_KK_mvr_covar_zt') - iNr_KK_mvr_covar_zt = k - - call stat_assign( iNr_KK_mvr_covar_zt, "Nr_KK_mvr_covar_zt", & - "Covariance of N_r and KK rain drop mean volume radius [(num/kg)m]", & - "(num/kg)m", zt ) - k = k + 1 - - case ('vm_bt') - ivm_bt = k - - call stat_assign( ivm_bt, "vm_bt", & - "vm budget: vm time tendency [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_ma') - ivm_ma = k - call stat_assign( ivm_ma, "vm_ma", & - "vm budget: vm vertical mean advection [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_gf') - ivm_gf = k - - call stat_assign( ivm_gf, "vm_gf", & - "vm budget: vm geostrophic forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_cf') - ivm_cf = k - - call stat_assign( ivm_cf, "vm_cf", & - "vm budget: vm coriolis forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_ta') - ivm_ta = k - - call stat_assign( ivm_ta, "vm_ta", & - "vm budget: vm turbulent transport [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_f') - ivm_f = k - call stat_assign( ivm_f, "vm_f", & - "vm budget: vm forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_sdmp') - ivm_sdmp = k - call stat_assign( ivm_sdmp, "vm_sdmp", & - "vm budget: vm sponge damping [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('vm_ndg') - ivm_ndg = k - call stat_assign( ivm_ndg, "vm_ndg", & - "vm budget: vm nudging [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_bt') - ium_bt = k - - call stat_assign( ium_bt, "um_bt", & - "um budget: um time tendency [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_ma') - ium_ma = k - - call stat_assign( ium_ma, "um_ma", & - "um budget: um vertical mean advection [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_gf') - ium_gf = k - call stat_assign( ium_gf, "um_gf", & - "um budget: um geostrophic forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_cf') - ium_cf = k - call stat_assign( ium_cf, "um_cf", & - "um budget: um coriolis forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_ta') - ium_ta = k - call stat_assign( ium_ta, "um_ta", & - "um budget: um turbulent advection [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_f') - ium_f = k - call stat_assign( ium_f, "um_f", & - "um budget: um forcing [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_sdmp') - ium_sdmp = k - call stat_assign( ium_sdmp, "um_sdmp", & - "um budget: um sponge damping [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('um_ndg') - ium_ndg = k - call stat_assign( ium_ndg, "um_ndg", & - "um budget: um nudging [m s^{-2}]", "m s^{-2}", zt ) - k = k + 1 - - case ('mixt_frac') - imixt_frac = k - call stat_assign( imixt_frac, "mixt_frac", & - "pdf parameter: mixture fraction [count]", "count", zt ) - k = k + 1 - - case ('w1') - iw1 = k - call stat_assign( iw1, "w1", & - "pdf parameter: mean w of component 1 [m/s]", "m/s", zt ) - - k = k + 1 - - case ('w2') - iw2 = k - - call stat_assign( iw2, "w2", & - "pdf paramete: mean w of component 2 [m/s]", "m/s", zt ) - k = k + 1 - - case ('varnce_w1') - ivarnce_w1 = k - call stat_assign( ivarnce_w1, "varnce_w1", & - "pdf parameter: w variance of component 1 [m^2/s^2]", "m^2/s^2", zt ) - - k = k + 1 - - case ('varnce_w2') - ivarnce_w2 = k - - call stat_assign( ivarnce_w2, "varnce_w2", & - "pdf parameter: w variance of component 2 [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case ('thl1') - ithl1 = k - - call stat_assign( ithl1, "thl1", & - "pdf parameter: mean thl of component 1 [K]", "K", zt ) - - k = k + 1 - - case ('thl2') - ithl2 = k - - call stat_assign( ithl2, "thl2", & - "pdf parameter: mean thl of component 2 [K]", "K", zt ) - k = k + 1 - - case ('varnce_thl1') - ivarnce_thl1 = k - - call stat_assign( ivarnce_thl1, "varnce_thl1", & - "pdf parameter: thl variance of component 1 [K^2]", "K^2", zt ) - - k = k + 1 - - case ('varnce_thl2') - ivarnce_thl2 = k - call stat_assign( ivarnce_thl2, "varnce_thl2", & - "pdf parameter: thl variance of component 2 [K^2]", "K^2", zt ) - - k = k + 1 - - case ('rt1') - irt1 = k - call stat_assign( irt1, "rt1", & - "pdf parameter: mean rt of component 1 [kg/kg]", "kg/kg", zt ) - - k = k + 1 - - case ('rt2') - irt2 = k - - call stat_assign( irt2, "rt2", & - "pdf parameter: mean rt of component 2 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('varnce_rt1') - ivarnce_rt1 = k - call stat_assign( ivarnce_rt1, "varnce_rt1", & - "pdf parameter: rt variance of component 1 [(kg^2)/(kg^2)]", "(kg^2)/(kg^2)", zt ) - k = k + 1 - - case ('varnce_rt2') - ivarnce_rt2 = k - - call stat_assign( ivarnce_rt2, "varnce_rt2", & - "pdf parameter: rt variance of component 2 [(kg^2)/(kg^2)]", "(kg^2)/(kg^2)", zt ) - k = k + 1 - - case ('rc1') - irc1 = k - - call stat_assign( irc1, "rc1", & - "pdf parameter: mean rc of component 1 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rc2') - irc2 = k - - call stat_assign( irc2, "rc2", & - "pdf parameter: mean rc of component 2 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rsl1') - irsl1 = k - - call stat_assign( irsl1, "rsl1", & - "pdf parameter: sat mix rat based on tl1 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('rsl2') - irsl2 = k - - call stat_assign( irsl2, "rsl2", & - "pdf parameter: sat mix rat based on tl2 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('cloud_frac1') - icloud_frac1 = k - call stat_assign( icloud_frac1, "cloud_frac1", & - "pdf parameter cloud_frac1 [count]", "count", zt ) - k = k + 1 - - case ('cloud_frac2') - icloud_frac2 = k - - call stat_assign( icloud_frac2, "cloud_frac2", & - "pdf parameter cloud_frac2 [count]", "count", zt ) - k = k + 1 - - case ('s1') - is1 = k - - call stat_assign( is1, "s1", & - "pdf parameter: Mellor's s (extended liq) for component 1 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('s2') - is2 = k - - call stat_assign( is2, "s2", & - "pdf parameter: Mellor's s (extended liq) for component 2 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('stdev_s1') - istdev_s1 = k - - call stat_assign( istdev_s1, "stdev_s1", & - "pdf parameter: Std dev of s1 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('stdev_s2') - istdev_s2 = k - - call stat_assign( istdev_s2, "stdev_s2", & - "pdf parameter: Std dev of s2 [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('stdev_t1') - istdev_t1 = k - - call stat_assign( istdev_t1, "stdev_t1", & - "Standard dev. of t (1st PDF component) [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('stdev_t2') - istdev_t2 = k - - call stat_assign( istdev_t2, "stdev_t2", & - "Standard dev. of t (2nd PDF component) [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ('covar_st_1') - icovar_st_1 = k - - call stat_assign( icovar_st_1, "covar_st_1", & - "Covariance of s and t (1st PDF component) [kg^2/kg^2]", "kg^2/kg^2", zt ) - k = k + 1 - - case ('covar_st_2') - icovar_st_2 = k - - call stat_assign( icovar_st_2, "covar_st_2", & - "Covariance of s and t (2nd PDF component) [kg^2/kg^2]", "kg^2/kg^2", zt ) - k = k + 1 - - case ('corr_st_1') - icorr_st_1 = k - - call stat_assign( icorr_st_1, "corr_st_1", & - "Correlation btw. s and t (1st PDF component) [-]", "-", zt ) - k = k + 1 - - case ('corr_st_2') - icorr_st_2 = k - - call stat_assign( icorr_st_2, "corr_st_2", & - "Correlation btw. s and t (2nd PDF component) [-]", "-", zt ) - k = k + 1 - - case ('rrtthl') - irrtthl = k - - call stat_assign( irrtthl, "rrtthl", & - "Correlation btw. rt and thl (both components) [-]", "-", zt ) - k = k + 1 - - case ('crt1') - icrt1 = k - - call stat_assign( icrt1, "crt1", & - " Coef. on r_t in s/t eqns. (1st PDF comp.) [-]", "count", zt ) - k = k + 1 - - case ('crt2') - icrt2 = k - - call stat_assign( icrt2, "crt2", & - " Coef. on r_t in s/t eqns. (2nd PDF comp.) [-]", "count", zt ) - k = k + 1 - - case ('cthl1') - icthl1 = k - - call stat_assign( icthl1, "cthl1", & - " Coef. on theta_l in s/t eqns. (1st PDF comp.) [kg/kg/K]", "kg/kg/K", zt ) - k = k + 1 - - case ('cthl2') - icthl2 = k - - call stat_assign( icthl2, "cthl2", & - " Coef. on theta_l in s/t eqns. (2nd PDF comp.) [kg/kg/K]", "kg/kg/K", zt ) - k = k + 1 - - - case('wp2_zt') - iwp2_zt = k - - call stat_assign( iwp2_zt, "wp2_zt", & - "w'^2 interpolated to thermodyamic levels [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case('thlp2_zt') - ithlp2_zt = k - - call stat_assign( ithlp2_zt, "thlp2_zt", & - "thl'^2 interpolated to thermodynamic levels [K^2]", "K^2", zt ) - k = k + 1 - - case('wpthlp_zt') - iwpthlp_zt = k - - call stat_assign( iwpthlp_zt, "wpthlp_zt", & - "w'thl' interpolated to thermodynamic levels [(m K)/s]", "(m K)/s", zt ) - k = k + 1 - - case('wprtp_zt') - iwprtp_zt = k - - call stat_assign( iwprtp_zt, "wprtp_zt", & - "w'rt' interpolated to thermodynamic levels [(m kg)/(s kg)]", "(m kg)/(s kg)", zt ) - k = k + 1 - - case('rtp2_zt') - irtp2_zt = k - - call stat_assign( irtp2_zt, "rtp2_zt", & - "rt'^2 interpolated to thermodynamic levels [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case('rtpthlp_zt') - irtpthlp_zt = k - - call stat_assign( irtpthlp_zt, "rtpthlp_zt", & - "rt'thl' interpolated to thermodynamic levels [(kg K)/kg]", "(kg K)/kg", zt ) - k = k + 1 - - case ('up2_zt') - iup2_zt = k - call stat_assign( iup2_zt, "up2_zt", & - "u'^2 interpolated to thermodynamic levels [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case ('vp2_zt') - ivp2_zt = k - call stat_assign( ivp2_zt, "vp2_zt", & - "v'^2 interpolated to thermodynamic levels [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case ('upwp_zt') - iupwp_zt = k - call stat_assign( iupwp_zt, "upwp_zt", & - "u'w' interpolated to thermodynamic levels [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case ('vpwp_zt') - ivpwp_zt = k - call stat_assign( ivpwp_zt, "vpwp_zt", & - "v'w' interpolated to thermodynamic levels [m^2/s^2]", "m^2/s^2", zt ) - k = k + 1 - - case ('C11_Skw_fnc') - iC11_Skw_fnc = k - - call stat_assign( iC11_Skw_fnc, "C11_Skw_fnc", & - "C_11 parameter with Sk_w applied [-]", "count", zt ) - k = k + 1 - - case ('s_mellor') - is_mellor = k - - call stat_assign( is_mellor, "s_mellor", & - "Mellor's s (extended liq) [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'a3_coef_zt' ) - ia3_coef_zt = k - call stat_assign( ia3_coef_zt, "a3_coef_zt", & - "The a3 coefficient interpolated the the zt grid [-]", "count", zt ) - k = k + 1 - - case ( 'wp3_on_wp2_zt' ) - iwp3_on_wp2_zt = k - call stat_assign( iwp3_on_wp2_zt, "wp3_on_wp2_zt", & - "Smoothed version of wp3 / wp2 [m/s]", "m/s", zt ) - k = k + 1 - - case ( 'rr1' ) - irr1 = k - call stat_assign( irr1, "rr1", & - "Mean of r_r (1st PDF component) [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'rr2' ) - irr2 = k - call stat_assign( irr2, "rr2", & - "Mean of r_r (2nd PDF component) [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'Nr1' ) - iNr1 = k - call stat_assign( iNr1, "Nr1", & - "Mean of N_r (1st PDF component) [num/kg]", "num/kg", zt ) - k = k + 1 - - case ( 'Nr2' ) - iNr2 = k - call stat_assign( iNr2, "Nr2", & - "Mean of N_r (2nd PDF component) [num/kg]", "num/kg", zt ) - k = k + 1 - - case ( 'LWP1' ) - iLWP1 = k - call stat_assign( iLWP1, "LWP1", & - "Liquid water path (1st PDF component) [kg/m^2]", "kg/m^2", zt ) - k = k + 1 - - case ( 'LWP2' ) - iLWP2 = k - call stat_assign( iLWP2, "LWP2", & - "Liquid water path (2nd PDF component) [kg/m^2]", "kg/m^2", zt ) - k = k + 1 - - case ( 'precip_frac' ) - iprecip_frac = k - call stat_assign( iprecip_frac, "precip_frac", & - "Precipitation Fraction [-]", "-", zt ) - k = k + 1 - - case ( 'precip_frac_1' ) - iprecip_frac_1 = k - call stat_assign( iprecip_frac_1, "precip_frac_1", & - "Precipitation Fraction (1st PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'precip_frac_2' ) - iprecip_frac_2 = k - call stat_assign( iprecip_frac_2, "precip_frac_2", & - "Precipitation Fraction (2nd PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'mu_rr_1' ) - imu_rr_1 = k - call stat_assign( imu_rr_1, "mu_rr_1", & - "Mean (in-precip) of r_r (1st PDF component) [kg/kg]", & - "kg/kg", zt ) - k = k + 1 - - case ( 'mu_rr_2' ) - imu_rr_2 = k - call stat_assign( imu_rr_2, "mu_rr_2", & - "Mean (in-precip) of r_r (2nd PDF component) [kg/kg]", & - "kg/kg", zt ) - k = k + 1 - - case ( 'mu_Nr_1' ) - imu_Nr_1 = k - call stat_assign( imu_Nr_1, "mu_Nr_1", & - "Mean (in-precip) of N_r (1st PDF component) [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ( 'mu_Nr_2' ) - imu_Nr_2 = k - call stat_assign( imu_Nr_2, "mu_Nr_2", & - "Mean (in-precip) of N_r (2nd PDF component) [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ( 'mu_Nc_1' ) - imu_Nc_1 = k - call stat_assign( imu_Nc_1, "mu_Nc_1", & - "Mean of N_c (1st PDF component) [num/kg]", "num/kg", zt ) - k = k + 1 - - case ( 'mu_Nc_2' ) - imu_Nc_2 = k - call stat_assign( imu_Nc_2, "mu_Nc_2", & - "Mean of N_c (2nd PDF component) [num/kg]", "num/kg", zt ) - k = k + 1 - - case ( 'mu_rr_1_n' ) - imu_rr_1_n = k - call stat_assign( imu_rr_1_n, "mu_rr_1_n", & - "Mean (in-precip) of ln r_r (1st PDF component) [ln(kg/kg)]", & - "ln(kg/kg)", zt ) - k = k + 1 - - case ( 'mu_rr_2_n' ) - imu_rr_2_n = k - call stat_assign( imu_rr_2_n, "mu_rr_2_n", & - "Mean (in-precip) of ln r_r (2nd PDF component) [ln(kg/kg)]", & - "ln(kg/kg)", zt ) - k = k + 1 - - case ( 'mu_Nr_1_n' ) - imu_Nr_1_n = k - call stat_assign( imu_Nr_1_n, "mu_Nr_1_n", & - "Mean (in-precip) of ln N_r (1st PDF component) [ln(num/kg)]", & - "ln(num/kg)", zt ) - k = k + 1 - - case ( 'mu_Nr_2_n' ) - imu_Nr_2_n = k - call stat_assign( imu_Nr_2_n, "mu_Nr_2_n", & - "Mean (in-precip) of ln N_r (2nd PDF component) [ln(num/kg)]", & - "ln(num/kg)", zt ) - k = k + 1 - - case ( 'mu_Nc_1_n' ) - imu_Nc_1_n = k - call stat_assign( imu_Nc_1_n, "mu_Nc_1_n", & - "Mean of ln N_c (1st PDF component) [ln(num/kg)]", & - "ln(num/kg)", zt ) - k = k + 1 - - case ( 'mu_Nc_2_n' ) - imu_Nc_2_n = k - call stat_assign( imu_Nc_2_n, "mu_Nc_2_n", & - "Mean of ln N_c (2nd PDF component) [ln(num/kg)]", & - "ln(num/kg)", zt ) - k = k + 1 - - case ( 'sigma_rr_1' ) - isigma_rr_1 = k - call stat_assign( isigma_rr_1, "sigma_rr_1", & - "Standard deviation (in-precip) of r_r (1st PDF component)" & - //" [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'sigma_rr_2' ) - isigma_rr_2 = k - call stat_assign( isigma_rr_2, "sigma_rr_2", & - "Standard deviation (in-precip) of r_r (2nd PDF component)" & - //" [kg/kg]", "kg/kg", zt ) - k = k + 1 - - case ( 'sigma_Nr_1' ) - isigma_Nr_1 = k - call stat_assign( isigma_Nr_1, "sigma_Nr_1", & - "Standard deviation (in-precip) of N_r (1st PDF component)" & - //" [num/kg]", "num/kg", zt ) - k = k + 1 - - case ( 'sigma_Nr_2' ) - isigma_Nr_2 = k - call stat_assign( isigma_Nr_2, "sigma_Nr_2", & - "Standard deviation (in-precip) of N_r (2nd PDF component)" & - //" [num/kg]", "num/kg", zt ) - k = k + 1 - - case ( 'sigma_Nc_1' ) - isigma_Nc_1 = k - call stat_assign( isigma_Nc_1, "sigma_Nc_1", & - "Standard deviation of N_c (1st PDF component) [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ( 'sigma_Nc_2' ) - isigma_Nc_2 = k - call stat_assign( isigma_Nc_2, "sigma_Nc_2", & - "Standard deviation of N_c (2nd PDF component) [num/kg]", & - "num/kg", zt ) - k = k + 1 - - case ( 'sigma_rr_1_n' ) - isigma_rr_1_n = k - call stat_assign( isigma_rr_1_n, "sigma_rr_1_n", & - "Standard deviation (in-precip) of ln r_r (1st PDF component)" & - //" [ln(kg/kg)]", "ln(kg/kg)", zt ) - k = k + 1 - - case ( 'sigma_rr_2_n' ) - isigma_rr_2_n = k - call stat_assign( isigma_rr_2_n, "sigma_rr_2_n", & - "Standard deviation (in-precip) of ln r_r (2nd PDF component)" & - //" [ln(kg/kg)]", "ln(kg/kg)", zt ) - k = k + 1 - - case ( 'sigma_Nr_1_n' ) - isigma_Nr_1_n = k - call stat_assign( isigma_Nr_1_n, "sigma_Nr_1_n", & - "Standard deviation (in-precip) of ln N_r (1st PDF component)" & - //" [ln(num/kg)]", "ln(num/kg)", zt ) - k = k + 1 - - case ( 'sigma_Nr_2_n' ) - isigma_Nr_2_n = k - call stat_assign( isigma_Nr_2_n, "sigma_Nr_2_n", & - "Standard deviation (in-precip) of ln N_r (2nd PDF component)" & - //" [ln(num/kg)]", "ln(num/kg)", zt ) - k = k + 1 - - case ( 'sigma_Nc_1_n' ) - isigma_Nc_1_n = k - call stat_assign( isigma_Nc_1_n, "sigma_Nc_1_n", & - "Standard deviation of ln N_c (1st PDF component) [ln(num/kg)]", & - "ln(num/kg)", zt ) - k = k + 1 - - case ( 'sigma_Nc_2_n' ) - isigma_Nc_2_n = k - call stat_assign( isigma_Nc_2_n, "sigma_Nc_2_n", & - "Standard deviation of ln N_c (2nd PDF component) [ln(num/kg)]", & - "ln(num/kg)", zt ) - k = k + 1 - - case ( 'corr_srr_1' ) - icorr_srr_1 = k - call stat_assign( icorr_srr_1, "corr_srr_1", & - "Correlation (in-precip) between s and r_r (1st PDF component)" & - //" [-]", "-", zt ) - k = k + 1 - - case ( 'corr_srr_2' ) - icorr_srr_2 = k - call stat_assign( icorr_srr_2, "corr_srr_2", & - "Correlation (in-precip) between s and r_r (2nd PDF component)" & - //" [-]", "-", zt ) - k = k + 1 - - case ( 'corr_sNr_1' ) - icorr_sNr_1 = k - call stat_assign( icorr_sNr_1, "corr_sNr_1", & - "Correlation (in-precip) between s and N_r (1st PDF component)" & - //" [-]", "-", zt ) - k = k + 1 - - case ( 'corr_sNr_2' ) - icorr_sNr_2 = k - call stat_assign( icorr_sNr_2, "corr_sNr_2", & - "Correlation (in-precip) between s and N_r (2nd PDF component)" & - //" [-]", "-", zt ) - k = k + 1 - - case ( 'corr_sNc_1' ) - icorr_sNc_1 = k - call stat_assign( icorr_sNc_1, "corr_sNc_1", & - "Correlation between s and N_c (1st PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_sNc_2' ) - icorr_sNc_2 = k - call stat_assign( icorr_sNc_2, "corr_sNc_2", & - "Correlation between s and N_c (2nd PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_trr_1' ) - icorr_trr_1 = k - call stat_assign( icorr_trr_1, "corr_trr_1", & - "Correlation (in-precip) between t and r_r (1st PDF component)" & - //" [-]", "-", zt ) - k = k + 1 - - case ( 'corr_trr_2' ) - icorr_trr_2 = k - call stat_assign( icorr_trr_2, "corr_trr_2", & - "Correlation (in-precip) between t and r_r (2nd PDF component)" & - //" [-]", "-", zt ) - k = k + 1 - - case ( 'corr_tNr_1' ) - icorr_tNr_1 = k - call stat_assign( icorr_tNr_1, "corr_tNr_1", & - "Correlation (in-precip) between t and N_r (1st PDF component)" & - //" [-]", "-", zt ) - k = k + 1 - - case ( 'corr_tNr_2' ) - icorr_tNr_2 = k - call stat_assign( icorr_tNr_2, "corr_tNr_2", & - "Correlation (in-precip) between t and N_r (2nd PDF component)" & - //" [-]", "-", zt ) - k = k + 1 - - case ( 'corr_tNc_1' ) - icorr_tNc_1 = k - call stat_assign( icorr_tNc_1, "corr_tNc_1", & - "Correlation between t and N_c (1st PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_tNc_2' ) - icorr_tNc_2 = k - call stat_assign( icorr_tNc_2, "corr_tNc_2", & - "Correlation between t and N_c (2nd PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_rrNr_1' ) - icorr_rrNr_1 = k - call stat_assign( icorr_rrNr_1, "corr_rrNr_1", & - "Correlation (in-precip) between r_r and N_r (1st PDF component)" & - //" [-]", "-", zt ) - k = k + 1 - - case ( 'corr_rrNr_2' ) - icorr_rrNr_2 = k - call stat_assign( icorr_rrNr_2, "corr_rrNr_2", & - "Correlation (in-precip) between r_r and N_r (2nd PDF component)" & - //" [-]", "-", zt ) - k = k + 1 - - case ( 'corr_srr_1_n' ) - icorr_srr_1_n = k - call stat_assign( icorr_srr_1_n, "corr_srr_1_n", & - "Correlation (in-precip) between s and ln r_r" & - //" (1st PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_srr_2_n' ) - icorr_srr_2_n = k - call stat_assign( icorr_srr_2_n, "corr_srr_2_n", & - "Correlation (in-precip) between s and ln r_r" & - //" (2nd PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_sNr_1_n' ) - icorr_sNr_1_n = k - call stat_assign( icorr_sNr_1_n, "corr_sNr_1_n", & - "Correlation (in-precip) between s and ln N_r" & - //" (1st PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_sNr_2_n' ) - icorr_sNr_2_n = k - call stat_assign( icorr_sNr_2_n, "corr_sNr_2_n", & - "Correlation (in-precip) between s and ln N_r" & - //" (2nd PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_sNc_1_n' ) - icorr_sNc_1_n = k - call stat_assign( icorr_sNc_1_n, "corr_sNc_1_n", & - "Correlation between s and ln N_c (1st PDF component) [-]", & - "-", zt ) - k = k + 1 - - case ( 'corr_sNc_2_n' ) - icorr_sNc_2_n = k - call stat_assign( icorr_sNc_2_n, "corr_sNc_2_n", & - "Correlation between s and ln N_c (2nd PDF component) [-]", & - "-", zt ) - k = k + 1 - - case ( 'corr_trr_1_n' ) - icorr_trr_1_n = k - call stat_assign( icorr_trr_1_n, "corr_trr_1_n", & - "Correlation (in-precip) between t and ln r_r" & - //" (1st PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_trr_2_n' ) - icorr_trr_2_n = k - call stat_assign( icorr_trr_2_n, "corr_trr_2_n", & - "Correlation (in-precip) between t and ln r_r" & - //" (2nd PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_tNr_1_n' ) - icorr_tNr_1_n = k - call stat_assign( icorr_tNr_1_n, "corr_tNr_1_n", & - "Correlation (in-precip) between t and ln N_r" & - //" (1st PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_tNr_2_n' ) - icorr_tNr_2_n = k - call stat_assign( icorr_tNr_2_n, "corr_tNr_2_n", & - "Correlation (in-precip) between t and ln N_r" & - //" (2nd PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_tNc_1_n' ) - icorr_tNc_1_n = k - call stat_assign( icorr_tNc_1_n, "corr_tNc_1_n", & - "Correlation between t and ln N_c (1st PDF component) [-]", & - "-", zt ) - k = k + 1 - - case ( 'corr_tNc_2_n' ) - icorr_tNc_2_n = k - call stat_assign( icorr_tNc_2_n, "corr_tNc_2_n", & - "Correlation between t and ln N_c (2nd PDF component) [-]", & - "-", zt ) - k = k + 1 - - case ( 'corr_rrNr_1_n' ) - icorr_rrNr_1_n = k - call stat_assign( icorr_rrNr_1_n, "corr_rrNr_1_n", & - "Correlation (in-precip) between ln r_r and ln N_r" & - //" (1st PDF component) [-]", "-", zt ) - k = k + 1 - - case ( 'corr_rrNr_2_n' ) - icorr_rrNr_2_n = k - call stat_assign( icorr_rrNr_2_n, "corr_rrNr_2_n", & - "Correlation (in-precip) between ln r_r and ln N_r" & - //" (2nd PDF component) [-]", "-", zt ) - k = k + 1 - - - ! changes by janhft 09/25/12 - case ('corr_sw') - icorr_sw = k - call stat_assign( icorr_sw, "corr_sw", & - "Correlation between s and w [-]", "-", zt ) - k = k + 1 - - case ('corr_wrr') - icorr_wrr = k - call stat_assign( icorr_wrr, "corr_wrr", & - "Correlation between w and rrain [-]", "-", zt ) - k = k + 1 - - case ('corr_wNr') - icorr_wNr = k - call stat_assign( icorr_wNr, "corr_wNr", & - "Correlation between w and Nr [-]", "-", zt ) - k = k + 1 - - case ('corr_wNc') - icorr_wNc = k - call stat_assign( icorr_wNc, "corr_wNc", & - "Correlation between w and Nc [-]", "-", zt ) - k = k + 1 - ! end changes by janhft 09/25/12 - - case default - - l_found =.false. - - j=1 - - do while( j <= sclr_dim .and. .not. l_found) - write(sclr_idx, * ) j - - sclr_idx = adjustl(sclr_idx) - - if(trim(vars_zt(i)) == "sclr"//trim(sclr_idx)//"m" .and. .not. l_found) then - - isclrm(j) = k - - call stat_assign( isclrm(j) , "sclr"//trim(sclr_idx)//"m",& - "passive scalar "//trim(sclr_idx), "unknown", zt ) - - k = k + 1 - - l_found = .true. - - else if(trim(vars_zt(i)) == "sclr"//trim(sclr_idx)//"m_f" .and. .not. l_found) then - - isclrm_f(j) = k - - call stat_assign( isclrm_f(j) , "sclr"//trim(sclr_idx)//"m_f", & - "passive scalar forcing "//trim(sclr_idx), "unknown", zt ) - - k = k + 1 - - l_found = .true. - - endif - - j = j + 1 - end do - - j = 1 - - do while( j <= edsclr_dim .and. .not. l_found) - - write(sclr_idx, * ) j - - sclr_idx = adjustl(sclr_idx) - - if(trim(vars_zt(i)) == "edsclr"//trim(sclr_idx)//"m" .and. .not. l_found ) then - - iedsclrm(j) = k - - call stat_assign( iedsclrm(j) , "edsclr"//trim(sclr_idx)//"m", & - "passive scalar "//trim(sclr_idx), "unknown", zt ) - - k = k + 1 - - l_found = .true. - - else if(trim(vars_zt(i)) == "edsclr"//trim(sclr_idx)//"m_f" .and. .not. l_found) then - - iedsclrm_f(j) = k - - call stat_assign( iedsclrm_f(j) , "edsclr"//trim(sclr_idx)//"m_f", & - "passive scalar forcing "//trim(sclr_idx), "unknown", zt ) - - k = k + 1 - - l_found = .true. - - endif - - j = j + 1 - - end do - - if (.not. l_found ) then - - write(fstderr,*) 'Error: unrecognized variable in vars_zt: ', trim( vars_zt(i) ) - - l_error = .true. ! This will stop the run. - - end if - - end select - - end do - - return - end subroutine stats_init_zt - -end module crmx_stats_zt diff --git a/src/physics/spcam/crm/CLUBB/crmx_surface_varnce_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_surface_varnce_module.F90 deleted file mode 100644 index 3ca35d19be..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_surface_varnce_module.F90 +++ /dev/null @@ -1,409 +0,0 @@ -! $Id: surface_varnce_module.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ -!=============================================================================== -module crmx_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, 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 -! second order moments. - -! References: -! None -!------------------------------------------------------------------------------- - - use crmx_parameters_model, only: & - T0 ! Variable(s) - - use crmx_constants_clubb, only: & - grav, & ! Variable(s) - eps, & - fstderr - - use crmx_parameters_model, only: & - sclr_dim ! Variable(s) - - use crmx_numerical_check, only: & - surface_varnce_check ! Procedure - - use crmx_error_code, only: & - clubb_var_equals_NaN, & ! Variable(s) - clubb_at_least_debug_level, & - clubb_no_error ! Constant - - use crmx_array_index, only: & - iisclr_rt, & ! Index for a scalar emulating rt - iisclr_thl ! Index for a scalar emulating thetal - - use crmx_stats_type, only: & - stat_end_update_pt, & ! Procedure(s) - stat_update_var_pt - - use crmx_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 = 1.0_core_rknd, & - ! Vince Larson increased ufmin to stabilize arm_97. 24 Jul 2007 -! ufmin = 0.0001_core_rknd, & - ufmin = 0.01_core_rknd, & - ! 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 [m^2/s^2] - vpwp_sfc, & ! Surface v momentum flux [m^2/s^2] - wpthlp_sfc, & ! Surface thetal flux [K m/s] - wprtp_sfc, & ! Surface moisture flux [kg/kg m/s] - um_sfc, & ! Surface u wind component [m/s] - vm_sfc ! Surface v wind component [m/s] - - real( kind = core_rknd ), intent(in), dimension(sclr_dim) :: & - wpsclrp_sfc ! Passive scalar flux [units m/s] - - ! Output Variables - real( kind = core_rknd ), intent(out) :: & - wp2_sfc, & ! Vertical velocity variance [m^2/s^2] - up2_sfc, & ! u'^2 [m^2/s^2] - vp2_sfc, & ! v'^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] - - integer, intent(out) :: & - err_code - - real( kind = core_rknd ), intent(out), dimension(sclr_dim) :: & - 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] - - ! Local Variables - real( kind = core_rknd ) :: ustar2, wstar - real( kind = core_rknd ) :: uf - - ! 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 - real( kind = core_rknd ) :: Lngth - real( kind = core_rknd ) :: zeta - - integer :: i ! Loop index - - ! ---- Begin Code ---- - - 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 )**(1.0_core_rknd/4.0_core_rknd), ufmin ) - - ! Find Monin-Obukhov Length (Andre et al., 1978, p. 1866). - Lngth = - ( ustar**3 ) / & - ( 0.35_core_rknd * (1.0_core_rknd/T0) * grav * wpthlp_sfc ) ! Known magic number - - ! Find the value of dimensionless height zeta - ! (Andre et al., 1978, p. 1866). - zeta = z_const / Lngth - - ! 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 < 0.0_core_rknd ) then - thlp2_sfc = reduce_coef & - * ( wpthlp_sfc**2 / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - rtp2_sfc = reduce_coef & - * ( wprtp_sfc**2 / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - rtpthlp_sfc = reduce_coef & - * ( wprtp_sfc*wpthlp_sfc / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - wp2_sfc = ( ustar**2 ) & - * ( 1.75_core_rknd + 2.0_core_rknd*(-zeta)**& - (2.0_core_rknd/3.0_core_rknd) ) ! Known magic number - else - thlp2_sfc = reduce_coef & - * 4.0_core_rknd * ( wpthlp_sfc**2 / ustar**2 ) ! Known magic number - rtp2_sfc = reduce_coef & - * 4.0_core_rknd * ( wprtp_sfc**2 / ustar**2 ) ! Known magic number - rtpthlp_sfc = reduce_coef & - * 4.0_core_rknd * ( wprtp_sfc*wpthlp_sfc / ustar**2 ) ! Known magic number - wp2_sfc = 1.75_core_rknd * ustar**2 ! Known magic number - end if - - ! Calculate wstar following Andre et al., 1978, p. 1866. - wstar = ( (1.0_core_rknd/T0) * grav * wpthlp_sfc * z_const )**(1.0_core_rknd/3.0_core_rknd) - - ! 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 > 0.0_core_rknd ) then - usp2_sfc = 4.0_core_rknd * ustar**2 + 0.3_core_rknd * wstar**2 ! Known magic number - vsp2_sfc = 1.75_core_rknd * ustar**2 + 0.3_core_rknd * wstar**2 ! Known magic number - else - usp2_sfc = 4.0_core_rknd * ustar**2 ! Known magic number - vsp2_sfc = 1.75_core_rknd * ustar**2 ! Known magic number - end if - - ! 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 < 0.0_core_rknd ) then - sclrprtp_sfc(i) & - = reduce_coef & - * ( wpsclrp_sfc(i)*wprtp_sfc / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - sclrpthlp_sfc(i) & - = reduce_coef & - * ( wpsclrp_sfc(i)*wpthlp_sfc / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - sclrp2_sfc(i) & - = reduce_coef & - * ( wpsclrp_sfc(i)**2 / ustar**2 ) & - * 4.0_core_rknd * ( 1.0_core_rknd - 8.3_core_rknd*zeta )**& - (-2.0_core_rknd/3.0_core_rknd) ! Known magic number - else - sclrprtp_sfc(i) & - = reduce_coef & - * 4.0_core_rknd * ( wpsclrp_sfc(i)*wprtp_sfc / ustar**2 ) ! Known magic number - sclrpthlp_sfc(i) & - = reduce_coef & - * 4.0_core_rknd * ( wpsclrp_sfc(i)*wpthlp_sfc / ustar**2 ) ! Known magic number - sclrp2_sfc(i) & - = reduce_coef & - * 4.0_core_rknd * ( wpsclrp_sfc(i)**2 / ustar**2 ) ! Known magic number - end if - end do ! 1,...sclr_dim - end if - - 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 > 0._core_rknd ) then - wstar = ( 1.0_core_rknd/T0 * grav * wpthlp_sfc * z_const ) ** (1._core_rknd/3._core_rknd) - else - wstar = 0._core_rknd - end if - - ! Surface friction velocity following Andre et al. 1978 - - uf = sqrt( ustar2 + 0.3_core_rknd * wstar * wstar ) ! Known magic number - 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 ! Known magic number - - rtp2_sfc = 0.4_core_rknd * a_const * ( wprtp_sfc / uf )**2 ! Known magic number - - rtpthlp_sfc = 0.2_core_rknd * a_const * ( wpthlp_sfc / uf ) & - * ( wprtp_sfc / uf )! Known magic number - - ! 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)!Known magic number - else - sclrprtp_sfc(i) = 0.2_core_rknd * a_const * (wprtp_sfc / uf) * & - (wpsclrp_sfc(i) / uf)!Known magic number - end if - - 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) ! Known magic number - else - sclrpthlp_sfc(i) = 0.2_core_rknd * a_const * (wpthlp_sfc / uf) & - * (wpsclrp_sfc(i) / uf) ! Known magic number - end if - - sclrp2_sfc(i) = sclr_var_coef * a_const * ( wpsclrp_sfc(i) / uf )**2 - - ! End Vince Larson's change. - - end do ! 1,...sclr_dim - end if ! sclr_dim > 0 - - end if - - if ( clubb_at_least_debug_level( 2 ) ) then - - call surface_varnce_check( wp2_sfc, up2_sfc, vp2_sfc, & - thlp2_sfc, rtp2_sfc, rtpthlp_sfc, & - err_code, & - sclrp2_sfc, sclrprtp_sfc, sclrpthlp_sfc ) - -! 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 - end if - - 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 - end if - - end if ! err_code == clubb_var_equals_NaN - - end if ! clubb_at_least_debug_level ( 2 ) - - return - - end subroutine surface_varnce - -!=============================================================================== - -end module crmx_surface_varnce_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_variables_diagnostic_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_variables_diagnostic_module.F90 deleted file mode 100644 index ce5d06c6fe..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_variables_diagnostic_module.F90 +++ /dev/null @@ -1,654 +0,0 @@ -! $Id: variables_diagnostic_module.F90 6118 2013-03-25 19:16:42Z storer@uwm.edu $ -module crmx_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 crmx_pdf_parameter_module, only: & - pdf_parameter ! derived type - - use crmx_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 [-] - 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, ug, vg, & -!$omp 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) - - 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] - -!$omp threadprivate(wpthlp2, wp2thlp, wprtp2, wp2rtp, & -!$omp wprtpthlp, wp2rcp, wp3_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) - -! 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 array - real( kind = core_rknd ), allocatable, dimension(:,:), public :: hydromet -!$omp threadprivate(hydromet) - - real( kind = core_rknd ), target, allocatable, dimension(:), public :: & - Ncnm ! Cloud nuclei number concentration [num/m^3] -!$omp threadprivate(Ncnm) - - -! 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 crmx_constants_clubb, only: & - em_min, & ! Constant(s) - zero - - use crmx_parameters_model, only: & - hydromet_dim, & ! Variables - sclr_dim, & - edsclr_dim - - use crmx_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( 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 - - ! 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( 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( Ncnm(1:nz) ) - allocate( hydromet(1:nz,1:hydromet_dim) ) ! All hydrometeor fields - - ! 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 - 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(:)%w1 = zero - pdf_params_zm(:)%w2 = zero - pdf_params_zm(:)%varnce_w1 = zero - pdf_params_zm(:)%varnce_w2 = zero - pdf_params_zm(:)%rt1 = zero - pdf_params_zm(:)%rt2 = zero - pdf_params_zm(:)%varnce_rt1 = zero - pdf_params_zm(:)%varnce_rt2 = zero - pdf_params_zm(:)%thl1 = zero - pdf_params_zm(:)%thl2 = zero - pdf_params_zm(:)%varnce_thl1 = zero - pdf_params_zm(:)%varnce_thl2 = zero - pdf_params_zm(:)%rrtthl = zero - pdf_params_zm(:)%alpha_thl = zero - pdf_params_zm(:)%alpha_rt = zero - pdf_params_zm(:)%crt1 = zero - pdf_params_zm(:)%crt2 = zero - pdf_params_zm(:)%cthl1 = zero - pdf_params_zm(:)%cthl2 = zero - pdf_params_zm(:)%s1 = zero - pdf_params_zm(:)%s2 = zero - pdf_params_zm(:)%stdev_s1 = zero - pdf_params_zm(:)%stdev_s2 = zero - pdf_params_zm(:)%stdev_t1 = zero - pdf_params_zm(:)%stdev_t2 = zero - pdf_params_zm(:)%covar_st_1 = zero - pdf_params_zm(:)%covar_st_2 = zero - pdf_params_zm(:)%corr_st_1 = zero - pdf_params_zm(:)%corr_st_2 = zero - pdf_params_zm(:)%rsl1 = zero - pdf_params_zm(:)%rsl2 = zero - pdf_params_zm(:)%rc1 = zero - pdf_params_zm(:)%rc2 = zero - pdf_params_zm(:)%cloud_frac1 = zero - pdf_params_zm(:)%cloud_frac2 = zero - pdf_params_zm(:)%mixt_frac = zero - - pdf_params_zm_frz(:)%w1 = zero - pdf_params_zm_frz(:)%w2 = zero - pdf_params_zm_frz(:)%varnce_w1 = zero - pdf_params_zm_frz(:)%varnce_w2 = zero - pdf_params_zm_frz(:)%rt1 = zero - pdf_params_zm_frz(:)%rt2 = zero - pdf_params_zm_frz(:)%varnce_rt1 = zero - pdf_params_zm_frz(:)%varnce_rt2 = zero - pdf_params_zm_frz(:)%thl1 = zero - pdf_params_zm_frz(:)%thl2 = zero - pdf_params_zm_frz(:)%varnce_thl1 = zero - pdf_params_zm_frz(:)%varnce_thl2 = 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(:)%crt1 = zero - pdf_params_zm_frz(:)%crt2 = zero - pdf_params_zm_frz(:)%cthl1 = zero - pdf_params_zm_frz(:)%cthl2 = zero - pdf_params_zm_frz(:)%s1 = zero - pdf_params_zm_frz(:)%s2 = zero - pdf_params_zm_frz(:)%stdev_s1 = zero - pdf_params_zm_frz(:)%stdev_s2 = zero - pdf_params_zm_frz(:)%stdev_t1 = zero - pdf_params_zm_frz(:)%stdev_t2 = zero - pdf_params_zm_frz(:)%covar_st_1 = zero - pdf_params_zm_frz(:)%covar_st_2 = zero - pdf_params_zm_frz(:)%corr_st_1 = zero - pdf_params_zm_frz(:)%corr_st_2 = zero - pdf_params_zm_frz(:)%rsl1 = zero - pdf_params_zm_frz(:)%rsl2 = zero - pdf_params_zm_frz(:)%rc1 = zero - pdf_params_zm_frz(:)%rc2 = zero - pdf_params_zm_frz(:)%cloud_frac1 = zero - pdf_params_zm_frz(:)%cloud_frac2 = 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 - - ! 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 - - ! 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 - Ncnm(1:nz) = 0.0_core_rknd ! Cloud nuclei number concentration (COAMPS) - - do i = 1, hydromet_dim, 1 - hydromet(1:nz,i) = 0.0_core_rknd - end do - - - ! 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 --- - - 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( 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 ) - - ! 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( 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( Ncnm ) - - deallocate( hydromet ) ! Hydrometeor fields - - - ! 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 ) - - return - end subroutine cleanup_diagnostic_variables - -end module crmx_variables_diagnostic_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_variables_prognostic_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_variables_prognostic_module.F90 deleted file mode 100644 index 40b9a3163d..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_variables_prognostic_module.F90 +++ /dev/null @@ -1,560 +0,0 @@ -!----------------------------------------------------------------------- -! $Id: variables_prognostic_module.F90 6117 2013-03-25 19:16:04Z storer@uwm.edu $ -module crmx_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 crmx_pdf_parameter_module, only: & - pdf_parameter ! Derived type - - use crmx_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] -#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, 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 -#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) - - 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 crmx_constants_clubb, only: & - rt_tol, & ! Constant(s) - thl_tol, & - w_tol_sqd, & - zero - - use crmx_parameters_model, only: & - sclr_dim, & ! Variable(s) - edsclr_dim - - use crmx_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(:)%w1 = zero - pdf_params(:)%w2 = zero - pdf_params(:)%varnce_w1 = zero - pdf_params(:)%varnce_w2 = zero - pdf_params(:)%rt1 = zero - pdf_params(:)%rt2 = zero - pdf_params(:)%varnce_rt1 = zero - pdf_params(:)%varnce_rt2 = zero - pdf_params(:)%thl1 = zero - pdf_params(:)%thl2 = zero - pdf_params(:)%varnce_thl1 = zero - pdf_params(:)%varnce_thl2 = zero - pdf_params(:)%rrtthl = zero - pdf_params(:)%alpha_thl = zero - pdf_params(:)%alpha_rt = zero - pdf_params(:)%crt1 = zero - pdf_params(:)%crt2 = zero - pdf_params(:)%cthl1 = zero - pdf_params(:)%cthl2 = zero - pdf_params(:)%s1 = zero - pdf_params(:)%s2 = zero - pdf_params(:)%stdev_s1 = zero - pdf_params(:)%stdev_s2 = zero - pdf_params(:)%stdev_t1 = zero - pdf_params(:)%stdev_t2 = zero - pdf_params(:)%covar_st_1 = zero - pdf_params(:)%covar_st_2 = zero - pdf_params(:)%corr_st_1 = zero - pdf_params(:)%corr_st_2 = zero - pdf_params(:)%rsl1 = zero - pdf_params(:)%rsl2 = zero - pdf_params(:)%rc1 = zero - pdf_params(:)%rc2 = zero - pdf_params(:)%cloud_frac1 = zero - pdf_params(:)%cloud_frac2 = zero - pdf_params(:)%mixt_frac = zero - - pdf_params_frz(:)%w1 = zero - pdf_params_frz(:)%w2 = zero - pdf_params_frz(:)%varnce_w1 = zero - pdf_params_frz(:)%varnce_w2 = zero - pdf_params_frz(:)%rt1 = zero - pdf_params_frz(:)%rt2 = zero - pdf_params_frz(:)%varnce_rt1 = zero - pdf_params_frz(:)%varnce_rt2 = zero - pdf_params_frz(:)%thl1 = zero - pdf_params_frz(:)%thl2 = zero - pdf_params_frz(:)%varnce_thl1 = zero - pdf_params_frz(:)%varnce_thl2 = zero - pdf_params_frz(:)%rrtthl = zero - pdf_params_frz(:)%alpha_thl = zero - pdf_params_frz(:)%alpha_rt = zero - pdf_params_frz(:)%crt1 = zero - pdf_params_frz(:)%crt2 = zero - pdf_params_frz(:)%cthl1 = zero - pdf_params_frz(:)%cthl2 = zero - pdf_params_frz(:)%s1 = zero - pdf_params_frz(:)%s2 = zero - pdf_params_frz(:)%stdev_s1 = zero - pdf_params_frz(:)%stdev_s2 = zero - pdf_params_frz(:)%stdev_t1 = zero - pdf_params_frz(:)%stdev_t2 = zero - pdf_params_frz(:)%covar_st_1 = zero - pdf_params_frz(:)%covar_st_2 = zero - pdf_params_frz(:)%corr_st_1 = zero - pdf_params_frz(:)%corr_st_2 = zero - pdf_params_frz(:)%rsl1 = zero - pdf_params_frz(:)%rsl2 = zero - pdf_params_frz(:)%rc1 = zero - pdf_params_frz(:)%rc2 = zero - pdf_params_frz(:)%cloud_frac1 = zero - pdf_params_frz(:)%cloud_frac2 = zero - pdf_params_frz(:)%mixt_frac = 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 - - 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 - - return - end subroutine cleanup_prognostic_variables - -end module crmx_variables_prognostic_module diff --git a/src/physics/spcam/crm/CLUBB/crmx_variables_radiation_module.F90 b/src/physics/spcam/crm/CLUBB/crmx_variables_radiation_module.F90 deleted file mode 100644 index 3b1886cbae..0000000000 --- a/src/physics/spcam/crm/CLUBB/crmx_variables_radiation_module.F90 +++ /dev/null @@ -1,203 +0,0 @@ -!--------------------------------------------------------------- -! $Id: variables_radiation_module.F90 5982 2012-11-21 19:20:12Z raut@uwm.edu $ -module crmx_variables_radiation_module - -! This module contains definitions of all radiation arrays -! used in the single column model, as well as subroutines to -! allocate, deallocate, and initialize them. -!--------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - - public :: & - setup_radiation_variables, & - cleanup_radiation_variables - - private ! Set Default Scoping - - integer, private, parameter :: dp = selected_real_kind( p=12 ) - - real( kind = core_rknd ), public, dimension(:), allocatable :: & - radht_LW, & ! LW heating rate [K/s] - radht_SW, & ! SW heating rate [K/s] - Frad_SW, & ! SW radiative flux [W/m^2] - Frad_LW ! LW radiative flux [W/m^2] - -!$omp threadprivate(radht_LW, radht_SW, Frad_SW, Frad_LW) - - real(kind = dp), public, dimension(:,:), allocatable :: & - T_in_K, & ! Temperature [K] - rcil, & ! Ice mixing ratio [kg/kg] - o3l ! Ozone mixing ratio [kg/kg] - -!$omp threadprivate(T_in_K, rcil, o3l) - - real(kind = dp), public, dimension(:,:), allocatable :: & - rsnowm_2d,& ! Two-dimensional copies of the input parameters - rcm_in_cloud_2d, & - cloud_frac_2d, & - ice_supersat_frac_2d - -!$omp threadprivate(rsnowm_2d, rcm_in_cloud_2d, cloud_frac_2d) - - real(kind = dp), public, dimension(:,:), allocatable :: & - radht_SW_2d, & ! SW Radiative heating rate [W/m^2] - radht_LW_2d ! LW Radiative heating rate [W/m^2] - -!$omp threadprivate(radht_SW_2d, radht_LW_2d) - - real(kind = dp), public, dimension(:,:), allocatable :: & - Frad_uLW, & ! LW upwelling flux [W/m^2] - Frad_dLW, & ! LW downwelling flux [W/m^2] - Frad_uSW, & ! SW upwelling flux [W/m^2] - Frad_dSW ! SW downwelling flux [W/m^2] - -!$omp threadprivate(Frad_uLW, Frad_dLW, Frad_uSW, Frad_dSW) - - real(kind = dp), public, dimension(:,:), allocatable :: & - fdswcl, & !Downward clear-sky SW flux (W/m^-2). - fuswcl, & !Upward clear-sky SW flux (W/m^-2). - fdlwcl, & !Downward clear-sky LW flux (W/m^-2). - fulwcl !Upward clear-sky LW flux (W/m^-2). - -!$omp threadprivate(fdswcl, fuswcl, fdlwcl, fulwcl) - - ! Constant parameters - integer, private, parameter :: & - nlen = 1, & ! Length of the total domain - slen = 1 ! Length of the sub domain - - contains - - !--------------------------------------------------------------------- - subroutine setup_radiation_variables( nzmax, lin_int_buffer, & - extend_atmos_range_size ) - ! Description: - ! Allocates and initializes prognostic scalar and array variables - ! for the CLUBB model code. - !--------------------------------------------------------------------- - - use crmx_clubb_precision, only: & - core_rknd ! Variable(s) - - implicit none - - ! Input Variables - integer, intent(in) :: & - nzmax, & ! Number of grid levels [-] - lin_int_buffer,& ! Number of interpolated levels between the computational - ! grid and the extended atmosphere [-] - extend_atmos_range_size ! The number of levels in the extended atmosphere [-] - - ! Local Variables - - integer :: rad_zt_dim, rad_zm_dim ! Dimensions of the radiation grid - - !----------------------------BEGIN CODE------------------------------- - - rad_zt_dim = (nzmax-1)+lin_int_buffer+extend_atmos_range_size - rad_zm_dim = (nzmax-1)+lin_int_buffer+extend_atmos_range_size+1 - - - ! --- Allocation --- - - allocate( radht_SW(1:nzmax) ) - allocate( radht_LW(1:nzmax) ) - allocate( Frad_SW(1:nzmax) ) - allocate( Frad_LW(1:nzmax) ) - - allocate( T_in_K(nlen, rad_zt_dim ) ) - allocate( rcil(nlen, rad_zt_dim ) ) - allocate( o3l(nlen, rad_zt_dim ) ) - - allocate( rsnowm_2d(nlen, rad_zt_dim ) ) - allocate( rcm_in_cloud_2d(nlen, rad_zt_dim ) ) - allocate( cloud_frac_2d(nlen, rad_zt_dim ) ) - allocate( ice_supersat_frac_2d(nlen, rad_zt_dim ) ) - - allocate( radht_SW_2d(nlen, rad_zt_dim ) ) - allocate( radht_LW_2d(nlen, rad_zt_dim ) ) - - allocate( Frad_uLW(nlen, rad_zm_dim ) ) - allocate( Frad_dLW(nlen, rad_zm_dim ) ) - allocate( Frad_uSW(nlen, rad_zm_dim ) ) - allocate( Frad_dSW(nlen, rad_zm_dim ) ) - - allocate( fdswcl(slen, rad_zm_dim ) ) - allocate( fuswcl(slen, rad_zm_dim ) ) - allocate( fdlwcl(slen, rad_zm_dim ) ) - allocate( fulwcl(slen, rad_zm_dim ) ) - - - ! --- Initialization --- - - radht_SW = 0.0_core_rknd - radht_LW = 0.0_core_rknd - Frad_SW = 0.0_core_rknd - Frad_LW = 0.0_core_rknd - T_in_K = 0.0_dp - rcil = 0.0_dp - o3l = 0.0_dp - rsnowm_2d = 0.0_dp - rcm_in_cloud_2d = 0.0_dp - cloud_frac_2d = 0.0_dp - ice_supersat_frac_2d = 0.0_dp - radht_SW_2d = 0.0_dp - radht_LW_2d = 0.0_dp - Frad_uLW = 0.0_dp - Frad_dLW = 0.0_dp - Frad_uSW = 0.0_dp - Frad_dSW = 0.0_dp - fdswcl = 0.0_dp - fuswcl = 0.0_dp - fdlwcl = 0.0_dp - fulwcl = 0.0_dp - - end subroutine setup_radiation_variables - - !--------------------------------------------------------------------- - subroutine cleanup_radiation_variables( ) - - ! Description: - ! Subroutine to deallocate variables defined in module global - !--------------------------------------------------------------------- - - implicit none - - ! --- Deallocate --- - - deallocate( radht_SW ) - deallocate( radht_LW ) - deallocate( Frad_SW ) - deallocate( Frad_LW ) - - deallocate( T_in_K ) - deallocate( rcil ) - deallocate( o3l ) - - deallocate( rsnowm_2d ) - deallocate( rcm_in_cloud_2d ) - deallocate( cloud_frac_2d ) - deallocate( ice_supersat_frac_2d ) - - deallocate( radht_SW_2d ) - deallocate( radht_LW_2d ) - - deallocate( Frad_uLW ) - deallocate( Frad_dLW ) - deallocate( Frad_uSW ) - deallocate( Frad_dSW ) - - deallocate( fdswcl ) - deallocate( fuswcl ) - deallocate( fdlwcl ) - deallocate( fulwcl ) - - end subroutine cleanup_radiation_variables - - -end module crmx_variables_radiation_module diff --git a/src/physics/spcam/crm/CLUBB/recl.inc b/src/physics/spcam/crm/CLUBB/recl.inc deleted file mode 100644 index 267b70e4db..0000000000 --- a/src/physics/spcam/crm/CLUBB/recl.inc +++ /dev/null @@ -1,26 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: recl.inc 5623 2012-01-17 17:55:26Z connork@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_core_rknd */ -# 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/spcam/crm/MICRO_M2005/README.MICRO_M2005 b/src/physics/spcam/crm/MICRO_M2005/README.MICRO_M2005 deleted file mode 100644 index 5caa0589b0..0000000000 --- a/src/physics/spcam/crm/MICRO_M2005/README.MICRO_M2005 +++ /dev/null @@ -1,121 +0,0 @@ -README for Morrison et al (2005) microphysics. - -The two-moment, five-class bulk microphysical scheme of Morrison et al -(2005) has been ported to SAM through the addition of an interface to -the WRF implementation of Morrison's scheme. Here, SAM directly -interfaces with the 1D version of the scheme in the WRF -implementation. Several microphysical options in the WRF -implementation are accessible here, through the specification of -parameters in the namelist MICRO_M2005, which should be placed in the -prm file and are listed below. The scheme will use an increasing -number of microphysical variables, depending on the options specified -in the PARAMETERS and MICRO_M2005 namelists. - - - QT, total water (vapor + cloud liquid) mass mixing ratio (units: kg/kg) - - NC, cloud water number mixing ratio (units: #/kg), used if dopredictNc=.true. - - QR, rain mass mixing ratio (units: kg/kg), used if doprecip=.true. - - NR, rain number mixing ratio (units: #/kg), used if doprecip=.true. - - QI, cloud ice mass mixing ratio (units: kg/kg), used if doicemicro=.true. - - NI, cloud ice number mixing ratio (units: #/kg), used if doicemicro=.true. - - QS, snow mass mixing ratio (units: kg/kg), used if doicemicro=.true. - - NS, snow number mixing ratio (units: #/kg), used if doicemicro=.true. - - QG, graupel mass mixing ratio (units: kg/kg), used if doicemicro=.true. - - NG, graupel number mixing ratio (units: #/kg), used if doicemicro=.true. - -The scheme will not run for the following combinations of parameters: - - + doprecip=.false. and doicemicro=.true. (doprecip=.false. only works for water clouds) - + dograupel=.true. and doicemicro=.false. (Need ice to make graupel) - + dohail=.true. and dograupel=.false. (Hail is an option for the graupel species) - -Note that the options docloud and doprecip appear in the PARAMETERS -namelist. Other options are in the MICRO_M2005 namelist and are -discussed below. - -MICRO_M2005 namelist options: - -doicemicro (logical, default=.true.): Add cloud ice and snow - microphysical species. Each species will be represented by two - prognostic variables: a mass mixing ratio and a number concentration. - -dograupel (logical, default=.true.): Add graupel as a microphysical - species. Prognostic variables for mass mixing ratio and number - concentration. - -dosb_warm_rain (logical, default=.false.): If true, use Seifert & - Beheng (2001) warm rain parameterization in place of the default - Khairoutdinov & Kogan (2000) scheme. - -dopredictNc (logical, default=.true.): Predict cloud water droplet - number concentration. Manner of droplet activation is controlled by - dospecifyaerosol. - -Nc0 (real, default=100.): If dopredictNc=.false., Nc0 is the cloud - droplet number concentration for all time. If dopredictNc=.true., Nc0 - is the initial cloud droplet number concentration if cloud exists in - the initial sounding. - -dospecifyaerosol (logical, default=.false.): If true, two modes of - aerosol (from which the cloud water droplets will be activated) can be - specified. Otherwise, a power-law activaton scheme is used. - -If dospecifyaerosol=.false., cloud droplet activation is controlled by - (defaults come from maritime values adapted from Rasmussen et al 2002 - by Hugh Morrison, suggested continental values are 1000., 0.5): - - ccnconst (real, default=120.): constant in N_{ccn} = C*S^K - where S is supersaturation. Units are cm^{-3}, I believe. - ccnexpnt (real, default=0.4): exponent in N_{ccn} = C*S^K. - -If dospecifyaerosol=.true., cloud droplet activation is controlled by - (defaults from MPACE, note that aerosol properties are currently set - up for ammonium sulfate): - - aer_rm1 (real, default=0.052): geometric mean radius (in microns) of - aerosol size distribution of aerosol mode 1. - aer_sig1 (real, default=2.04): geometric standard deviation of mode 1. - aer_n1 (real, default=72.2): number concentration (in #/cm3) of mode 1. - - aer_rm2 (real, default=1.3): geometric mean radius (in microns) of - aerosol size distribution of aerosol mode 2. - aer_sig2 (real, default=2.5): geometric standard deviation of mode 2. - aer_n2 (real, default=1.8): number concentration (in #/cm3) of mode 2. - -dosubgridw (logical, default=.false.): NOT IMPLEMENTED YET. In large - grid spacing simulations, this option would allow cloud droplet - activation to incorporate information about subgrid variations in - vertical velocity. - -doarcticicenucl (logical, default=.false): If true, use MPACE - observations for ice nucleation conditions. If false, use - mid-latitude formula from Rasmussen et al (2002). - -docloudedgeactivation (logical, default=.false.): Explanation from - Hugh Morrison in the code: - - If true, neglect droplet activation at lateral cloud edges due to - unresolved entrainment and mixing. Activate at cloud base - or in region with little cloud water using non-equlibrium - supersaturation assuming no initial cloud water. In cloud - interior activate using equilibrium supersaturation - - - If false, assume droplet activation at lateral cloud edges due to - unresolved entrainment and mixing dominates. Activate - droplets everywhere in the cloud using non-equilibrium - supersaturation assuming no initial cloud water, based on - the local sub-grid and/or grid-scale vertical velocity at - the grid point. - -dofix_pgam (logical, default=.false.): Fix the exponent in the Gamma - distribution approximation to the cloud water droplet size - distribution. If true, the value from pgam_fixed is used. If - false, a diagnostic relationship from observations that expressed - the exponent as a function of the number concentration is used: - - pgam = 0.2714 + 0.00057145*Nc where Nc has units of #/cm3 - -pgam_fixed (real, default=5.): Value of exponent used if - dofix_pgam=.true. - - diff --git a/src/physics/spcam/crm/MICRO_M2005/crmx_drop_activation.F90 b/src/physics/spcam/crm/MICRO_M2005/crmx_drop_activation.F90 deleted file mode 100644 index bdbf3b2f5e..0000000000 --- a/src/physics/spcam/crm/MICRO_M2005/crmx_drop_activation.F90 +++ /dev/null @@ -1,373 +0,0 @@ -module crmx_drop_activation -#ifdef MODAL_AERO -!---------------------------------------------------------------------------------------------------- -! -! Purposes: calcualte dropelt number concentration activated from aerosol particle, used -! in Morrison's two-moment microphysics in SAM. It treats multimode aerosol population, -! and aerosol fields are taken from the modal aerosol treatment in CAM. -! -! Method: This module is adopted from the module of ndrop used in CAM, originally writted by -! Steven Ghan. -! -! Revision history: -! July, 2009: adopted from the module of ndrop used in CAM. -! -!---------------------------------------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 - use modal_aero_data, only: ntot_amode - - implicit none - private - save - - public :: drop_activation_init, drop_activation_Ghan - - real(r8),allocatable :: npv(:) ! number per volume concentration - real(r8),allocatable :: alogsig(:) ! natl log of geometric standard dev of aerosol - real(r8),allocatable :: exp45logsig(:) - real(r8),allocatable :: argfactor(:) - real(r8),allocatable :: f1(:),f2(:) ! abdul-razzak functions of width - - real(r8) :: t0 ! reference temperature - real(r8) :: aten - real(r8) :: surften ! surface tension of water w/respect to air (N/m) - real(r8) :: alogten,alog2,alog3,alogaten - real(r8) :: third, twothird, sixth, zero - real(r8) :: sq2, sqpi, pi - -contains -!---------------------------------------------------------------------------------- - -!================================================================================== -subroutine drop_activation_init -!------------------------------------------------------------------------ -! Initialize constants, and prescribed parameters. -!----------------------------------------------------------------------- - use modal_aero_data - use physconst, only: rhoh2o, mwh2o, r_universal - implicit none - - integer l,m - real(r8) arg - -! mathematical constants - - zero=0._r8 - third=1./3._r8 - twothird=2.*third - sixth=1./6._r8 - sq2=sqrt(2._r8) - pi=4._r8*atan(1.0_r8) - sqpi=sqrt(pi) - - t0=273. - surften=0.076_r8 - aten=2.*mwh2o*surften/(r_universal*t0*rhoh2o) - alogaten=log(aten) - alog2=log(2._r8) - alog3=log(3._r8) - - if (.not. allocated(npv)) allocate (npv(ntot_amode)) - if (.not. allocated(alogsig)) allocate (alogsig(ntot_amode)) - if (.not. allocated(exp45logsig)) allocate (exp45logsig(ntot_amode)) - if (.not. allocated(argfactor)) allocate (argfactor(ntot_amode)) - if (.not. allocated(f1)) allocate (f1(ntot_amode)) - if (.not. allocated(f2)) allocate (f2(ntot_amode)) - - do m=1,ntot_amode -! use only if width of size distribution is prescribed - alogsig(m)=log(sigmag_amode(m)) - exp45logsig(m)=exp(4.5*alogsig(m)*alogsig(m)) - argfactor(m)=2./(3.*sqrt(2.)*alogsig(m)) - f1(m)=0.5*exp(2.5*alogsig(m)*alogsig(m)) - f2(m)=1.+0.25*alogsig(m) - end do - - return -end subroutine drop_activation_init -!------------------------------------------------------------------------------------------------------- - -!======================================================================================================= -subroutine drop_activation_Ghan(wnuc4, tair4, rhoair4, & - ndrop4, ines, smaxinout4, k) -!------------------------------------------------------------------------------------------------------- -! -! Purpose and method: 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 pmode 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. -! -! Revision history: -! 2009-07-17: Originally written by Gteven Ghan, and adopted by Minghuai Wang. -! -!------------------------------------------------------------------------------------------------------------ - - use physconst, only: rair, epsilo, cpair, rh2o, latvap, gravit, & - rhoh2o, mwh2o, r_universal - use wv_saturation, only: estblf - use physconst, only: epsqs => epsilo - use shr_spfn_mod, only: erf => shr_spfn_erf - use modal_aero_data - use crmx_vars, only: naer, vaer, hgaer - - implicit none - - -! Input - real, intent (in) :: wnuc4 ! updraft velocity (m/s) - real, intent (in) :: tair4 ! air temperature (K) - real, intent (in) :: rhoair4 ! air density (kg/m3) - integer, intent(in) :: ines ! whether non-equillium saturation is used (ines=1: used). - real, intent (inout) :: smaxinout4 ! For ines=1, it is non-equlibrium saturation ratio (input) - ! for ines=0, it is smax calculted from the activation parameterizaiton (output). - integer, intent(in) :: k ! the index of vertical levels. - -! Output - real, intent (out) :: ndrop4 ! activated droplet number concentration - - -! Local - real(r8) :: wnuc ! updraft velocity (m/s) - real(r8) :: tair ! air temperature (K) - real(r8) :: rhoair ! air density (kg/m3) - real(r8) na(ntot_amode) ! aerosol number concentration (/m3) - integer nmode ! number of aerosol modes - real(r8) volume(ntot_amode) ! aerosol volume concentration (m3/m3) - real(r8) hygro(ntot_amode) ! hygroscopicity of aerosol mode - - real(r8) fn(ntot_amode) ! number fraction of aerosols activated - real(r8) fm(ntot_amode) ! mass fraction of aerosols activated - real(r8) fluxn(ntot_amode) ! flux of activated aerosol number fraction into cloud (cm/s) - real(r8) fluxm(ntot_amode) ! flux of activated aerosol mass fraction into cloud (cm/s) - real(r8) 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 - - real(r8), parameter :: p0 = 1013.25e2_r8 ! reference pressure (Pa) - real(r8) sign(ntot_amode) ! geometric standard deviation of size distribution - real(r8) pres ! pressure (Pa) - real(r8) diff0 ! diffusivity (m2/s) - real(r8) conduct0 ! thermal conductivity (Joule/m/sec/deg) - 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(ntot_amode), eta(ntot_amode) - real(r8) lnsmax ! ln(smax) - real(r8) alpha - real(r8) gamma - real(r8) beta - real(r8) sqrtg(ntot_amode) - real(r8) :: amcube(ntot_amode) ! cube of dry mode radius (m) - real(r8) :: lnsm(ntot_amode) ! ln(smcrit) - real(r8) smc(ntot_amode) ! critical supersaturation for number mode radius - real(r8) alw,sqrtalw - real(r8) smax - real(r8) x,arg - real(r8) xmincoeff - real(r8) z - real(r8) etafactor1,etafactor2(ntot_amode),etafactor2max - real(r8) wmaxf ! maximum update velocity [m/s] - real ndrop_act - 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) - - wnuc = wnuc4 - tair = tair4 - rhoair = rhoair4 - -! Set aerosol fields - na = naer(k, :) - volume = vaer(k, :) - hygro = hgaer(k, :) - - nmode = ntot_amode - wmaxf = 10.0 - - fn(:)=0._r8 - fm(:)=0._r8 - fluxn(:)=0._r8 - fluxm(:)=0._r8 - flux_fullact=0._r8 - ndrop4 = 0. - ndrop_act = 0. - - if(nmode.eq.1.and.na(1).lt.1.e-20_r8)return - - pres=rair*rhoair*tair - diff0=0.211e-4_r8*(p0/pres)*(tair/t0)**1.94 - conduct0=(5.69_r8+0.017_r8*(tair-t0))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg - es = estblf(tair) - qs = epsilo*es/(pres-(1.0_r8 - epsqs)*es) - dqsdt=latvap/(rh2o*tair*tair)*qs - alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1./(rair*tair)) - gamma=(1+latvap/cpair*dqsdt)/(rhoair*qs) - etafactor2max=1.e10/(alpha*wmaxf)**1.5 ! this should make eta big if na is very small. - - 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(6,*)'alogsig,volc,na=',alogsig(m),volc(m),na(m) - amcube(m)=(3.*volume(m)/(4.*pi*exp45logsig(m)*na(m))) ! only if variable size dist -! 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. - g=1._r8/(rhoh2o/(diff0*rhoair*qs) & - +latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair)-1._r8)) - sqrtg(m)=sqrt(g) - beta=2._r8*pi*rhoh2o*g*gamma - etafactor2(m)=1._r8/(na(m)*beta*sqrtg(m)) - if(hygro(m).gt.1.e-10)then - smc(m)=2.*aten*sqrt(aten/(27.*hygro(m)*amcube(m))) ! only if variable size dist - else - smc(m)=100. - endif -! write(6,*)'sm,hygro,amcube=',smcrit(m),hygro(m),amcube(m) - else - g=1._r8/(rhoh2o/(diff0*rhoair*qs) & - +latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair)-1._r8)) - sqrtg(m)=sqrt(g) - 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(6,'(a,i4,4g12.2)')'m,na,amcube,hygro,sm,lnsm=', & -! m,na(m),amcube(m),hygro(m),sm(m),lnsm(m) - enddo - -! single updraft - - if(wnuc.gt.0._r8)then - - alw=alpha*wnuc - sqrtalw=sqrt(alw) - etafactor1=alw*sqrtalw - - do m=1,nmode - eta(m)=etafactor1*etafactor2(m) - zeta(m)=twothird*sqrtalw*aten/sqrtg(m) - enddo - - call maxsat(zeta,eta,nmode,smc,smax) - - lnsmax=log(smax) - xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 - - do m=1,nmode -! modal - x=twothird*(lnsm(m)-lnsmax)/(sq2*alogsig(m)) - fn(m)=0.5_r8*(1._r8-erf(x)) - arg=x-1.5_r8*sq2*alogsig(m) - fm(m)=0.5_r8*(1._r8-erf(arg)) - if(wnuc.gt.0._r8)then - fluxn(m)=fn(m)*wnuc - fluxm(m)=fm(m)*wnuc - endif - ndrop_act = ndrop_act + fn(m) * na (m) - enddo - flux_fullact = wnuc - - if(ines.eq.0) then - ndrop4 = ndrop_act - smaxinout4 = smax - else if(ines.eq.1) then -! for non-equlibrium ss - smax = smaxinout4 - lnsmax=log(smax) - xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 - - do m=1,nmode -! modal - x=twothird*(lnsm(m)-lnsmax)/(sq2*alogsig(m)) - fn(m)=0.5_r8*(1._r8-erf(x)) - arg=x-1.5_r8*sq2*alogsig(m) - fm(m)=0.5_r8*(1._r8-erf(arg)) - if(wnuc.gt.0._r8)then - fluxn(m)=fn(m)*wnuc - fluxm(m)=fm(m)*wnuc - endif - ndrop4 = ndrop4 + fn(m) * na (m) - enddo - flux_fullact = wnuc - ndrop4 = min(ndrop4, ndrop_act) - end if - - endif - -! sensitivity tests: -! ndrop4 = max(ndrop4, 100.*1.0e6) ! the minimum activated droplet number is 100 /cm3 - - return -end subroutine drop_activation_Ghan -!---------------------------------------------------------------------------------------- - -!======================================================================================= - subroutine maxsat(zeta,eta,nmode,smc,smax) - -! 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. - - implicit none - - integer nmode ! number of modes - real(r8) smc(ntot_amode) ! critical supersaturation for number mode radius - real(r8) zeta(ntot_amode), eta(ntot_amode) - real(r8) smax ! maximum supersaturation - integer m ! mode index - real(r8) sum, g1, g2, g1sqrt, g2sqrt - - 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. - go to 1 - endif - enddo - - return - - 1 continue - - sum=0 - 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(m)*g1+f2(m)*g2)/(smc(m)*smc(m)) - else - sum=1.e20_r8 - endif - enddo - - smax=1._r8/sqrt(sum) - - return - -end subroutine maxsat -!-------------------------------------------------------------------------------------- - -#endif -end module crmx_drop_activation - diff --git a/src/physics/spcam/crm/MICRO_M2005/crmx_microphysics.F90 b/src/physics/spcam/crm/MICRO_M2005/crmx_microphysics.F90 deleted file mode 100644 index 851ecafaf1..0000000000 --- a/src/physics/spcam/crm/MICRO_M2005/crmx_microphysics.F90 +++ /dev/null @@ -1,1660 +0,0 @@ -module crmx_microphysics - -! main interface to Morrison microphysics. -! original implementation by Peter Blossey, UW - -use crmx_params, only: lcond, lsub, fac_cond, fac_sub, ggr - -use crmx_grid, only: nx,ny,nzm,nz, & !grid dimensions; nzm = nz-1 # of scalar lvls - dimx1_s,dimx2_s,dimy1_s,dimy2_s, & ! actual scalar-array dimensions in x,y - dz, adz, dostatis, masterproc, & - doSAMconditionals, dosatupdnconditionals - -use crmx_vars, only: pres, rho, dt, dtn, w, t, tlatqi, condavg_mask, & - ncondavg, condavgname, condavglongname -use crmx_vars, only: tke2, tk2 -use crmx_params, only: doprecip, docloud, doclubb - -use crmx_module_mp_GRAUPEL, only: GRAUPEL_INIT, M2005MICRO_GRAUPEL, & - doicemicro, & ! use ice species (snow/cloud ice/graupel) - dograupel, & ! use graupel - dohail, & ! use graupel - dosb_warm_rain, & ! use Seifert & Beheng (2001) warm rain parameterization - dopredictNc, & ! prediction of cloud droplet number - aerosol_mode, & ! specify two modes of (sulfate) aerosol -#if (defined CRM && defined MODAL_AERO) - domodal_aero, & ! use modal aerosol from the CAM -#endif -#ifdef CLUBB_CRM - doclubb_tb, & ! use CLUBB as turbulence scheme only, but not cloud scheme, - ! so liquid water is diagnosed from saturation adjustment - doclubb_gridmean, & ! feed grid-mean CLUBB values into Morrision microphysics - doclubb_autoin, & ! use in-cloud values for autoconversion calculations -#endif - dosubgridw, & ! input estimate of subgrid w to microphysics - doarcticicenucl,& ! use arctic parameter values for ice nucleation - docloudedgeactivation,&! activate droplets at cloud edges as well as base - Nc0, & ! initial/specified cloud droplet number conc (#/cm3) - ccnconst, ccnexpnt, & ! parameters for aerosol_mode=1 (powerlaw CCN) - aer_rm1, aer_rm2, & ! two modes of aerosol for aerosol_mode=2 - aer_n1, aer_n2, & ! rm=geometric mean radius (um), n=aerosol conc. (#/cm3) - aer_sig1, aer_sig2, & ! sig=geom standard deviation of aerosol size distn. - dofix_pgam, pgam_fixed ! option to specify pgam (exponent of cloud water's gamma distn) - -#ifdef CRM - use cam_abortutils, only: endrun -#endif - -implicit none - -logical :: isallocatedMICRO = .false. - -integer :: nmicro_fields ! total number of prognostic water vars - -real, allocatable, dimension(:,:,:,:) :: micro_field ! holds mphys quantities - -! indices of water quantities in micro_field, e.g. qv = micro_field(:,:,:,iqv) -integer :: iqv, iqci, iqr, iqs, iqg, incl, inci, inr, ins, ing -integer :: index_water_vapor ! separate water vapor index used by SAM - -real, allocatable, dimension(:) :: lfac -integer, allocatable, dimension(:) :: flag_wmass, flag_precip, flag_number -integer, allocatable, dimension(:) :: flag_micro3Dout - -integer, parameter :: index_cloud_ice = -1 ! historical variable (don't change) - -real, allocatable, dimension(:,:,:) :: fluxbmk, fluxtmk !surface/top fluxes -real, allocatable, dimension(:,:,:) :: reffc, reffi -real, allocatable, dimension(:,:,:) :: cloudliq - -real, allocatable, dimension(:,:) :: & ! statistical arrays - mkwle, & ! resolved vertical flux - mkwsb, & ! SGS vertical flux - mksed, & ! sedimentation vertical flux - mkadv, & ! tendency due to vertical advection - mkdiff, &! tendency due to vertical diffusion - mklsadv, & ! tendency due to large-scale vertical advection - mfrac, & ! fraction of domain with microphysical quantity > 1.e-6 - stend, & ! tendency due to sedimentation - mtend, & ! tendency due to microphysical processes (other than sedimentation) - mstor, & ! storage terms of microphysical variables - trtau ! optical depths of various species - -real, allocatable, dimension(:) :: tmtend - -real :: sfcpcp, sfcicepcp - -! arrays with names/units for microphysical outputs in statistics. -character*3, allocatable, dimension(:) :: mkname -character*80, allocatable, dimension(:) :: mklongname -character*10, allocatable, dimension(:) :: mkunits -real, allocatable, dimension(:) :: mkoutputscale -logical douse_reffc, douse_reffi - -! You can also have some additional, diagnostic, arrays, for example, total -! nonprecipitating cloud water, etc: - -!bloss: array which holds temperature tendency due to microphysics -real, allocatable, dimension(:,:,:), SAVE :: tmtend3d - -#ifdef CRM -real, allocatable, dimension(:) :: qpevp !sink of precipitating water due to evaporation (set to zero here) -real, allocatable, dimension(:) :: qpsrc !source of precipitation microphysical processes (set to mtend) -#endif - -real, allocatable, dimension(:,:,:) :: wvar ! the vertical velocity variance from subgrid-scale motion, - ! which is needed in droplet activation. -#ifdef CRM -! hm 7/26/11 new output -real, public, allocatable, dimension(:,:,:) :: aut1 ! -real, public, allocatable, dimension(:,:,:) :: acc1 ! -real, public, allocatable, dimension(:,:,:) :: evpc1 ! -real, public, allocatable, dimension(:,:,:) :: evpr1 ! -real, public, allocatable, dimension(:,:,:) :: mlt1 ! -real, public, allocatable, dimension(:,:,:) :: sub1 ! -real, public, allocatable, dimension(:,:,:) :: dep1 ! -real, public, allocatable, dimension(:,:,:) :: con1 ! - -real, public, allocatable, dimension(:,:,:) :: aut1a ! -real, public, allocatable, dimension(:,:,:) :: acc1a ! -real, public, allocatable, dimension(:,:,:) :: evpc1a ! -real, public, allocatable, dimension(:,:,:) :: evpr1a ! -real, public, allocatable, dimension(:,:,:) :: mlt1a ! -real, public, allocatable, dimension(:,:,:) :: sub1a ! -real, public, allocatable, dimension(:,:,:) :: dep1a ! -real, public, allocatable, dimension(:,:,:) :: con1a ! -#endif - -!+++mhwangtest -! test water conservation -real, public, allocatable, dimension(:, :) :: sfcpcp2D ! surface precipitation -!---mhwangtest - -CONTAINS - -!---------------------------------------------------------------------- -!!! Read microphysical options from prm file and allocate variables -! -subroutine micro_setparm() - use crmx_vars -#ifdef CLUBB_CRM - use crmx_module_mp_graupel, only: NNUCCD_REDUCE_COEF, NNUCCC_REDUCE_COEF -#endif - implicit none - - integer ierr, ios, ios_missing_namelist, place_holder - - NAMELIST /MICRO_M2005/ & -#ifdef CLUBB_CRM - NNUCCD_REDUCE_COEF, NNUCCC_REDUCE_COEF, & -#endif - doicemicro, & ! use ice species (snow/cloud ice/graupel) - dograupel, & ! use graupel - dohail, & ! graupel species has qualities of hail - dosb_warm_rain, & ! use Seifert & Beheng (2001) warm rain parameterization in place of KK(2000) - dopredictNc, & ! prediction of cloud droplet number - aerosol_mode, & ! specify two modes of (sulfate) aerosol - dosubgridw, & ! input estimate of subgrid w to microphysics - doarcticicenucl,& ! use arctic parameter values for ice nucleation - docloudedgeactivation,&! activate droplets at cloud edges as well as base - Nc0, & ! initial/specified cloud droplet number conc (#/cm3) - ccnconst, ccnexpnt, & ! parameters for aerosol_mode=1 (powerlaw CCN) - aer_rm1, aer_rm2, & ! two modes of aerosol for aerosol_mode=2 - aer_n1, aer_n2, & ! rm=geometric mean radius (um), n=aerosol conc. (#/cm3) - aer_sig1, aer_sig2, & ! sig=geom standard deviation of aerosol size distn. - dofix_pgam, pgam_fixed, & ! option to specify pgam (exponent of cloud water's gamma distn) - douse_reffc, & ! use computed effective radius in radiation computation - douse_reffi ! use computed effective ice size in radiation computation - - !bloss: Create dummy namelist, so that we can figure out error code - ! for a mising namelist. This lets us differentiate between - ! missing namelists and those with an error within the namelist. - NAMELIST /BNCUIODSBJCB/ place_holder - - ! define default values for namelist variables - doicemicro = .true. ! use ice - dograupel = .true. ! use graupel - dohail = .false. ! graupel species has properties of graupel - dosb_warm_rain = .false. ! use KK (2000) warm rain scheme by default - dopredictNc = .true. ! prognostic cloud droplet number -#if (defined CRM && defined MODAL_AERO) - domodal_aero = .true. ! use modal aerosol -#endif -#ifdef CLUBB_CRM - dosubgridw = .true. ! Use clubb's w'^2 for sgs w - aerosol_mode = 2 ! use lognormal CCN relationship - doarcticicenucl = .false. ! use mid-latitude parameters - docloudedgeactivation = .false. ! activate droplets at cloud base, and edges - doclubb_tb = .false. - doclubb_gridmean = .true. - doclubb_autoin = .false. -#else - aerosol_mode = 2 - dosubgridw = .true. - doarcticicenucl = .false. ! use mid-latitude parameters - docloudedgeactivation = .true. -#endif /*CLUBB_CRM*/ - douse_reffc = .false. ! use computed effective radius in rad computations? - douse_reffi = .false. ! use computed effective radius in rad computations? - - Nc0 = 100. ! default droplet number concentration - - ccnconst = 120. ! maritime value (/cm3), adapted from Rasmussen - ccnexpnt = 0.4 ! et al (2002) by Hugh Morrison et al. Values - ! of 1000. and 0.5 suggested for continental -! aer_rm1 = 0.052 ! two aerosol mode defaults from MPACE (from Hugh) -! aer_sig1 = 2.04 -! aer_n1 = 72.2 -! aer_rm2 = 1.3 -! aer_sig2 = 2.5 -! aer_n2 = 1.8 - - aer_rm1 = 0.052 ! two aerosol mode defaults (from mhwang for testing in global models) - aer_sig1 = 2.04 - aer_n1 = 2500 - aer_rm2 = 1.3 - aer_sig2 = 2.5 - aer_n2 = 1.8 - - dofix_pgam = .false. - pgam_fixed = 5. ! middle range value -- corresponds to radius dispersion ~ 0.4 - - !---------------------------------- - ! Read namelist for microphysics options from prm file: - !------------ -! open(55,file='./'//trim(case)//'/prm', status='old',form='formatted') - - !bloss: get error code for missing namelist (by giving the name for - ! a namelist that doesn't exist in the prm file). -! read (UNIT=55,NML=BNCUIODSBJCB,IOSTAT=ios_missing_namelist) -! rewind(55) !note that one must rewind before searching for new namelists - - !bloss: read in MICRO_M2005 namelist -! read (55,MICRO_M2005,IOSTAT=ios) - -! if (ios.ne.0) then -! !namelist error checking -! if(ios.ne.ios_missing_namelist) then -! write(*,*) '****** ERROR: bad specification in MICRO_M2005 namelist' -! call task_abort() -! elseif(masterproc) then -! write(*,*) '****************************************************' -! write(*,*) '****** No MICRO_M2005 namelist in prm file *********' -! write(*,*) '****************************************************' -! end if -! end if -! close(55) - - if(.not.doicemicro) dograupel=.false. - - if(dohail.and..NOT.dograupel) then - if(masterproc) write(*,*) 'dograupel must be .true. for dohail to be used.' - call task_abort() - end if - - ! write namelist values out to file for documentation -! if(masterproc) then -! open(unit=55,file='./'//trim(case)//'/'//trim(case)//'_'//trim(caseid)//'.options_namelist', form='formatted', position='append') -! write (unit=55,nml=MICRO_M2005,IOSTAT=ios) -! write(55,*) ' ' -! close(unit=55) -! end if - - ! scale values of parameters for m2005micro - aer_rm1 = 1.e-6*aer_rm1 ! convert from um to m - aer_rm2 = 1.e-6*aer_rm2 - aer_n1 = 1.e6*aer_n1 ! convert from #/cm3 to #/m3 - aer_n2 = 1.e6*aer_n2 - - nmicro_fields = 1 ! start with water vapor and cloud water mass mixing ratio -#ifdef CLUBB_CRM - if(docloud.or.doclubb) then -#else - if(docloud) then -#endif -!bloss/qt nmicro_fields = nmicro_fields + 1 ! add cloud water mixing ratio - if(dopredictNc) nmicro_fields = nmicro_fields + 1 ! add cloud water number concentration (if desired) - end if - if(doprecip) nmicro_fields = nmicro_fields + 2 ! add rain mass and number (if desired) - if(doicemicro) nmicro_fields = nmicro_fields + 4 ! add snow and cloud ice number and mass (if desired) - if(dograupel) nmicro_fields = nmicro_fields + 2 ! add graupel mass and number (if desired) - - ! specify index of various quantities in micro_field array - ! *** note that not all of these may be used if(.not.doicemicro) *** - iqv = 1 ! total water (vapor + cloud liq) mass mixing ratio [kg H2O / kg dry air] -!bloss/qt iqcl = 2 ! cloud water mass mixing ratio [kg H2O / kg dry air] - -!bloss/qt: cloud liquid water no longer prognosed - if(dopredictNc) then - incl = 2 ! cloud water number mixing ratio [#/kg dry air] - iqr = 3 ! rain mass mixing ratio [kg H2O / kg dry air] - inr = 4 ! rain number mixing ratio [#/kg dry air] - iqci = 5 ! cloud ice mass mixing ratio [kg H2O / kg dry air] - inci = 6 ! cloud ice number mixing ratio [#/kg dry air] - iqs = 7 ! snow mass mixing ratio [kg H2O / kg dry air] - ins = 8 ! snow number mixing ratio [#/kg dry air] - iqg = 9 ! graupel mass mixing ratio [kg H2O / kg dry air] - ing = 10 ! graupel number mixing ratio [#/kg dry air] - else - iqr = 2 ! rain mass mixing ratio [kg H2O / kg dry air] - inr = 3 ! rain number mixing ratio [#/kg dry air] - iqci = 4 ! cloud ice mass mixing ratio [kg H2O / kg dry air] - inci = 5 ! cloud ice number mixing ratio [#/kg dry air] - iqs = 6 ! snow mass mixing ratio [kg H2O / kg dry air] - ins = 7 ! snow number mixing ratio [#/kg dry air] - iqg = 8 ! graupel mass mixing ratio [kg H2O / kg dry air] - ing = 9 ! graupel number mixing ratio [#/kg dry air] - end if - - ! stop if icemicro is specified without precip -- we don't support this right now. - if((doicemicro).and.(.not.doprecip)) then - if(masterproc) write(*,*) 'Morrison 2005 Microphysics does not support both doice and .not.doprecip' - call task_abort() - end if - index_water_vapor = iqv ! set SAM water vapor flag - - if(.not.isallocatedMICRO) then - ! allocate microphysical variables - allocate(micro_field(dimx1_s:dimx2_s,dimy1_s:dimy2_s,nzm,nmicro_fields), & - fluxbmk(nx,ny,nmicro_fields), fluxtmk(nx,ny,nmicro_fields), & - reffc(nx,ny,nzm), reffi(nx,ny,nzm), & - mkwle(nz,nmicro_fields), mkwsb(nz,nmicro_fields), & - mkadv(nz,nmicro_fields), mkdiff(nz,nmicro_fields), & - mklsadv(nz,nmicro_fields), & - stend(nzm,nmicro_fields), mtend(nzm,nmicro_fields), & - mfrac(nzm,nmicro_fields), trtau(nzm,nmicro_fields), & - mksed(nzm,nmicro_fields), tmtend(nzm), & - mstor(nzm,nmicro_fields), & - cloudliq(nx,ny,nzm), & - tmtend3d(nx,ny,nzm), flag_micro3Dout(nmicro_fields), & - flag_wmass(nmicro_fields), flag_precip(nmicro_fields), & - flag_number(nmicro_fields), lfac(nmicro_fields), & - mkname(nmicro_fields), mklongname(nmicro_fields), & - mkunits(nmicro_fields), mkoutputscale(nmicro_fields), STAT=ierr) - -#ifdef CRM - allocate (qpevp(nz), qpsrc(nz), STAT=ierr) -#endif - allocate (wvar(nx,ny,nzm), STAT=ierr) - -#ifdef CRM -! hm 7/26/11, add new output - allocate (aut1(nx,ny,nzm), STAT=ierr) - allocate (acc1(nx,ny,nzm), STAT=ierr) - allocate (evpc1(nx,ny,nzm), STAT=ierr) - allocate (evpr1(nx,ny,nzm), STAT=ierr) - allocate (mlt1(nx,ny,nzm), STAT=ierr) - allocate (sub1(nx,ny,nzm), STAT=ierr) - allocate (dep1(nx,ny,nzm), STAT=ierr) - allocate (con1(nx,ny,nzm), STAT=ierr) - - allocate (aut1a(nx,ny,nzm), STAT=ierr) - allocate (acc1a(nx,ny,nzm), STAT=ierr) - allocate (evpc1a(nx,ny,nzm), STAT=ierr) - allocate (evpr1a(nx,ny,nzm), STAT=ierr) - allocate (mlt1a(nx,ny,nzm), STAT=ierr) - allocate (sub1a(nx,ny,nzm), STAT=ierr) - allocate (dep1a(nx,ny,nzm), STAT=ierr) - allocate (con1a(nx,ny,nzm), STAT=ierr) -#endif - -!+++mhwangtest - allocate (sfcpcp2D(nx,ny), STAT=ierr) -!---mhwangtest - - if(ierr.ne.0) then - write(*,*) 'Failed to allocate microphysical arrays on proc ', rank - call task_abort() - else - isallocatedMICRO = .true. - end if - - ! zero out statistics variables associated with cloud ice sedimentation - ! in Marat's default SAM microphysics - tlatqi = 0. - - ! initialize these arrays - micro_field = 0. - cloudliq = 0. !bloss/qt: auxially cloud liquid water variable, analogous to qn in MICRO_SAM1MOM - fluxbmk = 0. - fluxtmk = 0. - mkwle = 0. - mkwsb = 0. - mkadv = 0. - mkdiff = 0. - mklsadv = 0. - mstor =0. - - wvar = 0. - -#ifdef CRM -! hm 7/26/11, new output - aut1 = 0. - acc1 = 0. - evpc1 = 0. - evpr1 = 0. - mlt1 = 0. - sub1 = 0. - dep1 = 0. - con1 = 0. - aut1a = 0. - acc1a = 0. - evpc1a = 0. - evpr1a = 0. - mlt1a = 0. - sub1a = 0. - dep1a = 0. - con1a = 0. -#endif - - ! initialize flag arrays to all mass, no number, no precip - flag_wmass = 1 - flag_number = 0 - flag_precip = 0 - flag_micro3Dout = 0 - - end if - - compute_reffc = douse_reffc - compute_reffi = douse_reffi - -end subroutine micro_setparm - -!---------------------------------------------------------------------- -!!! Initialize microphysics: -! -! this one is guaranteed to be called by SAM at the -! beginning of each run, initial or restart: -subroutine micro_init() - - use crmx_vars -#if (defined CRM && defined MODAL_AERO) - use crmx_drop_activation, only: drop_activation_init -#endif - - implicit none - - real, dimension(nzm) :: qc0, qi0 - -! Commented out by dschanen UWM 23 Nov 2009 to avoid a linking error -! real, external :: satadj_water - integer :: k - - ! initialize flag arrays - if(dopredictNc) then - ! Cloud droplet number concentration is a prognostic variable - if(doicemicro) then - if(dograupel) then - !bloss/qt: qt, Nc, qr, Nr, qi, Ni, qs, Ns, qg, Ng - flag_wmass = (/1,0,1,0,1,0,1,0,1,0/) - flag_precip = (/0,0,1,1,0,0,1,1,1,1/) - flag_number = (/0,1,0,1,0,1,0,1,0,1/) - else - !bloss/qt: qt, Nc, qr, Nr, qi, Ni, qs, Ns - flag_wmass = (/1,0,1,0,1,0,1,0/) - flag_precip = (/0,0,1,1,0,0,1,1/) - flag_number = (/0,1,0,1,0,1,0,1/) - end if - else - if(doprecip) then - !bloss/qt: qt, Nc, qr, Nr - flag_wmass = (/1,0,1,0/) - flag_precip = (/0,0,1,1/) - flag_number = (/0,1,0,1/) - else - !bloss/qt: qt, Nc - flag_wmass = (/1,0/) - flag_precip = (/0,0/) - flag_number = (/0,1/) - end if - end if - else - ! Cloud droplet number concentration is NOT a prognostic variable - if(doicemicro) then - if(dograupel) then - !bloss/qt: qt, qr, Nr, qi, Ni, qs, Ns, qg, Ng - flag_wmass = (/1,1,0,1,0,1,0,1,0/) - flag_precip = (/0,1,1,0,0,1,1,1,1/) - flag_number = (/0,0,1,0,1,0,1,0,1/) - else - !bloss/qt: qt, qr, Nr, qi, Ni, qs, Ns - flag_wmass = (/1,1,0,1,0,1,0/) - flag_precip = (/0,1,1,0,0,1,1/) - flag_number = (/0,0,1,0,1,0,1/) - end if - else - if(doprecip) then - !bloss/qt: qt, qr, Nr - flag_wmass = (/1,1,0/) - flag_precip = (/0,1,1/) - flag_number = (/0,0,1/) - else - !bloss/qt: only total water variable is needed for no-precip, - ! fixed droplet number, warm cloud and no cloud simulations. - flag_wmass = (/1/) - flag_precip = (/0/) - flag_number = (/0/) - end if - end if - end if - - ! output all microphysical fields to 3D output files if using more than - ! just docloud. Otherwise, rely on basic SAM outputs -#ifdef CLUBB_CRM - if((docloud.OR.doclubb).AND.(doprecip.OR.dopredictNc)) then -#else - if(docloud.AND.(doprecip.OR.dopredictNc)) then -#endif - flag_micro3Dout = 1 - end if - - ! initialize factor for latent heat - lfac(:) = 1. ! use one as default for number species - lfac(iqv) = lcond -!bloss/qt if(docloud) lfac(iqcl) = lcond - if(doprecip) lfac(iqr) = lcond - if(doicemicro) then - lfac(iqci) = lsub - lfac(iqs) = lsub - if(dograupel) lfac(iqg) = lsub - end if - - call graupel_init() ! call initialization routine within mphys module -#if (defined CRM && defined MODAL_AERO) - call drop_activation_init -#endif - - if(nrestart.eq.0) then - -! In SPCAM, do not need this part. -#ifndef CRM - ! compute initial profiles of liquid water - M.K. - call satadj_liquid(nzm,tabs0,q0,qc0,pres*100.) - - ! initialize microphysical quantities - q0 = q0 + qc0 - do k = 1,nzm - micro_field(:,:,k,iqv) = q0(k) - cloudliq(:,:,k) = qc0(k) - tabs(:,:,k) = tabs0(k) - end do - if(dopredictNc) then ! initialize concentration somehow... - do k = 1,nzm - if(q0(k).gt.0.) then - micro_field(:,:,k,incl) = 0.5*ccnconst*1.e6 - end if - end do - end if -#endif ! CRM - -#ifdef CLUBB_CRM - if(docloud.or.doclubb) call micro_diagnose() ! leave this line here -#else - if(docloud) call micro_diagnose() ! leave this here -#endif - - - end if - -end subroutine micro_init - -!---------------------------------------------------------------------- -!!! fill-in surface and top boundary fluxes: -! -! Obviously, for liquid/ice water variables those fluxes are zero. They are not zero -! only for water vapor variable and, possibly, for CCN and IN if you have those. - -subroutine micro_flux() - -use crmx_vars, only: fluxbq, fluxtq -#ifdef CLUBB_CRM -use crmx_params, only: doclubb, doclubb_sfc_fluxes, docam_sfc_fluxes -#endif - -fluxbmk(:,:,:) = 0. ! initialize all fluxes at surface to zero -fluxtmk(:,:,:) = 0. ! initialize all fluxes at top of domain to zero -#ifdef CLUBB_CRM -if ( doclubb .and. (doclubb_sfc_fluxes.or.docam_sfc_fluxes) ) then - fluxbmk(:,:,index_water_vapor) = 0.0 ! surface qv (latent heat) flux -else - fluxbmk(:,:,index_water_vapor) = fluxbq(:,:) ! surface qv (latent heat) flux -end if -#else -fluxbmk(:,:,index_water_vapor) = fluxbq(:,:) ! surface qv (latent heat) flux -#endif -fluxtmk(:,:,index_water_vapor) = fluxtq(:,:) ! top of domain qv flux - -end subroutine micro_flux - -!---------------------------------------------------------------------- -!!! compute local microphysics processes (beyond advection and SGS diffusion): -! -! This is the place where the condensation/sublimation, accretion, coagulation, freezing, -! melting, etc., that is all the microphysics processes except for the spatial transport happen. - -! IMPORTANT: You need to use the thermodynamic constants like specific heat, or -! specific heat of condensation, gas constant, etc, the same as in file params.f90 -! Also, you should assume that the conservative thermodynamic variable during these -! proceses is the liquid/ice water static energy: t = tabs + gz - Lc (qc+qr) - Ls (qi+qs+qg) -! It should not be changed during all of your point microphysical processes! - -subroutine micro_proc() - -use crmx_params, only: fac_cond, fac_sub, rgas -use crmx_grid, only: z, zi - -#ifdef CRM -use crmx_vars, only: t, gamaz, precsfc, precssfc, precflux, qpfall, tlat, prec_xy, & -#else -use crmx_vars, only: t, gamaz, precsfc, precflux, qpfall, tlat, prec_xy, & -#endif /*CRM*/ - nstep, nstatis, icycle, total_water_prec - -#ifdef ECPP -use crmx_ecppvars, only: qlsink, qlsink_bf, prain, precr, precsolid, rh, qcloud_bf -#endif - -#ifdef CLUBB_CRM -use crmx_params, only: doclubb, docloud, dosmoke -use crmx_grid, only: nz -use crmx_error_code, only: clubb_at_least_debug_level -use crmx_fill_holes, only: fill_holes_driver -use crmx_clubbvars, only: wp2, cloud_frac, rho_ds_zt, rho_ds_zm, relvarg, accre_enhang ! are used, but not modified here -use crmx_vars, only: qcl ! Used here and updated in micro_diagnose -use crmx_vars, only: prespot ! exner^-1 -use crmx_module_mp_GRAUPEL, only: & - cloud_frac_thresh ! Threshold for using sgs cloud fraction to weight - ! microphysical quantities [%] -use crmx_clubb_precision, only: core_rknd -use crmx_constants_clubb, only: T_freeze_K -use crmx_vars, only: CF3D -#endif - - -real, dimension(nzm) :: & - tmpqcl, tmpqci, tmpqr, tmpqs, tmpqg, tmpqv, & - tmpncl, tmpnci, tmpnr, tmpns, tmpng, & - tmpw, tmpwsub, tmppres, tmpdz, tmptabs, & -! hm 7/26/11, new output - tmpaut,tmpacc,tmpevpc,tmpevpr,tmpmlt, & - tmpsub,tmpdep,tmpcon, & - tmtend1d, & - mtendqcl, mtendqci, mtendqr, mtendqs, mtendqg, mtendqv, & - mtendncl, mtendnci, mtendnr, mtendns, mtendng, & - stendqcl, stendqci, stendqr, stendqs, stendqg, stendqv, & - stendncl, stendnci, stendnr, stendns, stendng, & - effg1d, effr1d, effs1d, effc1d, effi1d - -#ifdef ECPP -real, dimension(nzm) :: C2PREC,QSINK_TMP, CSED,ISED,SSED,GSED,RSED,RH3D ! used for cloud chemistry and wet deposition in ECPP -#endif - -#ifdef CLUBB_CRM -real(kind=core_rknd), dimension(nz) :: & - qv_clip, qcl_clip -real, dimension(nzm) :: cloud_frac_in, ice_cldfrac -real, dimension(nzm) :: liq_cldfrac -real, dimension(nzm) :: relvar ! relative cloud water variance -real, dimension(nzm) :: accre_enhan ! optional accretion enhancement factor for MG -#endif /*CLUBB_CRM*/ - -real, dimension(nzm,nmicro_fields) :: stend1d, mtend1d -real :: tmpc, tmpr, tmpi, tmps, tmpg -integer :: i1, i2, j1, j2, i, j, k, m, n - -real(kind=selected_real_kind(12)) :: tmp_total, tmptot - -! call t_startf ('micro_proc') - -#ifndef CRM -if(mod(nstep-1,nstatis).eq.0.and.icycle.eq.1) then - do j=1,ny - do i=1,nx - precsfc(i,j)=0. ! in SPCAM, done in crm.F90 - end do - end do - do k=1,nzm - precflux(k) = 0. ! in SPCAM, done in crm.F90 - end do -end if -#endif ! end CRM - -if(dostatis) then ! initialize arrays for statistics - mfrac(:,:) = 0. - mtend(:,:) = 0. - trtau(:,:) = 0. -! qpfall(:)=0. ! in SPCAM, done in crm.F90 - tlat(:) = 0. - tmtend3d(:,:,:) = 0. -end if -stend(:,:) = 0. -mksed(:,:) = 0. - -!!$if(doprecip) total_water_prec = total_water_prec + total_water() - -do j = 1,ny - do i = 1,nx - - ! zero out mixing ratios of microphysical species - tmpqv(:) = 0. - tmpqcl(:) = 0. - tmpncl(:) = 0. - tmpqr(:) = 0. - tmpnr(:) = 0. - tmpqci(:) = 0. - tmpnci(:) = 0. - tmpqs(:) = 0. - tmpns(:) = 0. - tmpqg(:) = 0. - tmpng(:) = 0. - - ! get microphysical quantities in this grid column - tmpqv(:) = micro_field(i,j,:,iqv) !bloss/qt: This is total water (qv+qcl) -!bloss/qt: compute below from saturation adjustment. -!bloss/qt tmpqcl(:) = micro_field(i,j,:,iqcl) - if(dopredictNc) tmpncl(:) = micro_field(i,j,:,incl) - if(doprecip) then - tmpqr(:) = micro_field(i,j,:,iqr) - tmpnr(:) = micro_field(i,j,:,inr) - end if - - if(doicemicro) then - tmpqci(:) = micro_field(i,j,:,iqci) - tmpnci(:) = micro_field(i,j,:,inci) - tmpqs(:) = micro_field(i,j,:,iqs) - tmpns(:) = micro_field(i,j,:,ins) - if(dograupel) then - tmpqg(:) = micro_field(i,j,:,iqg) - tmpng(:) = micro_field(i,j,:,ing) - end if - end if - - ! get absolute temperature in this column - !bloss/qt: before saturation adjustment for liquid, - ! this is Tcl = T - (L/Cp)*qcl (the cloud liquid water temperature) - tmptabs(:) = t(i,j,:) & ! liquid water-ice static energy over Cp - - gamaz(:) & ! potential energy - + fac_cond * (tmpqr(:)) & ! bloss/qt: liquid latent energy due to rain only - + fac_sub * (tmpqci(:) + tmpqs(:) + tmpqg(:)) ! ice latent energy - - tmpdz = adz(:)*dz -! tmpw = 0.5*(w(i,j,1:nzm) + w(i,j,2:nz)) ! MK: changed for stretched grids - tmpw = ((zi(2:nz)-z(1:nzm))*w(i,j,1:nzm)+ & - (z(1:nzm)-zi(1:nzm))*w(i,j,2:nz))/(zi(2:nz)-zi(1:nzm)) -#ifdef CLUBB_CRM - ! Added by dschanen on 4 Nov 2008 to account for w_sgs - if ( doclubb .and. dosubgridw ) then - ! Compute w_sgs. Formula is consistent with that used with - ! TKE from MYJ pbl scheme in WRF (see module_mp_graupel.f90). - tmpwsub = sqrt( LIN_INT( real( wp2(i,j,2:nz) ), real( wp2(i,j,1:nzm) ), & - zi(2:nz), zi(1:nzm), z(1:nzm) ) ) - else -! tmpwsub = 0. -! diagnose tmpwsub from tke. -! Notes: tke has to be already prognsotic or diagnostic. - tmpwsub = sqrt(tke2(i,j,:)/3.) ! diagnosed tmpwsub from tke -! diagnose tmpwsub from tk -! tmpwsub = sqrt(2*3.141593)*tk(i,j,:)/(dz*adz(:)) ! from Ghan et al. (1997, JGR). - end if - - if ( doclubb ) then - cloud_frac_in(1:nzm) = cloud_frac(i,j,2:nz) - liq_cldfrac(1:nzm) = cloud_frac(i,j,2:nz) - else - cloud_frac_in(1:nzm) = 0.0 - end if - -#else /* Old code */ -! tmpwsub = 0. -! diagnose tmpwsub from tke. -! Notes: tke has to be already prognsotic or diagnostic. - tmpwsub = sqrt(tke2(i,j,:)/3.) ! diagnosed tmpwsub from tke -! diagnose tmpwsub from tk -! tmpwsub = sqrt(2*3.141593)*tk(i,j,:)/(dz*adz(:)) ! from Ghan et al. (1997, JGR). -#endif - wvar(i,j,:) = tmpwsub(:) - - tmppres(:) = 100.*pres(1:nzm) - - !bloss/qt: saturation adjustment to compute cloud liquid water content. - ! Note: tmpqv holds qv+qcl on input, qv on output. - ! tmptabs hold T-(L/Cp)*qcl on input, T on output. - ! tmpqcl hold qcl on output. - ! tmppres is unchanged on output, should be in Pa. -#ifdef CLUBB_CRM - ! In the CLUBB case, we want to call the microphysics on sub-saturated grid - ! boxes and weight by cloud fraction, therefore we use the CLUBB value of - ! liquid water. -dschanen 23 Nov 2009 - if ( .not. ( docloud .or. dosmoke ) ) then - if(.not.doclubb_tb) then - tmpqcl = cloudliq(i,j,:) ! Liquid updated by CLUBB just prior to this - tmpqv = tmpqv - tmpqcl ! Vapor - tmptabs = tmptabs + fac_cond * tmpqcl ! Update temperature - if(doclubb_gridmean) then - cloud_frac_in(1:nzm) = 0.0 ! to use grid mean for Morrison microphysics, just - ! simply set cloud_frac_in to be zero. - liq_cldfrac(1:nzm) = cloud_frac(i,j,2:nz) - - CF3D(i, j, 1:nzm) = cloud_frac(i, j, 2:nz) - ice_cldfrac(:)= 0.0 - if(doicemicro) then - do k=1, nzm - if(tmpqci(k).gt.1.0e-8) then - ice_cldfrac(k) = 1.0 - end if - if((tmpqcl(k) + tmpqci(k)).gt.1.0e-9) then - CF3D(i,j,k) = (CF3D(i,j,k) * tmpqcl(k) + ice_cldfrac(k) * tmpqci(k)) & - / (tmpqcl(k) + tmpqci(k)) - else - CF3D(i,j,k) = 0.0 - end if - ice_cldfrac(k) = max(CF3D(i,j,k), liq_cldfrac(k)) - end do - endif - end if - else - call satadj_liquid(nzm,tmptabs,tmpqv,tmpqcl,tmppres) - cloudliq(i,j,:) = tmpqcl - cloud_frac_in(1:nzm) = 0.0 - end if - else - call satadj_liquid(nzm,tmptabs,tmpqv,tmpqcl,tmppres) - end if -#else - call satadj_liquid(nzm,tmptabs,tmpqv,tmpqcl,tmppres) -#endif - - -#ifdef ECPP -! save cloud water before microphysics process for the calculation -! of qlsink in ECPP - qcloud_bf(i,j,:) = tmpqcl(:) -#endif /*ECPP*/ - - i1 = 1 ! dummy variables used by WRF convention in subroutine call - i2 = 1 - j1 = 1 - j2 = 1 - -! hm 7/26/11, initialize new output - tmpaut=0. - tmpacc=0. - tmpevpc=0. - tmpevpr=0. - tmpmlt=0. - tmpsub=0. - tmpdep=0. - tmpcon=0. - - mtendqv = 0. - mtendqcl = 0. - mtendqr = 0. - mtendqci = 0. - mtendqs = 0. - mtendqg = 0. - mtendncl = 0. - mtendnr = 0. - mtendnci = 0. - mtendns = 0. - mtendng = 0. - - tmtend1d = 0. - - sfcpcp = 0. - sfcicepcp = 0. - - sfcpcp2D = 0.0 !+++mhwangtest - - effc1d(:) = 10. ! default liquid and ice effective radii - effi1d(:) = 75. - -#ifdef CLUBB_CRM - relvar(:) = 8. - accre_enhan(:) = 1. - if ( doclubb ) then - if ( any( tmpqv < 0. ) ) then - qv_clip(2:nz) = tmpqv(1:nzm) - qv_clip(1) = 0.0_core_rknd - if ( clubb_at_least_debug_level( 1 ) ) then - write(0,*) "M2005 has received a negative water vapor" - end if - call fill_holes_driver( 2, 0._core_rknd, "zt", rho_ds_zt, rho_ds_zm, qv_clip ) - tmpqv = qv_clip(2:nz) - end if - if ( any( tmpqcl < 0. ) ) then - qcl_clip(2:nz) = tmpqcl(1:nzm) - qcl_clip(1) = 0.0_core_rknd - if ( clubb_at_least_debug_level( 1 ) ) then - write(0,*) "M2005 has received a negative liquid water" - end if - call fill_holes_driver( 2, 0._core_rknd, "zt", rho_ds_zt, rho_ds_zm, qcl_clip ) - tmpqcl = qcl_clip(2:nz) - end if - - ! ------------------------------------------------- ! - ! Diagnose relative cloud water variance ! - ! ------------------------------------------------- ! -! relvar(:) = 1.0 ! default -! where (tmpqcl(:) /= 0. .and. qclvar(i,j, :) /= 0.) & -! relvar(:) = min(8.0, max(0.35,tmpqcl(:)**2/qclvar(i,j,:))) -! relvar(:) = min(8.0, max(0.35,tmpqcl(:)**2/qclvar(i,j,:))) - - ! ------------------------------------------------- ! - ! Optional Accretion enhancement factor ! - ! ------------------------------------------------- ! -! accre_enhan(:) = 1.+0.65*(1.0/relvar(:)) - relvar(:) = relvarg(i,j,:) - accre_enhan(:) = accre_enhang(i,j,:) - end if ! doclubb - - ! explanation of variable names: - ! mtend1d: array of 1d profiles of microphysical tendencies (w/o sed.) - ! stend1d: array of 1d profiles of sedimentation tendencies for q* - ! tmp**: on input, current value of **. On output, new value of **. - ! eff*1d: one-dim. profile of effective raduis for * - call m2005micro_graupel(& - mtendqcl,mtendqci,mtendqs,mtendqr, & - mtendncl,mtendnci,mtendns,mtendnr, & - tmpqcl,tmpqci,tmpqs,tmpqr, & - tmpncl,tmpnci,tmpns,tmpnr, & - tmtend1d,mtendqv, & - tmptabs,tmpqv,tmppres,rho,tmpdz,tmpw,tmpwsub, & -! hm 7/26/11, new output - tmpacc,tmpaut,tmpevpc,tmpevpr,tmpmlt, & - tmpsub,tmpdep,tmpcon, & - sfcpcp, sfcicepcp, & - effc1d,effi1d,effs1d,effr1d, & - dtn, & - i1,i2, j1,j2, 1,nzm, i1,i2, j1,j2, 1,nzm, & - mtendqg,mtendng,tmpqg,tmpng,effg1d,stendqg, & - stendqr,stendqci,stendqs,stendqcl,cloud_frac_in, liq_cldfrac, ice_cldfrac, relvar, accre_enhan & ! cloud_frac added by dschanen UWM -#ifdef ECPP - ,C2PREC,QSINK_TMP,CSED,ISED,SSED,GSED,RSED,RH3D & ! mhwang add, for ECPP -#endif - ) - - if ( doclubb ) then - if ( any( tmpqv < 0. ) ) then - qv_clip(2:nz) = tmpqv(1:nzm) - qv_clip(1) = 0.0_core_rknd - if ( clubb_at_least_debug_level( 1 ) ) then - write(0,*) "M2005 has produced a negative water vapor" - end if - call fill_holes_driver( 2, 0._core_rknd, "zt", rho_ds_zt, rho_ds_zm, qv_clip ) - tmpqv = qv_clip(2:nz) - end if - if ( any( tmpqcl < 0. ) ) then - qcl_clip(2:nz) = tmpqcl(1:nzm) - qcl_clip(1) = 0.0_core_rknd - if ( clubb_at_least_debug_level( 1 ) ) then - write(0,*) "M2005 has produced a negative liquid water" - end if - call fill_holes_driver( 2, 0._core_rknd, "zt", rho_ds_zt, rho_ds_zm, qcl_clip ) - tmpqcl = qcl_clip(2:nz) - end if - end if ! doclubb -#else - ! explanation of variable names: - ! mtend1d: array of 1d profiles of microphysical tendencies (w/o sed.) - ! stend1d: array of 1d profiles of sedimentation tendencies for q* - ! tmp**: on input, current value of **. On output, new value of **. - ! eff*1d: one-dim. profile of effective raduis for * - call m2005micro_graupel(& - mtendqcl,mtendqci,mtendqs,mtendqr, & - mtendncl,mtendnci,mtendns,mtendnr, & - tmpqcl,tmpqci,tmpqs,tmpqr, & - tmpncl,tmpnci,tmpns,tmpnr, & - tmtend1d,mtendqv, & - tmptabs,tmpqv,tmppres,rho,tmpdz,tmpw,tmpwsub, & -! hm 7/26/11, new output - tmpacc,tmpaut,tmpevpc,tmpevpr,tmpmlt, & - tmpsub,tmpdep,tmpcon, & - sfcpcp, sfcicepcp, & - effc1d,effi1d,effs1d,effr1d, & - dtn, & - i1,i2, j1,j2, 1,nzm, i1,i2, j1,j2, 1,nzm, & - mtendqg,mtendng,tmpqg,tmpng,effg1d,stendqg, & - stendqr,stendqci,stendqs,stendqcl & -#ifdef ECPP - ,C2PREC,QSINK_TMP,CSED,ISED,SSED,GSED,RSED,RH3D & ! mhwang add, for ECPP -#endif - ) -#endif - -#ifdef CRM -! hm 7/26/11, new output - aut1(i,j,:) = tmpaut(:) - acc1(i,j,:) = tmpacc(:) - evpc1(i,j,:) = tmpevpc(:) - evpr1(i,j,:) = tmpevpr(:) - mlt1(i,j,:) = tmpmlt(:) - sub1(i,j,:) = tmpsub(:) - dep1(i,j,:) = tmpdep(:) - con1(i,j,:) = tmpcon(:) - -! hm 8/31/11, new output for gcm-grid and time-step avg -! rates are summed here over the icycle loop -! note: rates are multiplied by time step, and then -! divided by dt in crm.F90 to get mean rates - aut1a(i,j,:) = aut1a(i,j,:) + aut1(i,j,:)*dtn - acc1a(i,j,:) = acc1a(i,j,:) + acc1(i,j,:)*dtn - evpc1a(i,j,:) = evpc1a(i,j,:) + evpc1(i,j,:)*dtn - evpr1a(i,j,:) = evpr1a(i,j,:) + evpr1(i,j,:)*dtn - mlt1a(i,j,:) = mlt1a(i,j,:) + mlt1(i,j,:)*dtn - sub1a(i,j,:) = sub1a(i,j,:) + sub1(i,j,:)*dtn - dep1a(i,j,:) = dep1a(i,j,:) + dep1(i,j,:)*dtn - con1a(i,j,:) = con1a(i,j,:) + con1(i,j,:)*dtn -#endif - - ! update microphysical quantities in this grid column - if(doprecip) then - total_water_prec = total_water_prec + sfcpcp - - ! take care of surface precipitation - precsfc(i,j) = precsfc(i,j) + sfcpcp/dz - prec_xy(i,j) = prec_xy(i,j) + sfcpcp/dtn/dz -!+++mhwang - sfcpcp2D(i,j) = sfcpcp/dtn/dz -!---mhwang -#ifdef CRM - precssfc(i,j) = precssfc(i,j) + sfcicepcp/dz ! the corect unit of precssfc should be mm/dz +++mhwang -#endif - ! update rain - micro_field(i,j,:,iqr) = tmpqr(:) - micro_field(i,j,:,inr) = tmpnr(:) - else - ! add rain to cloud - tmpqcl(:) = tmpqcl(:) + tmpqr(:) ! add rain mass back to cloud water - tmpncl(:) = tmpncl(:) + tmpnr(:) ! add rain number back to cloud water - - ! zero out rain - tmpqr(:) = 0. - tmpnr(:) = 0. - - ! add rain tendencies to cloud - stendqcl(:) = stendqcl(:) + stendqr(:) - mtendqcl(:) = mtendqcl(:) + mtendqr(:) - mtendncl(:) = mtendncl(:) + mtendnr(:) - - ! zero out rain tendencies - stendqr(:) = 0. - mtendqr(:) = 0. - mtendnr(:) = 0. - end if - - !bloss/qt: update total water and cloud liquid. - ! Note: update of total water moved to after if(doprecip), - ! since no precip moves rain --> cloud liq. - micro_field(i,j,:,iqv) = tmpqv(:) + tmpqcl(:) !bloss/qt: total water - cloudliq(i,j,:) = tmpqcl(:) !bloss/qt: auxilliary cloud liquid water variable - if(dopredictNc) micro_field(i,j,:,incl) = tmpncl(:) - - reffc(i,j,:) = effc1d(:) - - if(doicemicro) then - micro_field(i,j,:,iqci) = tmpqci(:) - micro_field(i,j,:,inci) = tmpnci(:) - micro_field(i,j,:,iqs) = tmpqs(:) - micro_field(i,j,:,ins) = tmpns(:) - if(dograupel) then - micro_field(i,j,:,iqg) = tmpqg(:) - micro_field(i,j,:,ing) = tmpng(:) - end if - reffi(i,j,:) = effi1d(:) - end if - - !===================================================== - ! update liquid-ice static energy due to precipitation - t(i,j,:) = t(i,j,:) & - - dtn*fac_cond*(stendqcl+stendqr) & - - dtn*fac_sub*(stendqci+stendqs+stendqg) - !===================================================== - - if(dostatis) then -!bloss/qt: total water microphysical tendency includes qv and qcl - mtend(:,iqv) = mtend(:,iqv) + mtendqv + mtendqcl -!bloss/qt mtend(:,iqcl) = mtend(:,iqcl) + mtendqcl - if(dopredictNc) mtend(:,incl) = mtend(:,incl) + mtendncl - if(doprecip) then - mtend(:,iqr) = mtend(:,iqr) + mtendqr - mtend(:,inr) = mtend(:,inr) + mtendnr - end if - - if(doicemicro) then - mtend(:,iqci) = mtend(:,iqci) + mtendqci - mtend(:,inci) = mtend(:,inci) + mtendnci - !bloss stend(:,inci) = stend(:,inci) + stendnci - - mtend(:,iqs) = mtend(:,iqs) + mtendqs - mtend(:,ins) = mtend(:,ins) + mtendns - !bloss stend(:,ins) = stend(:,ins) + stendns - - if(dograupel) then - mtend(:,iqg) = mtend(:,iqg) + mtendqg - mtend(:,ing) = mtend(:,ing) + mtendng - !bloss stend(:,ing) = stend(:,ing) + stendng - end if - end if - - do n = 1,nmicro_fields - do k = 1,nzm - if(micro_field(i,j,k,n).ge.1.e-6) mfrac(k,n) = mfrac(k,n)+1. - end do - end do - - ! approximate optical depth = 0.0018*lwp/effrad - ! integrated up to level at which output - tmpc = 0. - tmpr = 0. - tmpi = 0. - tmps = 0. - tmpg = 0. - - do k = 1,nzm - tmpc = tmpc + 0.0018*rho(k)*dz*adz(k)*tmpqcl(k)/(1.e-20+1.e-6*effc1d(k)) - tmpr = tmpr + 0.0018*rho(k)*dz*adz(k)*tmpqr(k)/(1.e-20+1.e-6*effr1d(k)) - !bloss/qt: put cloud liquid optical depth in trtau(:,iqv) - trtau(k,iqv) = trtau(k,iqv) + tmpc - if(doprecip) trtau(k,iqr) = trtau(k,iqr) + tmpr - - if(doicemicro) then - tmpi = tmpi + 0.0018*rho(k)*dz*adz(k)*tmpqci(k)/(1.e-20+1.e-6*effi1d(k)) - tmps = tmps + 0.0018*rho(k)*dz*adz(k)*tmpqs(k)/(1.e-20+1.e-6*effs1d(k)) - tmpg = tmpg + 0.0018*rho(k)*dz*adz(k)*tmpqg(k)/(1.e-20+1.e-6*effg1d(k)) - - trtau(k,iqci) = trtau(k,iqci) + tmpi - trtau(k,iqs) = trtau(k,iqs) + tmps -#ifdef CLUBB_CRM /* Bug fix -dschanen 9 Mar 2012 */ - if ( dograupel ) then - trtau(k,iqg) = trtau(k,iqg) + tmpg - end if -#else - trtau(k,iqg) = trtau(k,iqg) + tmpg -#endif /* CLUBB */ - end if - end do - - tlat(1:nzm) = tlat(1:nzm) & - - dtn*fac_cond*(stendqcl+stendqr) & - - dtn*fac_sub*(stendqci+stendqs+stendqg) - qpfall(1:nzm) = qpfall(1:nzm) + dtn*(stendqr+stendqs+stendqg) - -#ifdef CRM - qpsrc(1:nzm) = qpsrc(1:nzm) + dtn*(mtendqr+mtendqs+mtendqg) - qpevp(1:nzm) = 0.0 -#endif - - !bloss: temperature tendency (sensible heating) due to phase changes - tmtend3d(i,j,1:nzm) = tmtend1d(1:nzm) - - end if ! dostatis - - stend(:,iqv) = stend(:,iqv) + stendqcl !bloss/qt: iqcl --> iqv - if(doprecip) then - stend(:,iqr) = stend(:,iqr) + stendqr - end if - - if(doicemicro) then - stend(:,iqci) = stend(:,iqci) + stendqci - stend(:,iqs) = stend(:,iqs) + stendqs - if(dograupel) stend(:,iqg) = stend(:,iqg) + stendqg - end if - -#ifdef ECPP - do k=1, nzm - qlsink_bf(i,j,k) = min(1.0/dt, QSINK_TMP(k)) ! /s - rh(i,j,k) = RH3D(k) !0-1 - prain(i,j,k) = C2PREC(K) ! kg/kg/s - if(cloudliq(i,j,k).gt.1.0e-10) then - qlsink(i,j,k) = min(1.0/dt, C2PREC(k)/cloudliq(i,j,k)) - else - qlsink(i,j,k) = 0.0 - end if - end do - precr(i,j,:)=(RSED(:)) ! kg/m2/s - precsolid(i,j,:)=(SSED(:)+GSED(:)) !kg/m2/s leave ISED out for the momenent, and we may want to - ! test it effects in the future. +++mhwang -#endif /*ECPP*/ - - end do ! i = 1,nx -end do ! j = 1,ny - -! back sedimentation flux out from sedimentation tendencies -tmpc = 0. -do k = 1,nzm - m = nz-k - tmpc = tmpc + stend(m,iqv)*rho(m)*dz*adz(m) !bloss/qt: iqcl --> iqv - mksed(m,iqv) = tmpc -end do -precflux(1:nzm) = precflux(1:nzm) - mksed(:,iqv)*dtn/dz - -if(doprecip) then - tmpr = 0. - do k = 1,nzm - m = nz-k - tmpr = tmpr + stend(m,iqr)*rho(m)*dz*adz(m) - mksed(m,iqr) = tmpr - end do - precflux(1:nzm) = precflux(1:nzm) - mksed(:,iqr)*dtn/dz -end if - -if(doicemicro) then - tmpi = 0. - tmps = 0. - tmpg = 0. - do k = 1,nzm - m = nz-k - tmpi = tmpi + stend(m,iqci)*rho(m)*dz*adz(m) - tmps = tmps + stend(m,iqs)*rho(m)*dz*adz(m) -#ifdef CLUBB_CRM /* Bug fix -dschanen 9 Mar 2012 */ - if ( dograupel ) then - tmpg = tmpg + stend(m,iqg)*rho(m)*dz*adz(m) - else - tmpg = 0. - end if -#else - tmpg = tmpg + stend(m,iqg)*rho(m)*dz*adz(m) -#endif - mksed(m,iqci) = tmpi - mksed(m,iqs) = tmps -#ifdef CLUBB_CRM /* Bug fix -dschanen 9 Mar 2012 */ - if ( dograupel ) then - mksed(m,iqg) = tmpg - end if -#else - mksed(m,iqg) = tmpg -#endif - end do -#ifdef CLUBB_CRM /* Bug fix -dschanen 9 Mar 2012 */ - if ( dograupel ) then - precflux(1:nzm) = precflux(1:nzm) & - - (mksed(:,iqci) + mksed(:,iqs) + mksed(:,iqg))*dtn/dz - else - precflux(1:nzm) = precflux(1:nzm) & - - (mksed(:,iqci) + mksed(:,iqs))*dtn/dz - end if -#else - precflux(1:nzm) = precflux(1:nzm) & - - (mksed(:,iqci) + mksed(:,iqs) + mksed(:,iqg))*dtn/dz -#endif -end if - -!!$if(doprecip) total_water_prec = total_water_prec - total_water() - -#ifdef CLUBB_CRM -if (docloud.or.doclubb) call micro_diagnose() ! leave this line here -if(doclubb) then - CF3D(1:nx, 1:ny, 1:nzm) = cloud_frac(1:nx, 1:ny, 2:nzm+1) - if(doicemicro) then - do i=1, nx - do j=1, ny - ice_cldfrac(:) = 0.0 - do k=1, nzm -! Ice cloud fraction: 0 at 0 C, and 100% at -35C. -! ice_cldfrac(k) = -(tmptabs(k)-T_freeze_K)/35.0 -! ice_cldfrac(k) = min(1.0, max(ice_cldfrac(k), 0.0)) - if(micro_field(i,j,k,iqci) .gt. 1.0e-8) then - ice_cldfrac(k) = 1.0 - end if - if(cloudliq(i,j,k) + micro_field(i,j,k,iqci) .gt.1.0e-9) then - CF3D(i,j,k) = (CF3D(i,j,k)* cloudliq(i,j,k) + ice_cldfrac(k) * micro_field(i,j,k,iqci)) & - / (cloudliq(i,j,k) + micro_field(i,j,k,iqci)) - else - CF3D(i,j,k) = 0.0 - end if - end do - end do - end do - endif -endif -#else -if (docloud) call micro_diagnose() ! leave this line here -#endif - -! call t_stopf ('micro_proc') - -end subroutine micro_proc - -!---------------------------------------------------------------------- -!!! Diagnose arrays nessesary for dynamical core and radiation: -! -! This is the pace where the microphysics field that SAM actually cares about -! are diagnosed. - -subroutine micro_diagnose() - -use crmx_vars -#ifdef CLUBB_CRM -use crmx_error_code, only: clubb_at_least_debug_level ! Procedure -use crmx_constants_clubb, only: fstderr, zero_threshold -implicit none -#endif - -real omn, omp -integer i,j,k - -! water vapor = total water - cloud liquid -qv(1:nx,1:ny,1:nzm) = micro_field(1:nx,1:ny,1:nzm,iqv) & - - cloudliq(1:nx,1:ny,1:nzm) - -#ifdef CLUBB_CRM -do i = 1, nx - do j = 1, ny - do k = 1, nzm - ! Apply local hole-filling to vapor by converting liquid to vapor. Moist - ! static energy should be conserved, so updating temperature is not - ! needed here. -dschanen 31 August 2011 - if ( qv(i,j,k) < zero_threshold ) then - cloudliq(i,j,k) = cloudliq(i,j,k) + qv(i,j,k) - qv(i,j,k) = zero_threshold - if ( cloudliq(i,j,k) < zero_threshold ) then - if ( clubb_at_least_debug_level( 1 ) ) then - write(fstderr,*) "Total water at", "i =", i, "j =", j, "k =", k, "is negative.", & - "Applying non-conservative hard clipping." - end if - cloudliq(i,j,k) = zero_threshold - end if ! cloud_liq < 0 - end if ! qv < 0 - end do ! 1.. nzm - end do ! 1.. ny -end do ! 1.. nx -#endif /* CLUBB_CRM */ -! cloud liquid water -qcl(1:nx,1:ny,1:nzm) = cloudliq(1:nx,1:ny,1:nzm) - -! rain water -if(doprecip) qpl(1:nx,1:ny,1:nzm) = micro_field(1:nx,1:ny,1:nzm,iqr) - -! cloud ice -if(doicemicro) then - qci(1:nx,1:ny,1:nzm) = micro_field(1:nx,1:ny,1:nzm,iqci) - - if(dograupel) then - qpi(1:nx,1:ny,1:nzm) = micro_field(1:nx,1:ny,1:nzm,iqs) & - + micro_field(1:nx,1:ny,1:nzm,iqg) - else - qpi(1:nx,1:ny,1:nzm) = micro_field(1:nx,1:ny,1:nzm,iqs) - end if -end if - -end subroutine micro_diagnose - -#ifdef CLUBB_CRM -!--------------------------------------------------------------------- -subroutine micro_update() - -! Description: -! This subroutine essentially does what micro_proc does but does not -! call any microphysics subroutines. We need to do this for the -! single-moment bulk microphysics (SAM1MOM) so that CLUBB gets a -! properly updated value of ice fed in. -! -! -dschanen UWM -!--------------------------------------------------------------------- - - ! Update the dynamical core variables (e.g. qv, qcl) with the value in - ! micro_field. Diffusion, advection, and other processes are applied to - ! micro_field but not the variables in vars.f90 - call micro_diagnose() - - return -end subroutine micro_update - -!--------------------------------------------------------------------- -subroutine micro_adjust( new_qv, new_qc ) -! Description: -! Adjust total water in SAM based on values from CLUBB. -! References: -! None -!--------------------------------------------------------------------- - - use crmx_vars, only: qci - - implicit none - - real, dimension(nx,ny,nzm), intent(in) :: & - new_qv, & ! Water vapor mixing ratio that has been adjusted by CLUBB [kg/kg] - new_qc ! Cloud water mixing ratio that has been adjusted by CLUBB [kg/kg] - - ! Total water mixing ratio - micro_field(1:nx,1:ny,1:nzm,iqv) = new_qv(1:nx,1:ny,1:nzm) & - + new_qc(1:nx,1:ny,1:nzm) - - ! Cloud water mixing ratio - cloudliq(1:nx,1:ny,1:nzm) = new_qc(1:nx,1:ny,1:nzm) - - return -end subroutine micro_adjust - -#endif /*CLUBB_CRM*/ - -!---------------------------------------------------------------------- -!!! functions to compute terminal velocity for precipitating variables: -! -! you need supply functions to compute terminal velocity for all of your -! precipitating prognostic variables. Note that all functions should -! compute vertical velocity given two microphysics parameters var1, var2, -! and temperature, and water vapor (single values, not arrays). Var1 and var2 -! are some microphysics variables like water content and concentration. -! Don't change the number of arguments or their meaning! - -!!$real function term_vel_qr(qr,nr,tabs,rho) -!!$! ....... -!!$end function term_vel_qr -!!$ -!!$real function term_vel_Nr(qr,nr,tabs,rho) -!!$! ....... -!!$end function term_vel_Nr -!!$ -!!$real function term_vel_qs(qs,ns,tabs,rho) -!!$! ....... -!!$end function term_vel_qs - -! etc. - -!---------------------------------------------------------------------- -!!! compute sedimentation -! -! The perpose of this subroutine is to prepare variables needed to call -! the precip_all() for each of the falling hydrometeor varibles -subroutine micro_precip_fall() - -! before calling precip_fall() for each of falling prognostic variables, -! you need to set hydro_type and omega(:,:,:) variables. -! hydro_type can have four values: -! 0 - variable is liquid water mixing ratio -! 1 - hydrometeor is ice mixing ratio -! 2 - hydrometeor is mixture-of-liquid-and-ice mixing ratio. (As in original SAM microphysics). -! 3 - variable is not mixing ratio, but, for example, rain drop concentration -! OMEGA(:,:,:) is used only for hydro_type=2, and is the fraction of liquid phase (0-1). -! for hour hypothetical case, there is no mixed hydrometeor, so omega is not actually used. - -integer hydro_type -real omega(nx,ny,nzm) - -integer i,j,k - -return ! do not need this routine -- sedimentation done in m2005micro. - -!!$! Initialize arrays that accumulate surface precipitation flux -!!$ -!!$ if(mod(nstep-1,nstatis).eq.0.and.icycle.eq.1) then -!!$ do j=1,ny -!!$ do i=1,nx -!!$ precsfc(i,j)=0. -!!$ end do -!!$ end do -!!$ do k=1,nzm -!!$ precflux(k) = 0. -!!$ end do -!!$ end if -!!$ -!!$ do k = 1,nzm ! Initialize arrays which hold precipitation fluxes for stats. -!!$ qpfall(k)=0. -!!$ tlat(k) = 0. -!!$ end do -!!$ -!!$! Compute sedimentation of falling variables: -!!$ -!!$ hydro_type=0 -!!$ call precip_fall(qr, term_vel_qr, hydro_type, omega) -!!$ hydro_type=3 -!!$ call precip_fall(Nr, term_vel_Nr, hydro_type, omega) -!!$ hydro_type=1 -!!$ call precip_fall(qs, term_vel_qs, hydro_type, omega) -!!$ hydro_type=3 -!!$ call precip_fall(Ns, term_vel_Ns, hydro_type, omega) -!!$ hydro_type=1 -!!$ call precip_fall(qg, term_vel_qg, hydro_type, omega) -!!$ hydro_type=3 -!!$ call precip_fall(Ng, term_vel_Ng, hydro_type, omega) -!!$ - - -end subroutine micro_precip_fall - -!---------------------------------------------------------------------- -! called when stepout() called - -subroutine micro_print() - implicit none - integer :: k - - ! print out min/max values of all microphysical variables - do k=1,nmicro_fields - call fminmax_print(trim(mkname(k))//':', & - micro_field(:,:,:,k),dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm) - end do - -end subroutine micro_print - -!----------------------------------------- -subroutine satadj_liquid(nzm,tabs,qt,qc,pres) - !bloss/qt: Utility routine based on cloud.f90 in - ! MICRO_SAM1MOM that was written by Marat Khairoutdinov. - ! This routine performs a saturation adjustment for - ! cloud liquid water only using a Newton method. - ! While 20 iterations are allowed, most often this - ! routine should exit in five iterations or less. - ! Only a single calculation of the saturation vapor - ! pressure is required in subsaturated air. - - use crmx_module_mp_GRAUPEL, only: polysvp - use crmx_params, only: cp, lcond, rv, fac_cond - implicit none - - integer, intent(in) :: nzm - real, intent(inout), dimension(nzm) :: tabs ! absolute temperature, K - real, intent(inout), dimension(nzm) :: qt ! on input: qt; on output: qv - real, intent(out), dimension(nzm) :: qc ! cloud liquid water, kg/kg - real, intent(in), dimension(nzm) :: pres ! pressure, Pa - - real tabs1, dtabs, thresh, esat1, qsat1, fff, dfff - integer k, niter - - integer, parameter :: maxiter = 20 - - !bloss/qt: quick saturation adjustment to compute cloud liquid water content. - do k = 1,nzm - tabs1 = tabs(k) - esat1 = polysvp(tabs1,0) - qsat1 = 0.622*esat1/ (pres(k) - esat1) - qc(k) = 0. ! no cloud unless qt > qsat - - if (qt(k).gt.qsat1) then - - ! if unsaturated, nothing to do (i.e., qv=qt, T=Tl) --> just exit. - ! if saturated, do saturation adjustment - ! (modeled after Marat's cloud.f90). - - ! generate initial guess based on above calculation of qsat - dtabs = + fac_cond*MAX(0.,qt(k) - qsat1) & - / ( 1. + lcond**2*qsat1/(cp*rv*tabs1**2) ) - tabs1 = tabs1 + dtabs - niter = 1 - - ! convergence threshold: min of 0.01K and latent heating due to - ! condensation of 1% of saturation mixing ratio. - thresh = MIN(0.01, 0.01*fac_cond*qsat1) - - ! iterate while temperature increment > thresh and niter < maxiter - do while((ABS(dtabs).GT.thresh) .AND. (niter.lt.maxiter)) - - esat1 = polysvp(tabs1,0) - qsat1 = 0.622*esat1/ (pres(k) - esat1) ! saturation mixing ratio - - fff = tabs(k) - tabs1 + fac_cond*MAX(0.,qt(k) - qsat1) - dfff = 1. + lcond**2*qsat1/(cp*rv*tabs1**2) - dtabs = fff/dfff - tabs1 = tabs1 + dtabs - - niter = niter + 1 - - end do - - qc(k) = MAX( 0.,tabs1 - tabs(k) )/fac_cond ! cloud liquid mass mixing ratio - qt(k) = qt(k) - qc(k) ! This now holds the water vapor mass mixing ratio. - tabs(k) = tabs1 ! update temperature. - - if(niter.gt.maxiter-1) write(*,*) 'Reached iteration limit in satadj_liquid' - - end if ! qt_in > qsat - - end do ! k = 1,nzm - -end subroutine satadj_liquid - -!----------------------------------------------------------------------- -! Supply function that computes total water in a domain: -! -real(kind=selected_real_kind(12)) function total_water() - - use crmx_vars, only : nstep,nprint,adz,dz,rho - real(kind=selected_real_kind(12)) tmp - integer i,j,k,m - - total_water = 0. - do m=1,nmicro_fields - if(flag_wmass(m).eq.1) then - do k=1,nzm - tmp = 0. - do j=1,ny - do i=1,nx - tmp = tmp + micro_field(i,j,k,m) - end do - end do - total_water = total_water + tmp*adz(k)*dz*rho(k) - end do - end if - end do - -end function total_water - -function Get_reffc() ! liquid water - real, dimension(nx,ny,nzm) :: Get_reffc - Get_reffc = reffc -end function Get_reffc - -function Get_reffi() ! ice - real, dimension(nx,ny,nzm) :: Get_reffi - Get_reffi = reffi -end function Get_reffi -#ifdef CLUBB_CRM -!------------------------------------------------------------------------------- -ELEMENTAL FUNCTION LIN_INT( var_high, var_low, height_high, height_low, height_int ) - -! 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) - -! Author: Brian Griffin, UW-Milwaukee -! Modifications: Dave Schanen added the elemental attribute 4 Nov 2008 -! References: None - -IMPLICIT NONE - -! Input Variables -REAL, INTENT(IN):: var_high -REAL, INTENT(IN):: var_low -REAL, INTENT(IN):: height_high -REAL, INTENT(IN):: height_low -REAL, INTENT(IN):: height_int - -! Output Variable -REAL:: LIN_INT - -LIN_INT = ( var_high - var_low ) / ( height_high - height_low ) & - * ( height_int - height_low ) + var_low - - -END FUNCTION LIN_INT -#endif /*CLUBB_CRM*/ -!------------------------------------------------------------------------------ - -end module crmx_microphysics - - - diff --git a/src/physics/spcam/crm/MICRO_M2005/crmx_module_mp_graupel.F90 b/src/physics/spcam/crm/MICRO_M2005/crmx_module_mp_graupel.F90 deleted file mode 100644 index fd945c4a89..0000000000 --- a/src/physics/spcam/crm/MICRO_M2005/crmx_module_mp_graupel.F90 +++ /dev/null @@ -1,6884 +0,0 @@ -!WRF:MODEL_LAYER:PHYSICS -!HM: This is version 2 of Hugh Morrison's two moment, five class scheme. -! - -! THIS MODULE CONTAINS THE TWO-MOMENT MICROPHYSICS CODE DESCRIBED BY -! MORRISON ET AL. (2009, MWR) -! recent changes with respect to V1.4 - -! V1.5 -! 1) more pathways to allow hail to form (only affects IHAIL=1 option), from collisions of snow/cloud water -! 2) bug fix to PGAM calculation (multiplication instead of division by air density) - -! V1.6 -! 1) added parameter TMELT for all calculations involving melting point -! 2) replaced hard-wired gas constant for air with parameter value 'R' - -! V1.7 -! 1) modification to minimum mixing ratio in dry conditions, change from 10^-6 to 10^-8 kg/kg -! to improve reflectivity at low mixing ratio amounts -! 2) bug fix to prevent possible division by zero error involving LAMI -! 3) change for liquid saturation vapor pressure, replace old formula with Flatau et al. 1992 - -! V2 -! 1) bug fix to maximum-allowed particle fallspeeds (air density correction factor considered) -! 2) change to comments - -! *** Changes incorporated from WRF: *** -! CHANGES FOR V3.2, RELATIVE TO MOST RECENT (BUG-FIX) CODE FOR V3.1 - -! 1) ADDED ACCELERATED MELTING OF GRAUPEL/SNOW DUE TO COLLISION WITH RAIN, FOLLOWING LIN ET AL. (1983) -! 2) INCREASED MINIMUM LAMBDA FOR RAIN, AND ADDED RAIN DROP BREAKUP FOLLOWING MODIFIED VERSION -! OF VERLINDE AND COTTON (1993) -! 3) CHANGE MINIMUM ALLOWED MIXING RATIOS IN DRY CONDITIONS (RH < 90%), THIS IMPROVES RADAR REFLECTIIVITY -! IN LOW REFLECTIVITY REGIONS -! 4) BUG FIX TO MAXIMUM ALLOWED PARTICLE FALLSPEEDS AS A FUNCTION OF AIR DENSITY -! 5) BUG FIX TO CALCULATION OF LIQUID WATER SATURATION VAPOR PRESSURE (CHANGE IS VERY MINOR) - -! bug fix, 5/12/10 -! 6) bug fix for saturation vapor pressure in low pressure, to avoid division by zero - -! CHANGES FOR V3.3 -! 1) MODIFY FALLSPEED BELOW THE LOWEST LEVEL OF PRECIPITATION, WHICH PREVENTS -! POTENTIAL FOR SPURIOUS ACCUMULATION OF PRECIPITATION DURING SUB-STEPPING FOR SEDIMENTATION -! 2) BUG FIX TO LATENT HEAT RELEASE DUE TO COLLISIONS OF CLOUD ICE WITH RAIN -! 3) CLEAN UP OF COMMENTS IN THE CODE -! additional minor bug fixes and small changes, 5/30/2011 (CLUBB/SAM-CLUBB as of 5 Oct 2011) -! minor revisions by A. Ackerman April 2011: -! 1) replaced kinematic with dynamic viscosity -! 2) replaced scaling by air density for cloud droplet sedimentation -! with viscosity-dependent Stokes expression -! 3) use Ikawa and Saito (1991) air-density scaling for cloud ice -! 4) corrected typo in 2nd digit of ventilation constant F2R - -! Additional fixes -! 5) TEMPERATURE FOR ACCELERATED MELTING DUE TO COLLIIONS OF SNOW AND GRAUPEL -! WITH RAIN SHOULD USE CELSIUS, NOT KELVIN (BUG REPORTED BY K. VAN WEVERBERG) -! 6) NPRACS IS NO SUBTRACTED SUBTRACTED FROM SNOW NUMBER CONCENTRATION, SINCE -! DECREASE IN SNOW NUMBER IS ALREADY ACCOUNTED FOR BY NSMLTS -! 7) MODIFY FALLSPEED BELOW THE LOWEST LEVEL OF PRECIPITATION, WHICH PREVENTS -! POTENTIAL FOR SPURIOUS ACCUMULATION OF PRECIPITATION DURING SUB-STEPPING FOR SEDIMENTATION -! 8) BUG FIX TO LATENT HEAT RELEASE DUE TO COLLISIONS OF CLOUD ICE WITH RAIN -! 9) BUG FIX TO IGRAUP SWITCH FOR NO GRAUPEL/HAIL - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING -! RATIOS AND NUMBER CONCENTRATIONS OF FIVE HYDROMETEOR SPECIES: -! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL. - -MODULE crmx_module_mp_GRAUPEL -!bloss USE module_wrf_error -!bloss USE module_utility, ONLY: WRFU_Clock, WRFU_Alarm ! GT -!bloss USE module_domain, ONLY : HISTORY_ALARM, Is_alarm_tstep ! GT - -! USE module_state_description -#ifdef CLUBB_CRM - use crmx_constants_clubb, only: Lv, Ls, Cp, Rv, Rd, T_freeze_K, rho_lw, grav, EP_2 => ep -#else - ! parameters from SAM and options from wrapper routine. - use crmx_params, only: lcond, lsub, cp, rgas, rv -#endif /*CLUBB_CRM*/ - -#if (defined CRM && defined MODAL_AERO) - use crmx_drop_activation, only: drop_activation_ghan - use cam_abortutils, only: endrun -#endif - - IMPLICIT NONE - -! Adding coefficient term for clex9_oct14 case. This will reduce NNUCCD and NNUCCC -! by some factor to allow cloud to persist at realistic time intervals. - -#ifdef CLUBB_CRM -! REAL, SAVE :: NNUCCD_REDUCE_COEF = 1.0, NNUCCC_REDUCE_COEF = 1.0 - REAL, SAVE :: NNUCCD_REDUCE_COEF = 1.0, NNUCCC_REDUCE_COEF = 1.0e-2 -#endif - -! Change by Marc Pilon on 11/16/11 - - - REAL, PARAMETER :: PI = 3.1415926535897932384626434 - REAL, PARAMETER :: SQRTPI = 0.9189385332046727417803297 - - PUBLIC :: MP_GRAUPEL - PUBLIC :: POLYSVP - - PRIVATE :: GAMMA, DERF1 - PRIVATE :: PI, SQRTPI - PUBLIC :: M2005MICRO_GRAUPEL !bloss - - !bloss: added options that may be set in prm file namelist - ! -- initialized in micrphysics.f90 - logical, public :: & - doicemicro, & ! use ice species (snow/cloud ice/graupel) - dograupel, & ! use graupel - dohail, & ! make graupel species have properties of hail - dosb_warm_rain, & ! use Seifert & Beheng (2001) warm rain parameterization - dopredictNc, & ! prediction of cloud droplet number - dosubgridw, & ! input estimate of subgrid w to microphysics - doarcticicenucl, & ! use arctic parameter values for ice nucleation - docloudedgeactivation,& ! activate cloud droplets throughout the cloud - dofix_pgam ! option to fix value of pgam (exponent in cloud water gamma distn) - -#ifdef CLUBB_CRM - logical, public :: doclubb_tb ! use clubb as a turbulence scheme only +++mhwang - ! so liquid water is diagnosed based on saturaiton adjustment - logical, public :: doclubb_gridmean ! if .true., grid-mean values from CLUBB feeds into - ! Morrison microphysics - logical, public :: doclubb_autoin ! in-cloud values for autoconversion -#endif - - integer, public :: & - aerosol_mode ! determines aerosol mode used - ! 0 = no aerosol mode - ! 1 = power-law - ! 2 = lognormal -#if (defined CRM && defined MODAL_AERO) - logical, public :: domodal_aero ! use modal aerosol from the CAM -#endif - - real, public :: & - Nc0, & ! specified cloud droplet number conc (#/cm3) - ccnconst, ccnexpnt, & ! dospecifyaerosol=.false. params (powerlaw CCN) - aer_rm1, aer_rm2, & ! two modes of aerosol for dospecifyaer...=.true. - aer_n1, aer_n2, & ! rm=geom mean radius (um), n=aer conc. (#/cm3) - aer_sig1, aer_sig2, & ! sig=geom standard deviation of aer size distn. - pgam_fixed ! fixed value of pgam used if dofix_pgam=.true. - -! SWITCHES FOR MICROPHYSICS SCHEME -! IACT = 1, USE POWER-LAW CCN SPECTRA, NCCN = CS^K -! IACT = 2, USE LOGNORMAL AEROSOL SIZE DIST TO DERIVE CCN SPECTRA -! There's no IACT = 3 in SAM / SAM-CLUBB as per WRF -#if (defined CRM && defined MODAL_AERO) -! IACT = 3, USE MULTIMODE AEROSOL SIZE DIST to DERIVER CCN SPECTRA -#endif - - INTEGER, PRIVATE :: IACT - -! INUM = 0, PREDICT DROPLET CONCENTRATION -! INUM = 1, ASSUME CONSTANT DROPLET CONCENTRATION - - INTEGER, PRIVATE :: INUM - -! FOR INUM = 1, SET CONSTANT DROPLET CONCENTRATION (CM-3) - REAL, PRIVATE :: NDCNST - -! SWITCH FOR LIQUID-ONLY RUN -! ILIQ = 0, INCLUDE ICE -! ILIQ = 1, LIQUID ONLY, NO ICE - - INTEGER, PRIVATE :: ILIQ - -! SWITCH FOR ICE NUCLEATION -! INUC = 0, USE FORMULA FROM RASMUSSEN ET AL. 2002 (MID-LATITUDE) -! = 1, USE MPACE OBSERVATIONS - - INTEGER, PRIVATE :: INUC - -! IBASE = 1, NEGLECT DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO -! UNRESOLVED ENTRAINMENT AND MIXING, ACTIVATE -! AT CLOUD BASE OR IN REGION WITH LITTLE CLOUD WATER USING -! NON-EQULIBRIUM SUPERSATURATION, -! IN CLOUD INTERIOR ACTIVATE USING EQUILIBRIUM SUPERSATURATION -! IBASE = 2, ASSUME DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO -! UNRESOLVED ENTRAINMENT AND MIXING DOMINATES, -! ACTIVATE DROPLETS EVERYWHERE IN THE CLOUD USING NON-EQUILIBRIUM -! SUPERSATURATION, BASED ON THE -! LOCAL SUB-GRID AND/OR GRID-SCALE VERTICAL VELOCITY -! AT THE GRID POINT - -! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0) - - INTEGER, PRIVATE :: IBASE - -! INCLUDE SUB-GRID VERTICAL VELOCITY IN DROPLET ACTIVATION -! ISUB = 0, INCLUDE SUB-GRID W (RECOMMENDED FOR LOWER RESOLUTION) -! ISUB = 1, EXCLUDE SUB-GRID W, ONLY USE GRID-SCALE W - - INTEGER, PRIVATE :: ISUB - -! SWITCH FOR GRAUPEL/NO GRAUPEL -! IGRAUP = 0, INCLUDE GRAUPEL -! IGRAUP = 1, NO GRAUPEL - - INTEGER, PRIVATE :: IGRAUP - -! HM ADDED NEW OPTION FOR HAIL V1.3 -! SWITCH FOR HAIL/GRAUPEL -! IHAIL = 0, DENSE PRECIPITATING ICE IS GRAUPEL -! IHAIL = 1, DENSE PRECIPITATING GICE IS HAIL - - INTEGER, PRIVATE :: IHAIL - -! HM ADDED 8/1/08, v1.4 -! SWITCH FOR WARM RAIN SCHEME -! IRAIN = 0, WARM RAIN (AUTO, ACC, SELF-COLL) FROM KHAIROUTIDNOV AND KOGAN (2000) -! IRAIN = 1, WARM RAIN (AUTO, ACC, SELF-COLL) FROM SEIFERT AND BEHENG (2001) - - INTEGER, PRIVATE :: IRAIN - -! PB ADDED 4/13/09 -! SWITCH TO TURN ON/OFF CLOUD LIQUID WATER SATURATION ADJUSTMENT -! WHEN USING TOTAL WATER FORMULATION IN SAM, THE SATURATION -! ADJUSTMENT IS PERFORMED BEFORE CALLING M2005MICRO_GRAUPEL. -! THIS OPTION ALLOWS US TO AVOID PERFORMING IT IN M2005MICRO_GRAUPEL -! UNDER THE THEORY THAT THE OTHER MICROPHYSICAL PROCESSES WILL NOT -! DRIVE IT FAR FROM SATURATION. -! ISATADJ = 0, SATURATION ADJUSTMENT PEROFORMED IN M2005MICRO_GRAUPEL -! ISATADJ = 1, SATURATION ADJUSTMENT _NOT_ PEROFORMED IN M2005MICRO_GRAUPEL - - INTEGER, PRIVATE :: ISATADJ - -! CLOUD MICROPHYSICS CONSTANTS - - REAL, PRIVATE :: AI,AC,AS,AR,AG ! 'A' PARAMETER IN FALLSPEED-DIAM RELATIONSHIP - REAL, PRIVATE :: BI,BC,BS,BR,BG ! 'B' PARAMETER IN FALLSPEED-DIAM RELATIONSHIP - REAL, PRIVATE :: R ! GAS CONSTANT FOR AIR -!bloss REAL, PRIVATE :: RV ! GAS CONSTANT FOR WATER VAPOR -!bloss REAL, PRIVATE :: CP ! SPECIFIC HEAT AT CONSTANT PRESSURE FOR DRY AIR - REAL, PRIVATE :: RHOSU ! STANDARD AIR DENSITY AT 850 MB - REAL, PRIVATE :: RHOW ! DENSITY OF LIQUID WATER - REAL, PRIVATE :: RHOI ! BULK DENSITY OF CLOUD ICE - REAL, PRIVATE :: RHOSN ! BULK DENSITY OF SNOW - REAL, PRIVATE :: RHOG ! BULK DENSITY OF GRAUPEL - REAL, PRIVATE :: AIMM ! PARAMETER IN BIGG IMMERSION FREEZING - REAL, PRIVATE :: BIMM ! PARAMETER IN BIGG IMMERSION FREEZING - REAL, PRIVATE :: ECR ! COLLECTION EFFICIENCY BETWEEN DROPLETS/RAIN AND SNOW/RAIN - REAL, PRIVATE :: DCS ! THRESHOLD SIZE FOR CLOUD ICE AUTOCONVERSION - REAL, PRIVATE :: MI0 ! INITIAL SIZE OF NUCLEATED CRYSTAL - REAL, PRIVATE :: MG0 ! MASS OF EMBRYO GRAUPEL - REAL, PRIVATE :: F1S ! VENTILATION PARAMETER FOR SNOW - REAL, PRIVATE :: F2S ! VENTILATION PARAMETER FOR SNOW - REAL, PRIVATE :: F1R ! VENTILATION PARAMETER FOR RAIN - REAL, PRIVATE :: F2R ! VENTILATION PARAMETER FOR RAIN - REAL, PRIVATE :: G ! GRAVITATIONAL ACCELERATION - REAL, PRIVATE :: QSMALL ! SMALLEST ALLOWED HYDROMETEOR MIXING RATIO - REAL, PRIVATE :: CI,DI,CS,DS,CG,DG ! SIZE DISTRIBUTION PARAMETERS FOR CLOUD ICE, SNOW, GRAUPEL - REAL, PRIVATE :: EII ! COLLECTION EFFICIENCY, ICE-ICE COLLISIONS - REAL, PRIVATE :: ECI ! COLLECTION EFFICIENCY, ICE-DROPLET COLLISIONS - REAL, PRIVATE :: RIN ! RADIUS OF CONTACT NUCLEI (M) -! V1.6 - REAL, PRIVATE :: TMELT ! melting temp (K) -! hm, add for V2.1 - REAL, PRIVATE :: CPW ! SPECIFIC HEAT OF LIQUID WATER - -! CCN SPECTRA FOR IACT = 1 - - REAL, PRIVATE :: C1 ! 'C' IN NCCN = CS^K (CM-3) - REAL, PRIVATE :: K1 ! 'K' IN NCCN = CS^K - -! AEROSOL PARAMETERS FOR IACT = 2 - - REAL, PRIVATE :: MW ! MOLECULAR WEIGHT WATER (KG/MOL) - REAL, PRIVATE :: OSM ! OSMOTIC COEFFICIENT - REAL, PRIVATE :: VI ! NUMBER OF ION DISSOCIATED IN SOLUTION - REAL, PRIVATE :: EPSM ! AEROSOL SOLUBLE FRACTION - REAL, PRIVATE :: RHOA ! AEROSOL BULK DENSITY (KG/M3) - REAL, PRIVATE :: MAP ! MOLECULAR WEIGHT AEROSOL (KG/MOL) - REAL, PRIVATE :: MA ! MOLECULAR WEIGHT OF 'AIR' (KG/MOL) - REAL, PRIVATE :: RR ! UNIVERSAL GAS CONSTANT - REAL, PRIVATE :: BACT ! ACTIVATION PARAMETER - REAL, PRIVATE :: RM1 ! GEOMETRIC MEAN RADIUS, MODE 1 (M) - REAL, PRIVATE :: RM2 ! GEOMETRIC MEAN RADIUS, MODE 2 (M) - REAL, PRIVATE :: NANEW1 ! TOTAL AEROSOL CONCENTRATION, MODE 1 (M^-3) - REAL, PRIVATE :: NANEW2 ! TOTAL AEROSOL CONCENTRATION, MODE 2 (M^-3) - REAL, PRIVATE :: SIG1 ! STANDARD DEVIATION OF AEROSOL S.D., MODE 1 - REAL, PRIVATE :: SIG2 ! STANDARD DEVIATION OF AEROSOL S.D., MODE 2 - REAL, PRIVATE :: F11 ! CORRECTION FACTOR FOR ACTIVATION, MODE 1 - REAL, PRIVATE :: F12 ! CORRECTION FACTOR FOR ACTIVATION, MODE 1 - REAL, PRIVATE :: F21 ! CORRECTION FACTOR FOR ACTIVATION, MODE 2 - REAL, PRIVATE :: F22 ! CORRECTION FACTOR FOR ACTIVATION, MODE 2 - REAL, PRIVATE :: MMULT ! MASS OF SPLINTERED ICE PARTICLE - REAL, PRIVATE :: LAMMAXI,LAMMINI,LAMMAXR,LAMMINR,LAMMAXS,LAMMINS,LAMMAXG,LAMMING - -! CONSTANTS TO IMPROVE EFFICIENCY - - REAL, PRIVATE :: CONS1,CONS2,CONS3,CONS4,CONS5,CONS6,CONS7,CONS8,CONS9,CONS10 - REAL, PRIVATE :: CONS11,CONS12,CONS13,CONS14,CONS15,CONS16,CONS17,CONS18,CONS19,CONS20 - REAL, PRIVATE :: CONS21,CONS22,CONS23,CONS24,CONS25,CONS26,CONS27,CONS28,CONS29,CONS30 - REAL, PRIVATE :: CONS31,CONS32,CONS33,CONS34,CONS35,CONS36,CONS37,CONS38,CONS39,CONS40 - REAL, PRIVATE :: CONS41 - -! v1.4 - REAL, PRIVATE :: dnu(16) - -!..Various radar related variables, from GT - -!..Lookup table dimensions - INTEGER, PARAMETER, PRIVATE:: nbins = 100 - INTEGER, PARAMETER, PRIVATE:: nbr = nbins - INTEGER, PARAMETER, PRIVATE:: nbs = nbins - INTEGER, PARAMETER, PRIVATE:: nbg = nbins - REAL(kind=selected_real_kind(12)), DIMENSION(nbins+1):: ddx - REAL(kind=selected_real_kind(12)), DIMENSION(nbr):: Dr, dtr - REAL(kind=selected_real_kind(12)), DIMENSION(nbs):: Dds, dts - REAL(kind=selected_real_kind(12)), DIMENSION(nbg):: Ddg, dtg - REAL(kind=selected_real_kind(12)), PARAMETER, PRIVATE:: lamda_radar = 0.10 ! in meters - REAL(kind=selected_real_kind(12)), PRIVATE:: K_w, PI5, lamda4 - COMPLEX*16, PRIVATE:: m_w_0, m_i_0 - REAL(kind=selected_real_kind(12)), DIMENSION(nbins+1), PRIVATE:: simpson - REAL(kind=selected_real_kind(12)), DIMENSION(3), PARAMETER, PRIVATE:: basis = & - (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/) - - INTEGER, PARAMETER, PRIVATE:: slen = 20 - CHARACTER(len=slen), PRIVATE:: & - mixingrulestring_s, matrixstring_s, inclusionstring_s, & - hoststring_s, hostmatrixstring_s, hostinclusionstring_s, & - mixingrulestring_g, matrixstring_g, inclusionstring_g, & - hoststring_g, hostmatrixstring_g, hostinclusionstring_g - - REAL, PARAMETER, PRIVATE:: D0r = 50.E-6 - REAL, PARAMETER, PRIVATE:: D0s = 100.E-6 - REAL, PARAMETER, PRIVATE:: D0g = 100.E-6 - CHARACTER*256:: mp_debug -#ifdef CLUBB_CRM - REAL, PARAMETER, PUBLIC :: cloud_frac_thresh = 0.005 -#endif /* CLUBB_CRM */ - -CONTAINS - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE GRAUPEL_INIT -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! THIS SUBROUTINE INITIALIZES ALL PHYSICAL CONSTANTS AMND PARAMETERS -! NEEDED BY THE MICROPHYSICS SCHEME. -! NEEDS TO BE CALLED AT FIRST TIME STEP, PRIOR TO CALL TO MAIN MICROPHYSICS INTERFACE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - IMPLICIT NONE - - integer n,i - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! THE FOLLOWING PARAMETERS ARE USER-DEFINED SWITCHES AND NEED TO BE -! SET PRIOR TO CODE COMPILATION - -! INUM = 0, PREDICT DROPLET CONCENTRATION -! INUM = 1, ASSUME CONSTANT DROPLET CONCENTRATION - - INUM = 1 !bloss: use flag in prm file - if(dopredictNc) then - INUM = 0 - end if - -! FOR INUM = 1, SET CONSTANT DROPLET CONCENTRATION (UNITS OF CM-3) - - NDCNST = Nc0 !bloss: use value from prm file (default=100.) - -! IACT = 1, USE POWER-LAW CCN SPECTRA, NCCN = CS^K -! IACT = 2, USE LOGNORMAL AEROSOL SIZE DIST TO DERIVE CCN SPECTRA -! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0) -#if (defined CRM && defined MODAL_AERO) -! IACT = 3, USE MULTIMODE AEROSOL SIZE DIST to DERIVER CCN SPECTRA -#endif - - if( aerosol_mode == 2 ) then !bloss: specify using flag from prm file -#if (defined CRM && defined MODAL_AERO) - if(domodal_aero) then - IACT = 3 - else -#endif - IACT = 2 -#if (defined CRM && defined MODAL_AERO) - endif -#endif - else if( aerosol_mode == 1 ) then - IACT = 1 - else - IACT = 0 - end if - -! IBASE = 1, NEGLECT DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO -! UNRESOLVED ENTRAINMENT AND MIXING, ACTIVATE -! AT CLOUD BASE OR IN REGION WITH LITTLE CLOUD WATER USING -! NON-EQULIBRIUM SUPERSATURATION ASSUMING NO INITIAL CLOUD WATER, -! IN CLOUD INTERIOR ACTIVATE USING EQUILIBRIUM SUPERSATURATION -! IBASE = 2, ASSUME DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO -! UNRESOLVED ENTRAINMENT AND MIXING DOMINATES, -! ACTIVATE DROPLETS EVERYWHERE IN THE CLOUD USING NON-EQUILIBRIUM -! SUPERSATURATION ASSUMING NO INITIAL CLOUD WATER, BASED ON THE -! LOCAL SUB-GRID AND/OR GRID-SCALE VERTICAL VELOCITY -! AT THE GRID POINT - -! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0) - - if(docloudedgeactivation) then - IBASE = 2 - else - IBASE = 1 - end if - -! INCLUDE SUB-GRID VERTICAL VELOCITY IN DROPLET ACTIVATION -! ISUB = 0, INCLUDE SUB-GRID W (RECOMMENDED FOR LOWER RESOLUTION) -! ISUB = 1, EXCLUDE SUB-GRID W, ONLY USE GRID-SCALE W - -! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0) - - if(dosubgridw) then - ISUB = 0 - else - ISUB = 1 - end if - -! SWITCH FOR LIQUID-ONLY RUN -! ILIQ = 0, INCLUDE ICE -! ILIQ = 1, LIQUID ONLY, NO ICE - - if(doicemicro) then !bloss: specify using flag from prm file - ILIQ = 0 - else - ILIQ = 1 - end if - -! SWITCH FOR ICE NUCLEATION -! INUC = 0, USE FORMULA FROM RASMUSSEN ET AL. 2002 (MID-LATITUDE) -! = 1, USE MPACE OBSERVATIONS (ARCTIC ONLY) - - if(doarcticicenucl) then !bloss: specify using flag from prm file - INUC = 1 - else - INUC = 0 - end if - -! SWITCH FOR GRAUPEL/NO GRAUPEL -! IGRAUP = 0, INCLUDE GRAUPEL -! IGRAUP = 1, NO GRAUPEL - - if(dograupel) then - IGRAUP = 0 - else - IGRAUP = 1 - end if - -! HM ADDED 11/7/07, V1.3 -! SWITCH FOR HAIL/GRAUPEL -! IHAIL = 0, DENSE PRECIPITATING ICE IS GRAUPEL -! IHAIL = 1, DENSE PRECIPITATING ICE IS HAIL - - if(dohail) then - IHAIL = 1 - else - IHAIL = 0 - end if - -! HM ADDED 8/1/08, v1.4 -! SWITCH FOR WARM RAIN SCHEME -! IRAIN = 0, WARM RAIN (AUTO, ACC, SELF-COLL) FROM KHAIROUTIDNOV AND KOGAN (2000) -! IRAIN = 1, WARM RAIN (AUTO, ACC, SELF-COLL) FROM SEIFERT AND BEHENG (2001) - - if(dosb_warm_rain) then - IRAIN = 1 - else - IRAIN = 0 - end if - -! PB ADDED 4/13/09. TURN OFF SATURATION ADJUSTMENT WITHIN M2005MICRO_GRAUPEL -! IN TOTAL WATER VERSION. IT NOW TAKES PLACE BEFORE M2005MICRO_GRAUPEL IS CALLED. - -#ifdef CLUBB_CRM -! ISATADJ = 0 ! Enable for CLUBB - ISATADJ = 1 ! When CLUBB is called, saturation adjustment is done in CLUBB, - ! so should we set ISATADJ=1 here? test by Minghuai Wang +++mhwang -#else - ISATADJ = 1 -#endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! SET PHYSICAL CONSTANTS - -! FALLSPEED PARAMETERS (V=AD^B) - AI = 700. - AC = 3.E7 - AS = 11.72 - AR = 841.99667 - BI = 1. - BC = 2. - BS = 0.41 - BR = 0.8 -! V1.3 - IF (IHAIL.EQ.0) THEN - AG = 19.3 - BG = 0.37 - ELSE ! (MATSUN AND HUGGINS 1980) - AG = 114.5 - BG = 0.5 - END IF - -#ifdef CLUBB_CRM - ! Use CLUBB values for constants - R = Rd - RHOW = rho_lw - TMELT = T_freeze_K - RHOSU = 85000./(R*TMELT) -#else -! CONSTANTS AND PARAMETERS - !bloss: use values from params module - R = rgas -!bloss R = 287.15 -!bloss RV = 465.5 -!bloss CP = 1005. -! V1.6 - TMELT = 273.15 -#endif -! V1.6 - RHOSU = 85000./(R*TMELT) - RHOW = 997. - RHOI = 500. - RHOSN = 100. -! V1.3 - IF (IHAIL.EQ.0) THEN - RHOG = 400. - ELSE - RHOG = 900. - END IF - AIMM = 0.66 - BIMM = 100. - ECR = 1. - DCS = 125.E-6 - MI0 = 4./3.*PI*RHOI*(10.E-6)**3 - MG0 = 1.6E-10 - F1S = 0.86 - F2S = 0.28 - F1R = 0.78 -! V3 5/27/11 -! F2R = 0.32 -! AA revision 4/1/11 - F2R = 0.308 - -#ifdef CLUBB_CRM - G = grav - ! Should this be set to SAM's ggr if CLUBB is not defined? -#else - G = 9.806 -#endif - QSMALL = 1.E-14 - EII = 0.1 - ECI = 0.7 -! HM, ADD FOR V3.2 - CPW = 4218. - -! SIZE DISTRIBUTION PARAMETERS - - CI = RHOI*PI/6. - DI = 3. - CS = RHOSN*PI/6. - DS = 3. - CG = RHOG*PI/6. - DG = 3. - -! RADIUS OF CONTACT NUCLEI - RIN = 0.1E-6 - - MMULT = 4./3.*PI*RHOI*(5.E-6)**3 - -! SIZE LIMITS FOR LAMBDA - - LAMMAXI = 1./1.E-6 - LAMMINI = 1./(2.*DCS+100.E-6) - LAMMAXR = 1./20.E-6 -! LAMMINR = 1./500.E-6 - LAMMINR = 1./2800.E-6 - LAMMAXS = 1./10.E-6 - LAMMINS = 1./2000.E-6 - LAMMAXG = 1./20.E-6 - LAMMING = 1./2000.E-6 - -! CCN SPECTRA FOR IACT = 1 - -! MARITIME -! MODIFIED FROM RASMUSSEN ET AL. 2002 -! NCCN = C*S^K, NCCN IS IN CM-3, S IS SUPERSATURATION RATIO IN % - - K1 = ccnexpnt !bloss: specify using values from prm file - C1 = ccnconst !bloss - -!bloss K1 = 0.4 -!bloss C1 = 120. - -! CONTINENTAL - -! K1 = 0.5 -! C1 = 1000. - -! AEROSOL ACTIVATION PARAMETERS FOR IACT = 2 -! PARAMETERS CURRENTLY SET FOR AMMONIUM SULFATE - - MW = 0.018 - OSM = 1. - VI = 3. - EPSM = 0.7 - RHOA = 1777. - MAP = 0.132 - MA = 0.0284 - RR = 8.3187 - BACT = VI*OSM*EPSM*MW*RHOA/(MAP*RHOW) - -! AEROSOL SIZE DISTRIBUTION PARAMETERS CURRENTLY SET FOR MPACE -! (see morrison et al. 2007, JGR) -! MODE 1 - - RM1 = aer_rm1 !bloss: specify using values from prm file - SIG1 = aer_sig1 - NANEW1 = aer_n1 -!bloss RM1 = 0.052E-6 -!bloss SIG1 = 2.04 -!bloss NANEW1 = 100.0E6 - F11 = 0.5*EXP(2.5*(LOG(SIG1))**2) - F21 = 1.+0.25*LOG(SIG1) - -! MODE 2 - - RM2 = aer_rm2 !bloss: specify using values from prm file - SIG2 = aer_sig2 - NANEW2 = aer_n2 -!bloss RM2 = 1.3E-6 -!bloss SIG2 = 2.5 -!bloss NANEW2 = 1.E6 - F12 = 0.5*EXP(2.5*(LOG(SIG2))**2) - F22 = 1.+0.25*LOG(SIG2) - -! CONSTANTS FOR EFFICIENCY - - CONS1=GAMMA(1.+DS)*CS - CONS2=GAMMA(1.+DG)*CG - CONS3=GAMMA(4.+BS)/6. - CONS4=GAMMA(4.+BR)/6. - CONS5=GAMMA(1.+BS) - CONS6=GAMMA(1.+BR) - CONS7=GAMMA(4.+BG)/6. - CONS8=GAMMA(1.+BG) - CONS9=GAMMA(5./2.+BR/2.) - CONS10=GAMMA(5./2.+BS/2.) - CONS11=GAMMA(5./2.+BG/2.) - CONS12=GAMMA(1.+DI)*CI - CONS13=GAMMA(BS+3.)*PI/4.*ECI - CONS14=GAMMA(BG+3.)*PI/4.*ECI - CONS15=-1108.*EII*PI**((1.-BS)/3.)*RHOSN**((-2.-BS)/3.)/(4.*720.) - CONS16=GAMMA(BI+3.)*PI/4.*ECI - CONS17=4.*2.*3.*RHOSU*PI*ECI*ECI*GAMMA(2.*BS+2.)/(8.*(RHOG-RHOSN)) - CONS18=RHOSN*RHOSN - CONS19=RHOW*RHOW - CONS20=20.*PI*PI*RHOW*BIMM - CONS21=4./(DCS*RHOI) - CONS22=PI*RHOI*DCS**3/6. - CONS23=PI/4.*EII*GAMMA(BS+3.) - CONS24=PI/4.*ECR*GAMMA(BR+3.) - CONS25=PI*PI/24.*RHOW*ECR*GAMMA(BR+6.) - CONS26=PI/6.*RHOW - CONS27=GAMMA(1.+BI) - CONS28=GAMMA(4.+BI)/6. - CONS29=4./3.*PI*RHOW*(25.E-6)**3 - CONS30=4./3.*PI*RHOW - CONS31=PI*PI*ECR*RHOSN - CONS32=PI/2.*ECR - CONS33=PI*PI*ECR*RHOG - CONS34=5./2.+BR/2. - CONS35=5./2.+BS/2. - CONS36=5./2.+BG/2. - CONS37=4.*PI*1.38E-23/(6.*PI*RIN) - CONS38=PI*PI/3.*RHOW - CONS39=PI*PI/36.*RHOW*BIMM - CONS40=PI/6.*BIMM - CONS41=PI*PI*ECR*RHOW - -! v1.4 - dnu(1) = -0.557 - dnu(2) = -0.557 - dnu(3) = -0.430 - dnu(4) = -0.307 - dnu(5) = -0.186 - dnu(6) = -0.067 - dnu(7) = 0.050 - dnu(8) = 0.167 - dnu(9) = 0.282 - dnu(10) = 0.397 - dnu(11) = 0.512 - dnu(12) = 0.626 - dnu(13) = 0.739 - dnu(14) = 0.853 - dnu(15) = 0.966 - dnu(16) = 0.966 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! variables for radar reflecitivity calculations -!..Create bins of rain (from min diameter up to 5 mm). - ddx(1) = D0r*1.0d0 - ddx(nbr+1) = 0.005d0 - do n = 2, nbr - ddx(n) = DEXP(REAL(n-1,kind=kind(0d0))/REAL(nbr,kind=kind(0d0)) & - *DLOG(ddx(nbr+1)/ddx(1)) +DLOG(ddx(1))) - enddo - do n = 1, nbr - Dr(n) = DSQRT(ddx(n)*ddx(n+1)) - dtr(n) = ddx(n+1) - ddx(n) - enddo - -!..Create bins of snow (from min diameter up to 2 cm). - Ddx(1) = D0s*1.0d0 - Ddx(nbs+1) = 0.02d0 - do n = 2, nbs - Ddx(n) = DEXP(REAL(n-1,kind=kind(0d0))/REAL(nbs,kind=kind(0d0)) & - *DLOG(Ddx(nbs+1)/Ddx(1)) +DLOG(Ddx(1))) - enddo - do n = 1, nbs - Dds(n) = DSQRT(Ddx(n)*Ddx(n+1)) - dts(n) = Ddx(n+1) - Ddx(n) - enddo - -!..Create bins of graupel (from min diameter up to 5 cm). - Ddx(1) = D0g*1.0d0 - Ddx(nbg+1) = 0.05d0 - do n = 2, nbg - Ddx(n) = DEXP(REAL(n-1,kind=kind(0d0))/REAL(nbg,kind=kind(0d0)) & - *DLOG(Ddx(nbg+1)/Ddx(1)) +DLOG(Ddx(1))) - enddo - do n = 1, nbg - Ddg(n) = DSQRT(Ddx(n)*Ddx(n+1)) - dtg(n) = Ddx(n+1) - Ddx(n) - enddo - - do i = 1, 256 - mp_debug(i:i) = char(0) - enddo - - call radar_init -#ifndef CLUBB_CRM -! WRITE(0,*) "WARNING: This version of the Morrison microphysics ", & -! "incorporates changes from WRF V3.3 not found in standard SAM." -! STOP "Comment out this stop if you want to run this code anyway." -#endif /* not CLUBB_CRM */ - -END SUBROUTINE GRAUPEL_INIT - -!interface copied from new thompson interface -!and added NC, NS, NR, and NG variables. - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! THIS SUBROUTINE IS MAIN INTERFACE WITH THE TWO-MOMENT MICROPHYSICS SCHEME -! THIS INTERFACE TAKES IN 3D VARIABLES FROM DRIVER MODEL, CONVERTS TO 1D FOR -! CALL TO THE MAIN MICROPHYSICS SUBROUTINE (SUBROUTINE M2005MICRO_GRAUPEL) -! WHICH OPERATES ON 1D VERTICAL COLUMNS. -! 1D VARIABLES FROM THE MAIN MICROPHYSICS SUBROUTINE ARE THEN REASSIGNED BACK TO 3D FOR OUTPUT -! BACK TO DRIVER MODEL USING THIS INTERFACE - -! ******IMPORTANT****** -! THIS CODE ASSUMES THE DRIVER MODEL USES PROCESS-SPLITTING FOR SOLVING THE TIME-DEPENDENT EQS. -! THUS, MODEL VARIABLES ARE UPDATED WITH MICROPHYSICS TENDENCIES INSIDE OF THE MICROPHYSICS -! SCHEME. THESE UPDATED VARIABLES ARE PASSED BACK TO DRIVER MODEL. THIS IS WHY THERE -! ARE NO TENDENCIES PASSED BACK AND FORTH BETWEEN DRIVER AND THE INTERFACE SUBROUTINE - -! AN EXCEPTION IS THE TURBULENT MIXING TENDENCIES FOR DROPLET AND CLOUD ICE NUMBER CONCENTRATIONS -! (NCTEND, NITEND BELOW). FOR APPLICATION IN MODELS OTHER THAN WRF, TURBULENT MIXING TENDENCIES -! CAN BE ADDED TO THE VARIABLES ELSEWHERE (IN DRIVER OR PBL ROUTINE), AND THEN DON'T -! NEED TO BE PASSED INTO THE SUBROUTINE HERE..... - -! FOR QUESTIONS, CONTACT: HUGH MORRISON, E-MAIL: MORRISON@UCAR.EDU, PHONE:303-497-8916 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SUBROUTINE MP_GRAUPEL(ITIMESTEP, & - TH, QV, QC, QR, QI, QS, QG, NI, NC, NS, NR, NG, TKE, NCTEND, & - NITEND,KZH, & - RHO, PII, P, DT_IN, DZ, HT, W, & - RAINNC, RAINNCV, SR & - ,EFFCS,EFFIS & ! HM ADD 4/13/07 - ,refl_10cm & ! GT -!bloss ,grid_clock & ! GT -!bloss ,grid_alarms & ! GT - ,IDS,IDE, JDS,JDE, KDS,KDE & ! domain dims - ,IMS,IME, JMS,JME, KMS,KME & ! memory dims - ,ITS,ITE, JTS,JTE, KTS,KTE & ! tile dims ) - ) - -! QV - water vapor mixing ratio (kg/kg) -! QC - cloud water mixing ratio (kg/kg) -! QR - rain water mixing ratio (kg/kg) -! QI - cloud ice mixing ratio (kg/kg) -! QS - snow mixing ratio (kg/kg) -! QG - graupel mixing ratio (KG/KG) -! NI - cloud ice number concentration (1/kg) -! NC - Droplet Number concentration (1/kg) -! NS - Snow Number concentration (1/kg) -! NR - Rain Number concentration (1/kg) -! NG - Graupel number concentration (1/kg) -! NOTE: RHO AND HT NOT USED BY THIS SCHEME AND DO NOT NEED TO BE PASSED INTO SCHEME!!!! -! P - AIR PRESSURE (PA) -! W - VERTICAL AIR VELOCITY (M/S) -! TH - POTENTIAL TEMPERATURE (K) -! PII - exner function - used to convert potential temp to temp -! DZ - difference in height over interface (m) -! DT_IN - model time step (sec) -! ITIMESTEP - time step counter -! RAINNC - accumulated grid-scale precipitation (mm) -! RAINNCV - one time step grid scale precipitation (mm/time step) -! SR - one time step mass ratio of snow to total precip -! TKE - turbulence kinetic energy (m^2 s-2), NEEDED FOR DROPLET ACTIVATION (SEE CODE BELOW) -! NCTEND - droplet concentration tendency from pbl (kg-1 s-1) -! NCTEND - CLOUD ICE concentration tendency from pbl (kg-1 s-1) -! KZH - heat eddy diffusion coefficient from YSU scheme (M^2 S-1), NEEDED FOR DROPLET ACTIVATION (SEE CODE BELOW) -! EFFCS - CLOUD DROPLET EFFECTIVE RADIUS OUTPUT TO RADIATION CODE (micron) -! EFFIS - CLOUD DROPLET EFFECTIVE RADIUS OUTPUT TO RADIATION CODE (micron) -! REFL_10CM - CALCULATED RADAR REFLECTIVITY AT 10 CM (DBZ) -!................................ -! GRID_CLOCK, GRID_ALARMS - parameters to limit radar reflectivity calculation only when needed -! otherwise radar reflectivity calculation every time step is too slow -! only needed for coupling with WRF, see code below for details - -! EFFC - DROPLET EFFECTIVE RADIUS (MICRON) -! EFFR - RAIN EFFECTIVE RADIUS (MICRON) -! EFFS - SNOW EFFECTIVE RADIUS (MICRON) -! EFFI - CLOUD ICE EFFECTIVE RADIUS (MICRON) - -! ADDITIONAL OUTPUT FROM MICRO - SEDIMENTATION TENDENCIES, NEEDED FOR LIQUID-ICE STATIC ENERGY - -! QGSTEN - GRAUPEL SEDIMENTATION TEND (KG/KG/S) -! QRSTEN - RAIN SEDIMENTATION TEND (KG/KG/S) -! QISTEN - CLOUD ICE SEDIMENTATION TEND (KG/KG/S) -! QNISTEN - SNOW SEDIMENTATION TEND (KG/KG/S) -! QCSTEN - CLOUD WATER SEDIMENTATION TEND (KG/KG/S) - -! ADDITIONAL INPUT NEEDED BY MICRO -! ********NOTE: WVAR IS SHOULD BE USED IN DROPLET ACTIVATION -! FOR CASES WHEN UPDRAFT IS NOT RESOLVED, EITHER BECAUSE OF -! LOW MODEL RESOLUTION OR CLOUD TYPE - -! WVAR - STANDARD DEVIATION OF SUB-GRID VERTICAL VELOCITY (M/S) - - IMPLICIT NONE - - INTEGER, INTENT(IN ) :: ids, ide, jds, jde, kds, kde , & - ims, ime, jms, jme, kms, kme , & - its, ite, jts, jte, kts, kte -! Temporary changed from INOUT to IN - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - qv, qc, qr, qi, qs, qg, ni, nc, ns, nr, TH, NG, effcs, effis - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: & - pii, p, dz, rho, w, tke, nctend, nitend,kzh - REAL, INTENT(IN):: dt_in - INTEGER, INTENT(IN):: ITIMESTEP - - REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: & - RAINNC, RAINNCV, SR - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & ! GT - refl_10cm - - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: ht - -!bloss TYPE (WRFU_Clock):: grid_clock ! GT -!bloss TYPE (WRFU_Alarm), POINTER:: grid_alarms(:) ! GT - - ! LOCAL VARIABLES - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme):: & - effi, effs, effr, EFFG - - REAL, DIMENSION(ims:ime, kms:kme, jms:jme):: & - T, WVAR, EFFC - - REAL, DIMENSION(kts:kte) :: & - QC_TEND1D, QI_TEND1D, QNI_TEND1D, QR_TEND1D, NC_TEND1D, & - NI_TEND1D, NS_TEND1D, NR_TEND1D, & - QC1D, QI1D, QR1D, NC1D,NI1D, NS1D, NR1D, QS1D, & - T_TEND1D,QV_TEND1D, T1D, QV1D, P1D, RHO1D, W1D, WVAR1D, & - EFFC1D, EFFI1D, EFFS1D, EFFR1D,DZ1D, & - ! HM ADD GRAUPEL - QG_TEND1D, NG_TEND1D, QG1D, NG1D, EFFG1D, & - -! ADD SEDIMENTATION TENDENCIES (UNITS OF KG/KG/S) - QGSTEN,QRSTEN, QISTEN, QNISTEN, QCSTEN, & - -! HM add reflectivity - dbz - - REAL PRECPRT1D, SNOWRT1D - - INTEGER I,K,J - - REAL DT - LOGICAL:: dBZ_tstep ! GT - -! set dbz logical based on grid_clock -!+---+ -! only calculate reflectivity when it is needed for output -! in this instance, logical dbz_tstep is set to .true. -! *******NOTE: FOR COUPLING WITH DRIVER MODEL OTHER THAN WRF, -! THIS BLOCK OF CODE WILL NEED TO BE MODIFIED TO CORRECTLY -! SET WHEN REFLECTIVIITY CALCULATION IS MADE - - dBZ_tstep = .false. -!bloss if ( Is_alarm_tstep(grid_clock, grid_alarms(HISTORY_ALARM)) ) then -!bloss dBZ_tstep = .true. -!bloss endif - - ! Initialize tendencies (all set to 0) and transfer - ! array to local variables - DT = DT_IN - do I=ITS,ITE - do J=JTS,JTE - DO K=KTS,KTE - T(I,K,J) = TH(i,k,j)*PII(i,k,j) - -! wvar is the ST. DEV. OF sub-grid vertical velocity, used for calculating droplet -! activation rates. -! WVAR BE DERIVED EITHER FROM PREDICTED TKE (AS IN MYJ PBL SCHEME), -! OR FROM EDDY DIFFUSION COEFFICIENT KZH (AS IN YSU PBL SCHEME), -! DEPENDING ON THE PARTICULAR pbl SCHEME DRIVER MODEL IS COUPLED WITH -! NOTE: IF MODEL HAS HIGH ENOUGH RESOLUTION TO RESOLVE UPDRAFTS, WVAR IS -! PROBABLY NOT NEEDED - -! for MYJ pbl scheme: -! WVAR(I,K,J) = (0.667*tke(i,k,j))**0.5 -! for YSU pbl scheme: - WVAR(I,K,J) = KZH(I,K,J)/20. - WVAR(I,K,J) = MAX(0.1,WVAR(I,K,J)) - WVAR(I,K,J) = MIN(4.,WVAR(I,K,J)) - -! add tendency from pbl to droplet and cloud ice concentration -! NEEDED FOR WRF TEMPORARILY!!!! -! OTHER DRIVER MODELS MAY ADD TURBULENT DIFFUSION TENDENCY FOR -! SCALARS SOMEWHERE ELSE IN THE MODEL (I.E, NOT IN THE MICROPHYSICS) -! IN THIS CASE THESE 2 LINES BELOW MAY BE REMOVED - nc(i,k,j) = nc(i,k,j)+nctend(i,k,j)*dt - ni(i,k,j) = ni(i,k,j)+nitend(i,k,j)*dt - END DO - END DO - END DO - - do i=its,ite ! i loop (east-west) - do j=jts,jte ! j loop (north-south) - ! - ! Transfer 3D arrays into 1D for microphysical calculations - ! - -! hm , initialize 1d tendency arrays to zero - - do k=kts,kte ! k loop (vertical) - - QC_TEND1D(k) = 0. - QI_TEND1D(k) = 0. - QNI_TEND1D(k) = 0. - QR_TEND1D(k) = 0. - NC_TEND1D(k) = 0. - NI_TEND1D(k) = 0. - NS_TEND1D(k) = 0. - NR_TEND1D(k) = 0. - T_TEND1D(k) = 0. - QV_TEND1D(k) = 0. - - QC1D(k) = QC(i,k,j) - QI1D(k) = QI(i,k,j) - QS1D(k) = QS(i,k,j) - QR1D(k) = QR(i,k,j) - - NC1D(k) = NC(i,k,j) - NI1D(k) = NI(i,k,j) - - NS1D(k) = NS(i,k,j) - NR1D(k) = NR(i,k,j) -! HM ADD GRAUPEL - QG1D(K) = QG(I,K,j) - NG1D(K) = NG(I,K,j) - QG_TEND1D(K) = 0. - NG_TEND1D(K) = 0. - - T1D(k) = T(i,k,j) - QV1D(k) = QV(i,k,j) - P1D(k) = P(i,k,j) - RHO1D(k) = P1D(K)/(R*T1D(K)) - DZ1D(k) = DZ(i,k,j) - W1D(k) = W(i,k,j) - WVAR1D(k) = WVAR(i,k,j) - end do - - !bloss: add extra argument for rho for consistency with below subroutine. - ! done by repeating p1z. - ! diable routine to make sure it is not used. - STOP 'in mp_graupel wrapper routine. Only use m2005micro_graupel()' - -#ifndef CLUBB_CRM -! call m2005micro_graupel(QC_TEND1D, QI_TEND1D, QNI_TEND1D, QR_TEND1D, NC_TEND1D, & -! NI_TEND1D, NS_TEND1D, NR_TEND1D, & -! QC1D, QI1D, QS1D, QR1D, NC1D,NI1D, NS1D, NR1D, & -! T_TEND1D,QV_TEND1D, T1D, QV1D, P1D, RHO1D, DZ1D, W1D, WVAR1D, & -! PRECPRT1D,SNOWRT1D, & -! EFFC1D,EFFI1D,EFFS1D,EFFR1D,DT, & -! IMS,IME, JMS,JME, KMS,KME, & -! ITS,ITE, JTS,JTE, KTS,KTE, & ! HM ADD GRAUPEL -! QG_TEND1D,NG_TEND1D,QG1D,NG1D,EFFG1D, & -! ADD SEDIMENTATION TENDENCIES -! QGSTEN,QRSTEN,QISTEN,QNISTEN,QCSTEN) -#endif /*CLUBB_CRM*/ - ! - ! Transfer 1D arrays back into 3D arrays - ! - do k=kts,kte - -! hm, add tendencies to update global variables -! HM, TENDENCIES FOR Q AND N NOW ADDED IN M2005MICRO, SO WE -! ONLY NEED TO TRANSFER 1D VARIABLES BACK TO 3D - - QC(i,k,j) = QC1D(k) - QI(i,k,j) = QI1D(k) - QS(i,k,j) = QS1D(k) - QR(i,k,j) = QR1D(k) - NC(i,k,j) = NC1D(k) - NI(i,k,j) = NI1D(k) - NS(i,k,j) = NS1D(k) - NR(i,k,j) = NR1D(k) - QG(I,K,j) = QG1D(K) - NG(I,K,j) = NG1D(K) - - T(i,k,j) = T1D(k) - TH(I,K,J) = T(i,k,j)/PII(i,k,j) ! CONVERT TEMP BACK TO POTENTIAL TEMP - QV(i,k,j) = QV1D(k) - - EFFC(i,k,j) = EFFC1D(k) - EFFI(i,k,j) = EFFI1D(k) - EFFS(i,k,j) = EFFS1D(k) - EFFR(i,k,j) = EFFR1D(k) - EFFG(I,K,j) = EFFG1D(K) - -! EFFECTIVE RADIUS FOR RADIATION CODE -! HM, ADD LIMIT TO PREVENT BLOWING UP OPTICAL PROPERTIES, 8/18/07 -! LIMITS ARE FROM THE CAM MODEL APPLIED BY ANDREW GETTELMAN - EFFCS(I,K,J) = MIN(EFFC(I,K,J),16.) - EFFCS(I,K,J) = MAX(EFFCS(I,K,J),4.) - EFFIS(I,K,J) = MIN(EFFI(I,K,J),130.) - EFFIS(I,K,J) = MAX(EFFIS(I,K,J),13.) - - end do - -! hm modified so that m2005 precip variables correctly match wrf precip variables - RAINNC(i,j) = RAINNC(I,J)+PRECPRT1D - RAINNCV(i,j) = PRECPRT1D - SR(i,j) = SNOWRT1D/(PRECPRT1D+1.E-12) - -! add reflectivity calculations -! only calculate if logical parameter dbz_tstep = .true. - - if (dBZ_tstep) then - call calc_refl10cm (qv1d, qr1d, qs1d, qg1d, t1d, p1d, dBZ, & - kts, kte, i, j, nr1d, ns1d, ng1d) - do k = kts, kte - refl_10cm(i,k,j) = dBZ(k) - enddo - endif - - end do - end do - -END SUBROUTINE MP_GRAUPEL - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -#ifdef CLUBB_CRM - SUBROUTINE M2005MICRO_GRAUPEL(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,NC3DTEN, & - NI3DTEN,NS3DTEN,NR3DTEN,QC3D,QI3D,QNI3D,QR3D,NC3D,NI3D,NS3D,NR3D, & - T3DTEN,QV3DTEN,T3D,QV3D,PRES,RHO,DZQ,W3D,WVAR, & -! hm 7/26/11, new output - acc1d,aut1d,evpc1d,evpr1d,mlt1d,sub1d,dep1d,con1d, & - PRECRT,SNOWRT, & - EFFC,EFFI,EFFS,EFFR,DT, & - IMS,IME, JMS,JME, KMS,KME, & - ITS,ITE, JTS,JTE, KTS,KTE, & ! ADD GRAUPEL - QG3DTEN,NG3DTEN,QG3D,NG3D,EFFG,QGSTEN,QRSTEN,QISTEN,QNISTEN,QCSTEN, & - CF3D, CFL3D, CFI3D, RELVAR, ACCRE_ENHAN & ! Cloud fraction from clubb -#ifdef ECPP - ,C2PREC,QSINK,CSED,ISED,SSED,GSED,RSED, RH3D & ! mhwang added, for ECPP -#endif /*ECPP*/ - ) -#else - SUBROUTINE M2005MICRO_GRAUPEL(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,NC3DTEN, & - NI3DTEN,NS3DTEN,NR3DTEN,QC3D,QI3D,QNI3D,QR3D,NC3D,NI3D,NS3D,NR3D, & - T3DTEN,QV3DTEN,T3D,QV3D,PRES,RHO,DZQ,W3D,WVAR, & -! hm 7/26/11, new output - acc1d,aut1d,evpc1d,evpr1d,mlt1d,sub1d,dep1d,con1d, & - PRECRT,SNOWRT, & - EFFC,EFFI,EFFS,EFFR,DT, & - IMS,IME, JMS,JME, KMS,KME, & - ITS,ITE, JTS,JTE, KTS,KTE, & ! ADD GRAUPEL - QG3DTEN,NG3DTEN,QG3D,NG3D,EFFG,QGSTEN,QRSTEN,QISTEN,QNISTEN,QCSTEN & -#ifdef ECPP - ,C2PREC,QSINK,CSED,ISED,SSED,GSED,RSED, RH3D & ! mhwang added, for ECPP -#endif /*ECPP*/ - ) -#endif /*CLUBB_CRM*/ -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! THIS PROGRAM IS THE MAIN TWO-MOMENT MICROPHYSICS SUBROUTINE DESCRIBED BY -! MORRISON ET AL. 2005 JAS; MORRISON AND PINTO 2005 JAS. -! ADDITIONAL CHANGE IS ADDITION OF GRAUPEL MICROPHYSICS. -! SCHEME IS DESCRIBED IN DETAIL BY MORRISON ET AL. (MONTHLY WEATHER REVIEW, IN PREP.) - -! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING -! RATIOS AND NUMBER CONCENTRATIONS OF FIVE HYDROMETEOR SPECIES: -! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL. - -! CODE STRUCTURE: MAIN SUBROUTINE IS 'M2005MICRO_GRAUPEL'. ALSO INCLUDED IN THIS FILE IS -! 'FUNCTION POLYSVP', 'FUNCTION DERF1', AND -! 'FUNCTION GAMMA'. - -! NOTE: THIS SUBROUTINE USES 1D ARRAY IN VERTICAL (COLUMN), EVEN THOUGH VARIABLES ARE CALLED '3D'...... - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -! DECLARATIONS - - IMPLICIT NONE - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! THESE VARIABLES BELOW MUST BE LINKED WITH THE MAIN MODEL. -! DEFINE ARRAY SIZES - -! INPUT NUMBER OF GRID CELLS - -! INPUT/OUTPUT PARAMETERS ! DESCRIPTION (UNITS) - INTEGER, INTENT( IN) :: IMS,IME, JMS,JME, KMS,KME, & - ITS,ITE, JTS,JTE, KTS,KTE - - REAL, DIMENSION(KMS:KME) :: QC3DTEN ! CLOUD WATER MIXING RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KMS:KME) :: QI3DTEN ! CLOUD ICE MIXING RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KMS:KME) :: QNI3DTEN ! SNOW MIXING RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KMS:KME) :: QR3DTEN ! RAIN MIXING RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KMS:KME) :: NC3DTEN ! CLOUD DROPLET NUMBER CONCENTRATION (1/KG/S) - REAL, DIMENSION(KMS:KME) :: NI3DTEN ! CLOUD ICE NUMBER CONCENTRATION (1/KG/S) - REAL, DIMENSION(KMS:KME) :: NS3DTEN ! SNOW NUMBER CONCENTRATION (1/KG/S) - REAL, DIMENSION(KMS:KME) :: NR3DTEN ! RAIN NUMBER CONCENTRATION (1/KG/S) - REAL, DIMENSION(KMS:KME) :: QC3D ! CLOUD WATER MIXING RATIO (KG/KG) - REAL, DIMENSION(KMS:KME) :: QI3D ! CLOUD ICE MIXING RATIO (KG/KG) - REAL, DIMENSION(KMS:KME) :: QNI3D ! SNOW MIXING RATIO (KG/KG) - REAL, DIMENSION(KMS:KME) :: QR3D ! RAIN MIXING RATIO (KG/KG) - REAL, DIMENSION(KMS:KME) :: NC3D ! CLOUD DROPLET NUMBER CONCENTRATION (1/KG) - REAL, DIMENSION(KMS:KME) :: NI3D ! CLOUD ICE NUMBER CONCENTRATION (1/KG) - REAL, DIMENSION(KMS:KME) :: NS3D ! SNOW NUMBER CONCENTRATION (1/KG) - REAL, DIMENSION(KMS:KME) :: NR3D ! RAIN NUMBER CONCENTRATION (1/KG) - REAL, DIMENSION(KMS:KME) :: T3DTEN ! TEMPERATURE TENDENCY (K/S) - REAL, DIMENSION(KMS:KME) :: QV3DTEN ! WATER VAPOR MIXING RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KMS:KME) :: T3D ! TEMPERATURE (K) - REAL, DIMENSION(KMS:KME) :: QV3D ! WATER VAPOR MIXING RATIO (KG/KG) - REAL, DIMENSION(KMS:KME) :: PRES ! ATMOSPHERIC PRESSURE (PA) -!bloss: make rho an input argument - REAL, DIMENSION(KMS:KME), INTENT(IN) :: RHO ! AIR DENSITY - REAL, DIMENSION(KMS:KME) :: DZQ ! DIFFERENCE IN HEIGHT ACROSS LEVEL (m) - REAL, DIMENSION(KMS:KME) :: W3D ! GRID-SCALE VERTICAL VELOCITY (M/S) - REAL, DIMENSION(KMS:KME) :: WVAR ! SUB-GRID VERTICAL VELOCITY (M/S) - -! hm 7/26/11, new output - REAL, DIMENSION(KMS:KME) :: aut1d ! - REAL, DIMENSION(KMS:KME) :: acc1d ! - REAL, DIMENSION(KMS:KME) :: evpc1d ! - REAL, DIMENSION(KMS:KME) :: evpr1d ! - REAL, DIMENSION(KMS:KME) :: mlt1d ! - REAL, DIMENSION(KMS:KME) :: sub1d ! - REAL, DIMENSION(KMS:KME) :: dep1d ! - REAL, DIMENSION(KMS:KME) :: con1d ! - -! HM ADDED GRAUPEL VARIABLES - REAL, DIMENSION(KMS:KME) :: QG3DTEN ! GRAUPEL MIX RATIO TENDENCY (KG/KG/S) - REAL, DIMENSION(KMS:KME) :: NG3DTEN ! GRAUPEL NUMB CONC TENDENCY (1/KG/S) - REAL, DIMENSION(KMS:KME) :: QG3D ! GRAUPEL MIX RATIO (KG/KG) - REAL, DIMENSION(KMS:KME) :: NG3D ! GRAUPEL NUMBER CONC (1/KG) - -! HM, ADD 1/16/07, SEDIMENTATION TENDENCIES FOR MIXING RATIO - - REAL, DIMENSION(KMS:KME) :: QGSTEN ! GRAUPEL SED TEND (KG/KG/S) - REAL, DIMENSION(KMS:KME) :: QRSTEN ! RAIN SED TEND (KG/KG/S) - REAL, DIMENSION(KMS:KME) :: QISTEN ! CLOUD ICE SED TEND (KG/KG/S) - REAL, DIMENSION(KMS:KME) :: QNISTEN ! SNOW SED TEND (KG/KG/S) - REAL, DIMENSION(KMS:KME) :: QCSTEN ! CLOUD WAT SED TEND (KG/KG/S) - - REAL, DIMENSION(KMS:KME) :: NGSTEN ! GRAUPEL SED TEND (#KG/S) - REAL, DIMENSION(KMS:KME) :: NRSTEN ! RAIN SED TEND (#/KG/S) - REAL, DIMENSION(KMS:KME) :: NISTEN ! CLOUD ICE SED TEND (#/KG/S) - REAL, DIMENSION(KMS:KME) :: NSSTEN ! SNOW SED TEND (#/KG/S) - REAL, DIMENSION(KMS:KME) :: NCSTEN ! CLOUD WAT SED TEND (#/KG/S) - -#ifdef CLUBB_CRM -! ADDED BY UWM JAN 7 2008 - REAL, INTENT(IN), DIMENSION(KMS:KME) :: CF3D ! SUBGRID SCALE CLOUD FRACTION - REAL, INTENT(IN), DIMENSION(KMS:KME) :: CFL3D ! SUBGRID SCALE LIQUID CLOUD FRACTION - REAL, INTENT(IN), DIMENSION(KMS:KME) :: CFI3D ! SUBGRID SCALE ICE CLOUD FRACTION (total cloud fraction here) - REAL, INTENT(IN), DIMENSION(KMS:KME) :: RELVAR ! RELATIVE LIQUID WATER VARIANCE - REAL, INTENT(IN), DIMENSION(KMS:KME) :: ACCRE_ENHAN ! ACCRETION ENHANCEMENT FACTOR -#endif -! OUTPUT VARIABLES - - REAL PRECRT ! TOTAL PRECIP PER TIME STEP (mm) - REAL SNOWRT ! SNOW PER TIME STEP (mm) - - REAL, DIMENSION(KMS:KME) :: EFFC ! DROPLET EFFECTIVE RADIUS (MICRON) - REAL, DIMENSION(KMS:KME) :: EFFI ! CLOUD ICE EFFECTIVE RADIUS (MICRON) - REAL, DIMENSION(KMS:KME) :: EFFS ! SNOW EFFECTIVE RADIUS (MICRON) - REAL, DIMENSION(KMS:KME) :: EFFR ! RAIN EFFECTIVE RADIUS (MICRON) - REAL, DIMENSION(KMS:KME) :: EFFG ! GRAUPEL EFFECTIVE RADIUS (MICRON) - -! MODEL INPUT PARAMETERS (FORMERLY IN COMMON BLOCKS) - - REAL DT ! MODEL TIME STEP (SEC) - -#ifdef ECPP - REAL, DIMENSION(KMS:KME) :: C2PREC ! CLOUD WATER SINK rate FROM PRECIPITATION (kg/kg/s) - REAL, DIMENSION(KMS:KME) :: QSINK ! CLOUD WATER SINK rate FROM PRECIPITATION (/s) - REAL, DIMENSION(KMS:KME) :: CSED ! sedimentation flux of cloud water (kg/m2/s) - REAL, DIMENSION(KMS:KME) :: ISED ! sedimentation flux of cloud ice (kg/m2/s) - REAL, DIMENSION(KMS:KME) :: SSED ! sedimentation flux of snow (kg/m2/s) - REAL, DIMENSION(KMS:KME) :: GSED ! sedimentation flux of graupel (kg/m2/s) - REAL, DIMENSION(KMS:KME) :: RSED ! sedimentation flux of rain (kg/m2/s) - REAL, DIMENSION(KMS:KME) :: RH3D ! relative humidity w.r.t water. -#endif /*ECPP*/ - -!..................................................................................................... -! LOCAL VARIABLES: ALL PARAMETERS BELOW ARE LOCAL TO SCHEME AND DON'T NEED TO COMMUNICATE WITH THE -! REST OF THE MODEL. - -! SIZE PARAMETER VARIABLES - - REAL, DIMENSION(KMS:KME) :: LAMC ! SLOPE PARAMETER FOR DROPLETS (M-1) - REAL, DIMENSION(KMS:KME) :: LAMI ! SLOPE PARAMETER FOR CLOUD ICE (M-1) - REAL, DIMENSION(KMS:KME) :: LAMS ! SLOPE PARAMETER FOR SNOW (M-1) - REAL, DIMENSION(KMS:KME) :: LAMR ! SLOPE PARAMETER FOR RAIN (M-1) - REAL, DIMENSION(KMS:KME) :: LAMG ! SLOPE PARAMETER FOR GRAUPEL (M-1) - REAL, DIMENSION(KMS:KME) :: CDIST1 ! PSD PARAMETER FOR DROPLETS - REAL, DIMENSION(KMS:KME) :: N0I ! INTERCEPT PARAMETER FOR CLOUD ICE (KG-1 M-1) - REAL, DIMENSION(KMS:KME) :: N0S ! INTERCEPT PARAMETER FOR SNOW (KG-1 M-1) - REAL, DIMENSION(KMS:KME) :: N0RR ! INTERCEPT PARAMETER FOR RAIN (KG-1 M-1) - REAL, DIMENSION(KMS:KME) :: N0G ! INTERCEPT PARAMETER FOR GRAUPEL (KG-1 M-1) - REAL, DIMENSION(KMS:KME) :: PGAM ! SPECTRAL SHAPE PARAMETER FOR DROPLETS - -! MICROPHYSICAL PROCESSES - - REAL, DIMENSION(KMS:KME) :: NSUBC ! LOSS OF NC DURING EVAP - REAL, DIMENSION(KMS:KME) :: NSUBI ! LOSS OF NI DURING SUB. - REAL, DIMENSION(KMS:KME) :: NSUBS ! LOSS OF NS DURING SUB. - REAL, DIMENSION(KMS:KME) :: NSUBR ! LOSS OF NR DURING EVAP - REAL, DIMENSION(KMS:KME) :: PRD ! DEP CLOUD ICE - REAL, DIMENSION(KMS:KME) :: PRE ! EVAP OF RAIN - REAL, DIMENSION(KMS:KME) :: PRDS ! DEP SNOW - REAL, DIMENSION(KMS:KME) :: NNUCCC ! CHANGE N DUE TO CONTACT FREEZ DROPLETS - REAL, DIMENSION(KMS:KME) :: MNUCCC ! CHANGE Q DUE TO CONTACT FREEZ DROPLETS - REAL, DIMENSION(KMS:KME) :: PRA ! ACCRETION DROPLETS BY RAIN - REAL, DIMENSION(KMS:KME) :: PRC ! AUTOCONVERSION DROPLETS - REAL, DIMENSION(KMS:KME) :: PCC ! COND/EVAP DROPLETS - REAL, DIMENSION(KMS:KME) :: NNUCCD ! CHANGE N FREEZING AEROSOL (PRIM ICE NUCLEATION) - REAL, DIMENSION(KMS:KME) :: MNUCCD ! CHANGE Q FREEZING AEROSOL (PRIM ICE NUCLEATION) - REAL, DIMENSION(KMS:KME) :: MNUCCR ! CHANGE Q DUE TO CONTACT FREEZ RAIN - REAL, DIMENSION(KMS:KME) :: NNUCCR ! CHANGE N DUE TO CONTACT FREEZ RAIN - REAL, DIMENSION(KMS:KME) :: NPRA ! CHANGE IN N DUE TO DROPLET ACC BY RAIN - REAL, DIMENSION(KMS:KME) :: NRAGG ! SELF-COLLECTION OF RAIN - REAL, DIMENSION(KMS:KME) :: NSAGG ! SELF-COLLECTION OF SNOW - REAL, DIMENSION(KMS:KME) :: NPRC ! CHANGE NC AUTOCONVERSION DROPLETS - REAL, DIMENSION(KMS:KME) :: NPRC1 ! CHANGE NR AUTOCONVERSION DROPLETS - REAL, DIMENSION(KMS:KME) :: PRAI ! CHANGE Q ACCRETION CLOUD ICE - REAL, DIMENSION(KMS:KME) :: PRCI ! CHANGE Q AUTOCONVERSION CLOUD ICE BY SNOW - REAL, DIMENSION(KMS:KME) :: PSACWS ! CHANGE Q DROPLET ACCRETION BY SNOW - REAL, DIMENSION(KMS:KME) :: NPSACWS ! CHANGE N DROPLET ACCRETION BY SNOW - REAL, DIMENSION(KMS:KME) :: PSACWI ! CHANGE Q DROPLET ACCRETION BY CLOUD ICE - REAL, DIMENSION(KMS:KME) :: NPSACWI ! CHANGE N DROPLET ACCRETION BY CLOUD ICE - REAL, DIMENSION(KMS:KME) :: NPRCI ! CHANGE N AUTOCONVERSION CLOUD ICE BY SNOW - REAL, DIMENSION(KMS:KME) :: NPRAI ! CHANGE N ACCRETION CLOUD ICE - REAL, DIMENSION(KMS:KME) :: NMULTS ! ICE MULT DUE TO RIMING DROPLETS BY SNOW - REAL, DIMENSION(KMS:KME) :: NMULTR ! ICE MULT DUE TO RIMING RAIN BY SNOW - REAL, DIMENSION(KMS:KME) :: QMULTS ! CHANGE Q DUE TO ICE MULT DROPLETS/SNOW - REAL, DIMENSION(KMS:KME) :: QMULTR ! CHANGE Q DUE TO ICE RAIN/SNOW - REAL, DIMENSION(KMS:KME) :: PRACS ! CHANGE Q RAIN-SNOW COLLECTION - REAL, DIMENSION(KMS:KME) :: NPRACS ! CHANGE N RAIN-SNOW COLLECTION - REAL, DIMENSION(KMS:KME) :: PCCN ! CHANGE Q DROPLET ACTIVATION - REAL, DIMENSION(KMS:KME) :: PSMLT ! CHANGE Q MELTING SNOW TO RAIN - REAL, DIMENSION(KMS:KME) :: EVPMS ! CHNAGE Q MELTING SNOW EVAPORATING - REAL, DIMENSION(KMS:KME) :: NSMLTS ! CHANGE N MELTING SNOW - REAL, DIMENSION(KMS:KME) :: NSMLTR ! CHANGE N MELTING SNOW TO RAIN -! HM ADDED 12/13/06 - REAL, DIMENSION(KMS:KME) :: PIACR ! CHANGE QR, ICE-RAIN COLLECTION - REAL, DIMENSION(KMS:KME) :: NIACR ! CHANGE N, ICE-RAIN COLLECTION - REAL, DIMENSION(KMS:KME) :: PRACI ! CHANGE QI, ICE-RAIN COLLECTION - REAL, DIMENSION(KMS:KME) :: PIACRS ! CHANGE QR, ICE RAIN COLLISION, ADDED TO SNOW - REAL, DIMENSION(KMS:KME) :: NIACRS ! CHANGE N, ICE RAIN COLLISION, ADDED TO SNOW - REAL, DIMENSION(KMS:KME) :: PRACIS ! CHANGE QI, ICE RAIN COLLISION, ADDED TO SNOW - REAL, DIMENSION(KMS:KME) :: EPRD ! SUBLIMATION CLOUD ICE - REAL, DIMENSION(KMS:KME) :: EPRDS ! SUBLIMATION SNOW -! HM ADDED GRAUPEL PROCESSES - REAL, DIMENSION(KMS:KME) :: PRACG ! CHANGE IN Q COLLECTION RAIN BY GRAUPEL - REAL, DIMENSION(KMS:KME) :: PSACWG ! CHANGE IN Q COLLECTION DROPLETS BY GRAUPEL - REAL, DIMENSION(KMS:KME) :: PGSACW ! CONVERSION Q TO GRAUPEL DUE TO COLLECTION DROPLETS BY SNOW - REAL, DIMENSION(KMS:KME) :: PGRACS ! CONVERSION Q TO GRAUPEL DUE TO COLLECTION RAIN BY SNOW - REAL, DIMENSION(KMS:KME) :: PRDG ! DEP OF GRAUPEL - REAL, DIMENSION(KMS:KME) :: EPRDG ! SUB OF GRAUPEL - REAL, DIMENSION(KMS:KME) :: EVPMG ! CHANGE Q MELTING OF GRAUPEL AND EVAPORATION - REAL, DIMENSION(KMS:KME) :: PGMLT ! CHANGE Q MELTING OF GRAUPEL - REAL, DIMENSION(KMS:KME) :: NPRACG ! CHANGE N COLLECTION RAIN BY GRAUPEL - REAL, DIMENSION(KMS:KME) :: NPSACWG ! CHANGE N COLLECTION DROPLETS BY GRAUPEL - REAL, DIMENSION(KMS:KME) :: NSCNG ! CHANGE N CONVERSION TO GRAUPEL DUE TO COLLECTION DROPLETS BY SNOW - REAL, DIMENSION(KMS:KME) :: NGRACS ! CHANGE N CONVERSION TO GRAUPEL DUE TO COLLECTION RAIN BY SNOW - REAL, DIMENSION(KMS:KME) :: NGMLTG ! CHANGE N MELTING GRAUPEL - REAL, DIMENSION(KMS:KME) :: NGMLTR ! CHANGE N MELTING GRAUPEL TO RAIN - REAL, DIMENSION(KMS:KME) :: NSUBG ! CHANGE N SUB/DEP OF GRAUPEL - REAL, DIMENSION(KMS:KME) :: PSACR ! CONVERSION DUE TO COLL OF SNOW BY RAIN - REAL, DIMENSION(KMS:KME) :: NMULTG ! ICE MULT DUE TO ACC DROPLETS BY GRAUPEL - REAL, DIMENSION(KMS:KME) :: NMULTRG ! ICE MULT DUE TO ACC RAIN BY GRAUPEL - REAL, DIMENSION(KMS:KME) :: QMULTG ! CHANGE Q DUE TO ICE MULT DROPLETS/GRAUPEL - REAL, DIMENSION(KMS:KME) :: QMULTRG ! CHANGE Q DUE TO ICE MULT RAIN/GRAUPEL - -! TIME-VARYING ATMOSPHERIC PARAMETERS - - REAL, DIMENSION(KMS:KME) :: KAP ! THERMAL CONDUCTIVITY OF AIR - REAL, DIMENSION(KMS:KME) :: EVS ! SATURATION VAPOR PRESSURE - REAL, DIMENSION(KMS:KME) :: EIS ! ICE SATURATION VAPOR PRESSURE - REAL, DIMENSION(KMS:KME) :: QVS ! SATURATION MIXING RATIO - REAL, DIMENSION(KMS:KME) :: QVI ! ICE SATURATION MIXING RATIO - REAL, DIMENSION(KMS:KME) :: QVQVS ! SAUTRATION RATIO - REAL, DIMENSION(KMS:KME) :: QVQVSI! ICE SATURAION RATIO - REAL, DIMENSION(KMS:KME) :: DV ! DIFFUSIVITY OF WATER VAPOR IN AIR - REAL, DIMENSION(KMS:KME) :: XXLS ! LATENT HEAT OF SUBLIMATION - REAL, DIMENSION(KMS:KME) :: XXLV ! LATENT HEAT OF VAPORIZATION - REAL, DIMENSION(KMS:KME) :: CPM ! SPECIFIC HEAT AT CONST PRESSURE FOR MOIST AIR - REAL, DIMENSION(KMS:KME) :: MU ! VISCOCITY OF AIR - REAL, DIMENSION(KMS:KME) :: SC ! SCHMIDT NUMBER - REAL, DIMENSION(KMS:KME) :: XLF ! LATENT HEAT OF FREEZING -!bloss REAL, DIMENSION(KMS:KME) :: RHO ! AIR DENSITY - REAL, DIMENSION(KMS:KME) :: AB ! CORRECTION TO CONDENSATION RATE DUE TO LATENT HEATING - REAL, DIMENSION(KMS:KME) :: ABI ! CORRECTION TO DEPOSITION RATE DUE TO LATENT HEATING - -! TIME-VARYING MICROPHYSICS PARAMETERS - - REAL, DIMENSION(KMS:KME) :: DAP ! DIFFUSIVITY OF AEROSOL - REAL NACNT ! NUMBER OF CONTACT IN - REAL FMULT ! TEMP.-DEP. PARAMETER FOR RIME-SPLINTERING - REAL COFFI ! ICE AUTOCONVERSION PARAMETER - -! FALL SPEED WORKING VARIABLES (DEFINED IN CODE) - - REAL, DIMENSION(KMS:KME) :: DUMI,DUMR,DUMFNI,DUMG,DUMFNG - REAL UNI, UMI,UMR - REAL, DIMENSION(KMS:KME) :: FR, FI, FNI,FG,FNG - REAL RGVM - REAL, DIMENSION(KMS:KME) :: FALOUTR,FALOUTI,FALOUTNI - REAL FALTNDR,FALTNDI,FALTNDNI,RHO2 - REAL, DIMENSION(KMS:KME) :: DUMQS,DUMFNS - REAL UMS,UNS - REAL, DIMENSION(KMS:KME) :: FS,FNS, FALOUTS,FALOUTNS,FALOUTG,FALOUTNG - REAL FALTNDS,FALTNDNS,UNR,FALTNDG,FALTNDNG - REAL, DIMENSION(KMS:KME) :: DUMC,DUMFNC - REAL UNC,UMC,UNG,UMG - REAL, DIMENSION(KMS:KME) :: FC,FALOUTC,FALOUTNC - REAL FALTNDC,FALTNDNC - REAL, DIMENSION(KMS:KME) :: FNC,DUMFNR,FALOUTNR - REAL FALTNDNR - REAL, DIMENSION(KMS:KME) :: FNR - -! FALL-SPEED PARAMETER 'A' WITH AIR DENSITY CORRECTION - - REAL, DIMENSION(KMS:KME) :: AIN,ARN,ASN,ACN,AGN - -! EXTERNAL FUNCTION CALL RETURN VARIABLES - -! REAL GAMMA, ! EULER GAMMA FUNCTION -! REAL POLYSVP, ! SAT. PRESSURE FUNCTION -! REAL DERF1 ! ERROR FUNCTION - -! DUMMY VARIABLES - - REAL DUM,DUM1,DUM2,DUMT,DUMQV,DUMQSS,DUMQSI,DUMS - -! PROGNOSTIC SUPERSATURATION - - REAL DQSDT ! CHANGE OF SAT. MIX. RAT. WITH TEMPERATURE - REAL DQSIDT ! CHANGE IN ICE SAT. MIXING RAT. WITH T - REAL EPSI ! 1/PHASE REL. TIME (SEE M2005), ICE - REAL EPSS ! 1/PHASE REL. TIME (SEE M2005), SNOW - REAL EPSR ! 1/PHASE REL. TIME (SEE M2005), RAIN - REAL EPSG ! 1/PHASE REL. TIME (SEE M2005), GRAUPEL - -! NEW DROPLET ACTIVATION VARIABLES - REAL TAUC ! PHASE REL. TIME (SEE M2005), DROPLETS - REAL TAUR ! PHASE REL. TIME (SEE M2005), RAIN - REAL TAUI ! PHASE REL. TIME (SEE M2005), CLOUD ICE - REAL TAUS ! PHASE REL. TIME (SEE M2005), SNOW - REAL TAUG ! PHASE REL. TIME (SEE M2005), GRAUPEL - REAL DUMACT,DUM3 - -! COUNTING/INDEX VARIABLES - - INTEGER K,NSTEP,N ! ,I - -! LTRUE IS ONLY USED TO SPEED UP THE CODE !! -! LTRUE, SWITCH = 0, NO HYDROMETEORS IN COLUMN, -! = 1, HYDROMETEORS IN COLUMN - - INTEGER LTRUE - -! DROPLET ACTIVATION/FREEZING AEROSOL - - - REAL CT ! DROPLET ACTIVATION PARAMETER - REAL TEMP1 ! DUMMY TEMPERATURE - REAL SAT1 ! DUMMY SATURATION - REAL SIGVL ! SURFACE TENSION LIQ/VAPOR - REAL KEL ! KELVIN PARAMETER - REAL KC2 ! TOTAL ICE NUCLEATION RATE - - REAL CRY,KRY ! AEROSOL ACTIVATION PARAMETERS - -! MORE WORKING/DUMMY VARIABLES - - REAL DUMQI,DUMNI,DC0,DS0,DG0 - REAL DUMQC,DUMQR,RATIO,SUM_DEP,FUDGEF - -! EFFECTIVE VERTICAL VELOCITY (M/S) - REAL WEF - -! WORKING PARAMETERS FOR ICE NUCLEATION - - REAL ANUC,BNUC - -! WORKING PARAMETERS FOR AEROSOL ACTIVATION - - REAL AACT,GAMM,GG,PSI,ETA1,ETA2,SM1,SM2,SMAX,UU1,UU2,ALPHA - -! DUMMY SIZE DISTRIBUTION PARAMETERS - - REAL DLAMS,DLAMR,DLAMI,DLAMC,DLAMG,LAMMAX,LAMMIN - - INTEGER IDROP - -#if (defined CRM && defined MODAL_AERO) - INTEGER INES -#endif - -! v1.4 -! new variables for seifert and beheng warm rain scheme - REAL, DIMENSION(KMS:KME) :: nu - integer dumii - -#ifdef CLUBB_CRM - REAL :: QV_INIT ! Temporary variable for vapor - REAL :: QSAT_INIT ! Temporary variable for saturation - REAL :: TMPQSMALL ! Temporary variable for QSMALL (a lower bound in kg/kg) - REAL :: T3D_INIT ! Temporary variable for T3D (absolute temperature in [K] ) - REAL :: CLDMAXR(KMS:KME) ! Maximum cloudoverlap for rain water - REAL :: CLDMAXALL(KMS:KME) ! Maximum cloudoverlap for all hydrometers -#else - REAL ::EP_2 ! Dry air gas constant over water vapor gas constant [-] - EP_2 = rgas / rv -#endif - - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -! SET LTRUE INITIALLY TO 0 - - LTRUE = 0 - -! V.13 initialize effective radii to default values (from P. Blossey) - effc(kts:kte) = 25. - effi(kts:kte) = 25. - effs(kts:kte) = 25. - effr(kts:kte) = 25. - effg(kts:kte) = 25. - -! 09/19/2011 mhwang Initialize the micropysics process rate for output - acc1d(kms:kme) = 0.0 - aut1d(kms:kme) = 0.0 - evpc1d(kms:kme) = 0.0 - evpr1d(kms:kme) = 0.0 - mlt1d(kms:kme) = 0.0 - sub1d(kms:kme) = 0.0 - dep1d(kms:kme) = 0.0 - con1d(kms:kme) = 0.0 - - PRC(KMS:KME) = 0. - NPRC(KMS:KME) = 0. - NPRC1(KMS:KME) = 0. - PRA(KMS:KME) = 0. - NPRA(KMS:KME) = 0. - NRAGG(KMS:KME) = 0. - PSMLT(KMS:KME) = 0. - NSMLTS(KMS:KME) = 0. - NSMLTR(KMS:KME) = 0. - EVPMS(KMS:KME) = 0. - PCC(KMS:KME) = 0. - PRE(KMS:KME) = 0. - NSUBC(KMS:KME) = 0. - NSUBR(KMS:KME) = 0. - PRACG(KMS:KME) = 0. - NPRACG(KMS:KME) = 0. - PSMLT(KMS:KME) = 0. - EVPMS(KMS:KME) = 0. - PGMLT(KMS:KME) = 0. - EVPMG(KMS:KME) = 0. - PRACS(KMS:KME) = 0. - NPRACS(KMS:KME) = 0. - NGMLTG(KMS:KME) = 0. - NGMLTR(KMS:KME) = 0. - -#ifdef CLUBB_CRM - if(doclubb_gridmean) then -! calculate rain fraction based on the maximum cloud overlap -! This follows Morrison and Gettelman scheme in CAM5 - CLDMAXR(KTE)=CFL3D(KTE) - DO K=KTE-1,KTS,-1 - ! if rain, is smaller than threshold, set cldmax - ! to cloud fraction at current level - if(QR3D(K+1).ge.QSMALL) then - CLDMAXR(K) = max(CLDMAXR(K+1), CFL3D(K)) - else - CLDMAXR(K) = CFL3D(K) - end if - END DO - - CLDMAXALL(KTE)=CFI3D(KTE) - DO K=KTE-1,KTS,-1 - ! if rain, is smaller than threshold, set cldmax - ! to cloud fraction at current level - if(QR3D(K+1).ge.QSMALL.OR.QNI3D(K+1).ge.QSMALL.OR.QG3D(K+1).ge.QSMALL ) then - CLDMAXALL(K) = max(CLDMAXALL(K+1), CFI3D(K)) - else - CLDMAXALL(K) = CFI3D(K) - end if - END DO - endif -#endif - -! ATMOSPHERIC PARAMETERS THAT VARY IN TIME AND HEIGHT - DO K = KTS,KTE - -#ifdef ECPP -! INITIALIZE VARIABLES FOR ECPP OUTPUT TO ZERO - C2PREC(K)=0. - QSINK(K)=0. - CSED(K)=0. - ISED(K)=0. - SSED(K)=0. - GSED(K)=0. - RSED(K)=0. - RH3D(K)=0. -#endif /*ECPP*/ - -#ifdef CLUBB_CRM - XXLV = Lv - XXLS(K) = Ls - CPM(K) = Cp -#else -! LATENT HEAT OF VAPORATION - - XXLV(K) = lcond !bloss 3.1484E6-2370.*T3D(K) - -! LATENT HEAT OF SUBLIMATION - - XXLS(K) = lsub !bloss 3.15E6-2370.*T3D(K)+0.3337E6 - - CPM(K) = cp !bloss CP*(1.+0.887*QV3D(K)) - -#endif -! SATURATION VAPOR PRESSURE AND MIXING RATIO - -! hm, add fix for low pressure, 5/12/10 - EVS(K) = min(0.99*pres(k),POLYSVP(T3D(K),0)) ! PA - EIS(K) = min(0.99*pres(k),POLYSVP(T3D(K),1)) ! PA - -! MAKE SURE ICE SATURATION DOESN'T EXCEED WATER SAT. NEAR FREEZING - - IF (EIS(K).GT.EVS(K)) EIS(K) = EVS(K) - - QVS(K) = EP_2*EVS(K)/(PRES(K)-EVS(K)) - QVI(K) = EP_2*EIS(K)/(PRES(K)-EIS(K)) - -#ifdef CLUBB_CRM -! ADDITION BY UWM TO WEIGHT BY SGS CLOUD FRACTION -! We assume that Morrison microphysics only acts within cloud - IF ( CF3D(K) > cloud_frac_thresh ) THEN - T3D_INIT = T3D(K) ! SAVE TEMPERATURE - QV_INIT = QV3D(K) ! SAVE VAPOR - - ! We now set QV3D to be saturated w.r.t liquid at all - ! temperatures -dschanen 15 May 2009 -! IF ( T3D(K) < 273.15 ) THEN -! QV3D(K) = QVI(K) ! SET VAPOR TO ICE SATURATION WITHIN CLOUD -! TMPQSAT = QVI(K) ! Save value -! ELSE - QV3D(K) = QVS(K) ! SET VAPOR TO LIQUID SATURATION WITHIN CLOUD - QSAT_INIT = QVS(K) ! Save value -! END IF - - QC3D(K) = QC3D(K) / CF3D(K) ! Within cloud cloud water mix ratio - - IF ( INUM == 0 ) THEN - NC3D(K) = NC3D(K) / CF3D(K) ! Cloud drop num conc - END IF - - QR3D(K) = QR3D(K) / CF3D(K) ! Rain mix ratio - NR3D(K) = NR3D(K) / CF3D(K) ! Rain num conc - - IF ( ILIQ == 0 ) THEN - QI3D(K) = QI3D(K) / CF3D(K) ! Ice mix ratio - NI3D(K) = NI3D(K) / CF3D(K) ! Ice num conc - QNI3D(K) = QNI3D(K) / CF3D(K) ! Snow mix ratio - NS3D(K) = NS3D(K) / CF3D(K) ! Snow num conc - END IF - IF ( IGRAUP == 0 ) THEN - QG3D(K) = QG3D(K) / CF3D(K) ! Graupel mix ratio - NG3D(K) = NG3D(K) / CF3D(K) ! Graupel num conc - END IF - END IF -#endif - - QVQVS(K) = QV3D(K)/QVS(K) - QVQVSI(K) = QV3D(K)/QVI(K) - -! AT SUBSATURATION, REMOVE SMALL AMOUNTS OF CLOUD/PRECIP WATER -! V1.3, change limit from 10^-7 to 10^-6 -! V1.7 7/9/09 change limit from 10^-6 to 10^-8 -! this improves reflectivity at low mixing ratios - - IF (QVQVS(K).LT.0.9) THEN - IF (QR3D(K).LT.1.E-8) THEN - QV3D(K)=QV3D(K)+QR3D(K) - T3D(K)=T3D(K)-QR3D(K)*XXLV(K)/CPM(K) - QR3D(K)=0. - END IF - IF (QC3D(K).LT.1.E-8) THEN - QV3D(K)=QV3D(K)+QC3D(K) - T3D(K)=T3D(K)-QC3D(K)*XXLV(K)/CPM(K) - QC3D(K)=0. - END IF - END IF - - IF (QVQVSI(K).LT.0.9) THEN - IF (QI3D(K).LT.1.E-8) THEN - QV3D(K)=QV3D(K)+QI3D(K) - T3D(K)=T3D(K)-QI3D(K)*XXLS(K)/CPM(K) - QI3D(K)=0. - END IF - IF (QNI3D(K).LT.1.E-8) THEN - QV3D(K)=QV3D(K)+QNI3D(K) - T3D(K)=T3D(K)-QNI3D(K)*XXLS(K)/CPM(K) - QNI3D(K)=0. - END IF - IF (QG3D(K).LT.1.E-8) THEN - QV3D(K)=QV3D(K)+QG3D(K) - T3D(K)=T3D(K)-QG3D(K)*XXLS(K)/CPM(K) - QG3D(K)=0. - END IF - END IF - -! AIR DENSITY - -!bloss: now an input argument RHO(K) = PRES(K)/(R*T3D(K)) - -! HEAT OF FUSION - - XLF(K) = XXLS(K)-XXLV(K) - -!.................................................................. -! IF MIXING RATIO < QSMALL SET MIXING RATIO AND NUMBER CONC TO ZERO - - IF (QC3D(K).LT.QSMALL) THEN -!+++mhwang - QV3D(K)=QV3D(K)+QC3D(K) - T3D(K)=T3D(K)-QC3D(K)*XXLV(K)/CPM(K) -!---mhwang - QC3D(K) = 0. - NC3D(K) = 0. - EFFC(K) = 0. - END IF - IF (QR3D(K).LT.QSMALL) THEN -!+++mhwang - QV3D(K)=QV3D(K)+QR3D(K) - T3D(K)=T3D(K)-QR3D(K)*XXLV(K)/CPM(K) -!---mhwang - QR3D(K) = 0. - NR3D(K) = 0. - EFFR(K) = 0. - END IF - IF (QI3D(K).LT.QSMALL) THEN -!+++mhwang - QV3D(K)=QV3D(K)+QI3D(K) - T3D(K)=T3D(K)-QI3D(K)*XXLS(K)/CPM(K) -!+++mhwang - QI3D(K) = 0. - NI3D(K) = 0. - EFFI(K) = 0. - END IF - IF (QNI3D(K).LT.QSMALL) THEN -!+++mhwang - QV3D(K)=QV3D(K)+QNI3D(K) - T3D(K)=T3D(K)-QNI3D(K)*XXLS(K)/CPM(K) -!+++mhwang - QNI3D(K) = 0. - NS3D(K) = 0. - EFFS(K) = 0. - END IF - IF (QG3D(K).LT.QSMALL) THEN -!+++mhwang - QV3D(K)=QV3D(K)+QG3D(K) - T3D(K)=T3D(K)-QG3D(K)*XXLS(K)/CPM(K) -!+++mhwang - QG3D(K) = 0. - NG3D(K) = 0. - EFFG(K) = 0. - END IF - -! INITIALIZE SEDIMENTATION TENDENCIES FOR MIXING RATIO - - QRSTEN(K) = 0. - QISTEN(K) = 0. - QNISTEN(K) = 0. - QCSTEN(K) = 0. - QGSTEN(K) = 0. - - NRSTEN(K) = 0. - NISTEN(K) = 0. - NSSTEN(K) = 0. - NCSTEN(K) = 0. - NGSTEN(K) = 0. - -!.................................................................. -! MICROPHYSICS PARAMETERS VARYING IN TIME/HEIGHT - -! DYNAMIC VISCOSITY OF AIR -! fix 053011 - MU(K) = 1.496E-6*T3D(K)**1.5/(T3D(K)+120.) - -! FALL SPEED WITH DENSITY CORRECTION (HEYMSFIELD AND BENSSEMER 2006) - - DUM = (RHOSU/RHO(K))**0.54 - -! fix 053011 -! AIN(K) = DUM*AI -! AA revision 4/1/11: Ikawa and Saito 1991 air-density correction -! AIN(K) = (RHOSU/RHO(K))**0.35 -! HM bug fix 10/32/2011 - AIN(K) = (RHOSU/RHO(K))**0.35*AI - ARN(K) = DUM*AR - ASN(K) = DUM*AS -! ACN(K) = DUM*AC -! AA revision 4/1/11: temperature-dependent Stokes fall speed - ACN(K) = G*RHOW/(18.*MU(K)) -! HM ADD GRAUPEL 8/28/06 - AGN(K) = DUM*AG - -! V1.7 -! bug fix 7/10/09 -!hm 4/15/09 bug fix, initialize lami to prevent later division by zero - LAMI(K)=0. - -!.................................. -! IF THERE IS NO CLOUD/PRECIP WATER, AND IF SUBSATURATED, THEN SKIP MICROPHYSICS -! FOR THIS LEVEL - - IF (QC3D(K).LT.QSMALL.AND.QI3D(K).LT.QSMALL.AND.QNI3D(K).LT.QSMALL & - .AND.QR3D(K).LT.QSMALL.AND.QG3D(K).LT.QSMALL) THEN - IF (T3D(K).LT.TMELT.AND.QVQVSI(K).LT.0.999) GOTO 200 - IF (T3D(K).GE.TMELT.AND.QVQVS(K).LT.0.999) GOTO 200 - END IF - -! THERMAL CONDUCTIVITY FOR AIR - -! fix 053011 - KAP(K) = 1.414E3*MU(K) - -! DIFFUSIVITY OF WATER VAPOR - - DV(K) = 8.794E-5*T3D(K)**1.81/PRES(K) - -! SCHMIT NUMBER - -! fix 053011 - SC(K) = MU(K)/(RHO(K)*DV(K)) - -! PSYCHOMETIC CORRECTIONS - -! RATE OF CHANGE SAT. MIX. RATIO WITH TEMPERATURE - - DUM = (RV*T3D(K)**2) - - DQSDT = XXLV(K)*QVS(K)/DUM - DQSIDT = XXLS(K)*QVI(K)/DUM - - ABI(K) = 1.+DQSIDT*XXLS(K)/CPM(K) - AB(K) = 1.+DQSDT*XXLV(K)/CPM(K) - -! -!..................................................................... -!..................................................................... -! CASE FOR TEMPERATURE ABOVE FREEZING - - IF (T3D(K).GE.TMELT) THEN - -!...................................................................... -!HM ADD, ALLOW FOR CONSTANT DROPLET NUMBER -! INUM = 0, PREDICT DROPLET NUMBER -! INUM = 1, SET CONSTANT DROPLET NUMBER - - IF (INUM.EQ.1) THEN -! CONVERT NDCNST FROM CM-3 TO KG-1 - NC3D(K)=NDCNST*1.E6/RHO(K) - END IF - -! GET SIZE DISTRIBUTION PARAMETERS - -! MELT VERY SMALL SNOW AND GRAUPEL MIXING RATIOS, ADD TO RAIN - IF (QNI3D(K).LT.1.E-6) THEN - QR3D(K)=QR3D(K)+QNI3D(K) - NR3D(K)=NR3D(K)+NS3D(K) - T3D(K)=T3D(K)-QNI3D(K)*XLF(K)/CPM(K) - QNI3D(K) = 0. - NS3D(K) = 0. - END IF - IF (QG3D(K).LT.1.E-6) THEN - QR3D(K)=QR3D(K)+QG3D(K) - NR3D(K)=NR3D(K)+NG3D(K) - T3D(K)=T3D(K)-QG3D(K)*XLF(K)/CPM(K) - QG3D(K) = 0. - NG3D(K) = 0. - END IF - - IF (QC3D(K).LT.QSMALL.AND.QNI3D(K).LT.1.E-8.AND.QR3D(K).LT.QSMALL.AND.QG3D(K).LT.1.E-8) GOTO 300 - -! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE - - NS3D(K) = MAX(0.,NS3D(K)) - NC3D(K) = MAX(0.,NC3D(K)) - NR3D(K) = MAX(0.,NR3D(K)) - NG3D(K) = MAX(0.,NG3D(K)) - -!...................................................................... -! RAIN - - IF (QR3D(K).GE.QSMALL) THEN - LAMR(K) = (PI*RHOW*NR3D(K)/QR3D(K))**(1./3.) - N0RR(K) = NR3D(K)*LAMR(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMR(K).LT.LAMMINR) THEN - - LAMR(K) = LAMMINR - - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - ELSE IF (LAMR(K).GT.LAMMAXR) THEN - LAMR(K) = LAMMAXR - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - END IF - END IF - -!...................................................................... -! CLOUD DROPLETS - -! MARTIN ET AL. (1994) FORMULA FOR PGAM - - IF (QC3D(K).GE.QSMALL) THEN - - !bloss: option for fixing pgam - if(dofix_pgam) then - pgam(k) = pgam_fixed - else - -! DUM = PRES(K)/(R*T3D(K)) -! V1.5 -#ifndef CLUBB_CRM - PGAM(K)=0.0005714*(NC3D(K)/1.E6*RHO(K))+0.2714 -#else - if(doclubb_autoin) then - PGAM(K)=0.0005714*(NC3D(K)/1.E6*RHO(K)/max(CFL3D(K), cloud_frac_thresh))+0.2714 - else - PGAM(K)=0.0005714*(NC3D(K)/1.E6*RHO(K))+0.2714 - end if -#endif - - PGAM(K)=1./(PGAM(K)**2)-1. - PGAM(K)=MAX(PGAM(K),2.) - PGAM(K)=MIN(PGAM(K),10.) - - end if -! v1.4 -! interpolate - dumii=int(pgam(k)) - nu(k)=dnu(dumii)+(dnu(dumii+1)-dnu(dumii))* & - (pgam(k)-real(dumii)) - -! CALCULATE LAMC - - LAMC(K) = (CONS26*NC3D(K)*GAMMA(PGAM(K)+4.)/ & - (QC3D(K)*GAMMA(PGAM(K)+1.)))**(1./3.) - -! LAMMIN, 60 MICRON DIAMETER -! LAMMAX, 1 MICRON - - LAMMIN = (PGAM(K)+1.)/60.E-6 - LAMMAX = (PGAM(K)+1.)/1.E-6 - - IF (LAMC(K).LT.LAMMIN) THEN - LAMC(K) = LAMMIN - -#ifndef CLUBB_CRM - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 -#else - if(doclubb_autoin) then - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K)/max(CFL3D(K), cloud_frac_thresh))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 * max(CFL3D(K), cloud_frac_thresh) - else - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - endif -#endif - ELSE IF (LAMC(K).GT.LAMMAX) THEN - LAMC(K) = LAMMAX - -#ifndef CLUBB_CRM - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 -#else - if(doclubb_autoin) then - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K)/max(CFL3D(K), cloud_frac_thresh))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 * max(CFL3D(K), cloud_frac_thresh) - else - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - end if -#endif - - END IF - - END IF - -!...................................................................... -! SNOW - - IF (QNI3D(K).GE.QSMALL) THEN - LAMS(K) = (CONS1*NS3D(K)/QNI3D(K))**(1./DS) - N0S(K) = NS3D(K)*LAMS(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMS(K).LT.LAMMINS) THEN - LAMS(K) = LAMMINS - N0S(K) = LAMS(K)**(DS+1.)*QNI3D(K)/CONS1 - - NS3D(K) = N0S(K)/LAMS(K) - - ELSE IF (LAMS(K).GT.LAMMAXS) THEN - - LAMS(K) = LAMMAXS - N0S(K) = LAMS(K)**(DS+1.)*QNI3D(K)/CONS1 - - NS3D(K) = N0S(K)/LAMS(K) - END IF - END IF - -!...................................................................... -! GRAUPEL - - IF (QG3D(K).GE.QSMALL) THEN - LAMG(K) = (CONS2*NG3D(K)/QG3D(K))**(1./DG) - N0G(K) = NG3D(K)*LAMG(K) - -! ADJUST VARS - - IF (LAMG(K).LT.LAMMING) THEN - LAMG(K) = LAMMING - N0G(K) = LAMG(K)**(DG+1.)*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - - ELSE IF (LAMG(K).GT.LAMMAXG) THEN - - LAMG(K) = LAMMAXG - N0G(K) = LAMG(K)**(DG+1.)*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - END IF - END IF - -!..................................................................... -! ZERO OUT PROCESS RATES - - PRC(K) = 0. - NPRC(K) = 0. - NPRC1(K) = 0. - PRA(K) = 0. - NPRA(K) = 0. - NRAGG(K) = 0. - PSMLT(K) = 0. - NSMLTS(K) = 0. - NSMLTR(K) = 0. - EVPMS(K) = 0. - PCC(K) = 0. - PRE(K) = 0. - NSUBC(K) = 0. - NSUBR(K) = 0. - PRACG(K) = 0. - NPRACG(K) = 0. - PSMLT(K) = 0. - EVPMS(K) = 0. - PGMLT(K) = 0. - EVPMG(K) = 0. - PRACS(K) = 0. - NPRACS(K) = 0. - NGMLTG(K) = 0. - NGMLTR(K) = 0. - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! CALCULATION OF MICROPHYSICAL PROCESS RATES, T > 273.15 K - -!................................................................. -!....................................................................... -! AUTOCONVERSION OF CLOUD LIQUID WATER TO RAIN -! FORMULA FROM BEHENG (1994) -! USING NUMERICAL SIMULATION OF STOCHASTIC COLLECTION EQUATION -! AND INITIAL CLOUD DROPLET SIZE DISTRIBUTION SPECIFIED -! AS A GAMMA DISTRIBUTION - -! USE MINIMUM VALUE OF 1.E-6 TO PREVENT FLOATING POINT ERROR - - IF (QC3D(K).GE.1.E-6) THEN - -! HM ADD 12/13/06, REPLACE WITH NEWER FORMULA -! FROM KHAIROUTDINOV AND KOGAN 2000, MWR - - IF (IRAIN.EQ.0) THEN - - PRC(K)=1350.*QC3D(K)**2.47* & - (NC3D(K)/1.e6*RHO(K))**(-1.79) - -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - PRC(K)=PRC(K) * gamma(RELVAR(K)+2.47)/(gamma(RELVAR(K))*RELVAR(K)**2.47) - PRC(K)=PRC(K) * CFL3D(K)**0.32 ! CFL3D**(1.79-2.47+1) - end if -#endif - -! note: nprc1 is change in Nr, -! nprc is change in Nc - - NPRC1(K) = PRC(K)/CONS29 - NPRC(K) = PRC(K)/(QC3D(k)/NC3D(K)) - - NPRC(K) = MIN(NPRC(K),NC3D(K)/DT) - - ELSE IF (IRAIN.EQ.1) THEN - -! v1.4 -! replace with seifert and beheng - - dum = 1.-qc3d(k)/(qc3d(k)+qr3d(k)) - dum1 = 600.*dum**0.68*(1.-dum**0.68)**3 - - prc(k) = 9.44e9/(20.*2.6e-7)* & - (nu(k)+2.)*(nu(k)+4.)/(nu(k)+1.)**2* & - (rho(k)*qc3d(k)/1000.)**4/(rho(k)*nc3d(k)/1.e6)**2* & - (1.+dum1/(1.-dum)**2)*1000./rho(k) - - nprc(k) = prc(k)*2./2.6e-7*1000. - nprc1(k) = 0.5*nprc(k) - - END IF - END IF - -!....................................................................... -! HM ADD 12/13/06, COLLECTION OF SNOW BY RAIN ABOVE FREEZING -! FORMULA FROM IKAWA AND SAITO (1991) - - IF (QR3D(K).GE.1.E-8.AND.QNI3D(K).GE.1.E-8) THEN - - UMS = ASN(K)*CONS3/(LAMS(K)**BS) - UMR = ARN(K)*CONS4/(LAMR(K)**BR) - UNS = ASN(K)*CONS5/LAMS(K)**BS - UNR = ARN(K)*CONS6/LAMR(K)**BR - -! SET REASLISTIC LIMITS ON FALLSPEEDS - -! bug fix, 10/08/09 - dum=(rhosu/rho(k))**0.54 - UMS=MIN(UMS,1.2*dum) - UNS=MIN(UNS,1.2*dum) - UMR=MIN(UMR,9.1*dum) - UNR=MIN(UNR,9.1*dum) - - PRACS(K) = CONS31*(((1.2*UMR-0.95*UMS)**2+ & - 0.08*UMS*UMR)**0.5*RHO(K)* & - N0RR(K)*N0S(K)/LAMS(K)**3* & - (5./(LAMS(K)**3*LAMR(K))+ & - 2./(LAMS(K)**2*LAMR(K)**2)+ & - 0.5/(LAMS(K)*LAMR(K)**3))) - -! fix 053011, npracs no longer subtracted from snow -! NPRACS(K) = CONS32*RHO(K)*(1.7*(UNR-UNS)**2+ & -! 0.3*UNR*UNS)**0.5*N0RR(K)*N0S(K)* & -! (1./(LAMR(K)**3*LAMS(K))+ & -! 1./(LAMR(K)**2*LAMS(K)**2)+ & -! 1./(LAMR(K)*LAMS(K)**3)) - - END IF - -! ADD COLLECTION OF GRAUPEL BY RAIN ABOVE FREEZING -! ASSUME ALL RAIN COLLECTION BY GRAUPEL ABOVE FREEZING IS SHED -! ASSUME SHED DROPS ARE 1 MM IN SIZE - - IF (QR3D(K).GE.1.E-8.AND.QG3D(K).GE.1.E-8) THEN - - UMG = AGN(K)*CONS7/(LAMG(K)**BG) - UMR = ARN(K)*CONS4/(LAMR(K)**BR) - UNG = AGN(K)*CONS8/LAMG(K)**BG - UNR = ARN(K)*CONS6/LAMR(K)**BR - -! SET REASLISTIC LIMITS ON FALLSPEEDS -! bug fix, 10/08/09 - dum=(rhosu/rho(k))**0.54 - UMG=MIN(UMG,20.*dum) - UNG=MIN(UNG,20.*dum) - UMR=MIN(UMR,9.1*dum) - UNR=MIN(UNR,9.1*dum) - -! PRACG IS MIXING RATIO OF RAIN PER SEC COLLECTED BY GRAUPEL/HAIL - PRACG(K) = CONS41*(((1.2*UMR-0.95*UMG)**2+ & - 0.08*UMG*UMR)**0.5*RHO(K)* & - N0RR(K)*N0G(K)/LAMR(K)**3* & - (5./(LAMR(K)**3*LAMG(K))+ & - 2./(LAMR(K)**2*LAMG(K)**2)+ & - 0.5/(LAMR(k)*LAMG(k)**3))) - -! ASSUME 1 MM DROPS ARE SHED, GET NUMBER CONC (KG-1) SHED PER SEC - - DUM = PRACG(K)/5.2E-7 - -! GET NUMBER CONC OF RAIN DROPS COLLECTED - - NPRACG(K) = CONS32*RHO(K)*(1.7*(UNR-UNG)**2+ & - 0.3*UNR*UNG)**0.5*N0RR(K)*N0G(K)* & - (1./(LAMR(K)**3*LAMG(K))+ & - 1./(LAMR(K)**2*LAMG(K)**2)+ & - 1./(LAMR(K)*LAMG(K)**3)) - - NPRACG(K)=MAX(NPRACG(K)-DUM,0.) - - END IF - -!....................................................................... -! ACCRETION OF CLOUD LIQUID WATER BY RAIN -! CONTINUOUS COLLECTION EQUATION WITH -! GRAVITATIONAL COLLECTION KERNEL, DROPLET FALL SPEED NEGLECTED - - IF (QR3D(K).GE.1.E-8 .AND. QC3D(K).GE.1.E-8) THEN - -! 12/13/06 HM ADD, REPLACE WITH NEWER FORMULA FROM -! KHAIROUTDINOV AND KOGAN 2000, MWR - - IF (IRAIN.EQ.0) THEN - - DUM=(QC3D(K)*QR3D(K)) - PRA(K) = 67.*(DUM)**1.15 -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - PRA(K)=PRA(K) * accre_enhan(K)*gamma(RELVAR(K)+1.15)/(gamma(RELVAR(K))*RELVAR(K)**1.15) - PRA(K) = PRA(K) /(max(CLDMAXR(K), cloud_frac_thresh))**1.15 ! PRA = (QC3D/CFL3D * QR3D/CLDMAXR * CFL3D)**1.15 - end if -#endif - NPRA(K) = PRA(K)/(QC3D(K)/NC3D(K)) - - ELSE IF (IRAIN.EQ.1) THEN - -! v1.4 -! seifert and beheng (2001) formulation - - dum = 1.-qc3d(k)/(qc3d(k)+qr3d(k)) - dum1 = (dum/(dum+5.e-4))**4 - pra(k) = 5.78e3*rho(k)/1000.*qc3d(k)*qr3d(k)*dum1 - npra(k) = pra(k)*rho(k)/1000.*(nc3d(k)*rho(k)/1.e6)/ & - (qc3d(k)*rho(k)/1000.)*1.e6/rho(k) - - END IF - END IF -!....................................................................... -! SELF-COLLECTION OF RAIN DROPS -! FROM BEHENG(1994) -! FROM NUMERICAL SIMULATION OF THE STOCHASTIC COLLECTION EQUATION -! AS DESCRINED ABOVE FOR AUTOCONVERSION - -! v1.4, replace with seifert and beheng (2001) - - IF (QR3D(K).GE.1.E-8) THEN -! include breakup add 10/09/09 - dum1=300.e-6 - if (1./lamr(k).lt.dum1) then - dum=1. - else if (1./lamr(k).ge.dum1) then - dum=2.-exp(2300.*(1./lamr(k)-dum1)) - end if -! NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K) - NRAGG(K) = -5.78*dum*NR3D(K)*QR3D(K)*RHO(K) - END IF - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! CALCULATE EVAP OF RAIN (RUTLEDGE AND HOBBS 1983) - - IF (QR3D(K).GE.QSMALL) THEN - EPSR = 2.*PI*N0RR(K)*RHO(K)*DV(K)* & - (F1R/(LAMR(K)*LAMR(K))+ & - F2R*(ARN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS9/ & - (LAMR(K)**CONS34)) - ELSE - EPSR = 0. - END IF - -! NO CONDENSATION ONTO RAIN, ONLY EVAP ALLOWED - - IF (QV3D(K).LT.QVS(K)) THEN - PRE(K) = EPSR*(QV3D(K)-QVS(K))/AB(K) - PRE(K) = MIN(PRE(K),0.) - ELSE - PRE(K) = 0. - END IF -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - PRE(K) = PRE(K) * max(CLDMAXR(K)-CFL3D(K), 0.0)/max(CLDMAXR(K), cloud_frac_thresh) - if(CFL3D(K).gt.0.10) then ! when there is enough liquid present, no evaporation is allowed - PRE(K) = 0.0 - end if - end if -#endif - -!....................................................................... -! MELTING OF SNOW - -! SNOW MAY PERSITS ABOVE FREEZING, FORMULA FROM RUTLEDGE AND HOBBS, 1984 -! IF WATER SUPERSATURATION, SNOW MELTS TO FORM RAIN - - IF (QNI3D(K).GE.1.E-8) THEN - -! fix 053011 -! HM, MODIFY FOR V3.2, ADD ACCELERATED MELTING DUE TO COLLISION WITH RAIN -! DUM = -CPW/XLF(K)*T3D(K)*PRACS(K) -! DUM = -CPW/XLF(K)*(T3D(K)-TMELT)*PRACS(K) - DUM = -CPW/XLF(K)*max(T3D(K)-TMELT, 0.0)*PRACS(K) !+++mhwang 09/20/2011 - -! PSMLT(K)=2.*PI*N0S(K)*KAP(K)*(TMELT-T3D(K))/ & - PSMLT(K)=2.*PI*N0S(K)*KAP(K)*min(TMELT-T3D(K), 0.0)/ & !+++mhwang 09/20/2011 - XLF(K)*RHO(K)*(F1S/(LAMS(K)*LAMS(K))+ & - F2S*(ASN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS10/ & - (LAMS(K)**CONS35))+DUM - -! IN WATER SUBSATURATION, SNOW MELTS AND EVAPORATES - - IF (QVQVS(K).LT.1.) THEN - EPSS = 2.*PI*N0S(K)*RHO(K)*DV(K)* & - (F1S/(LAMS(K)*LAMS(K))+ & - F2S*(ASN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS10/ & - (LAMS(K)**CONS35)) -! bug fix V1.4 - EVPMS(K) = (QV3D(K)-QVS(K))*EPSS/AB(K) - EVPMS(K) = MAX(EVPMS(K),PSMLT(K)) - PSMLT(K) = PSMLT(K)-EVPMS(K) - END IF - END IF - -!....................................................................... -! MELTING OF GRAUPEL - -! GRAUPEL MAY PERSITS ABOVE FREEZING, FORMULA FROM RUTLEDGE AND HOBBS, 1984 -! IF WATER SUPERSATURATION, GRAUPEL MELTS TO FORM RAIN - - IF (QG3D(K).GE.1.E-8) THEN - -! fix 053011 -! HM, MODIFY FOR V3.2, ADD ACCELERATED MELTING DUE TO COLLISION WITH RAIN -! DUM = -CPW/XLF(K)*T3D(K)*PRACG(K) -! DUM = -CPW/XLF(K)*(T3D(K)-273.15)*PRACG(K) - DUM = -CPW/XLF(K)*max(T3D(K)-TMELT, 0.0)*PRACG(K) !+++mhwang 10/17/2011 - - PGMLT(K)=2.*PI*N0G(K)*KAP(K)*(TMELT-T3D(K))/ & - XLF(K)*RHO(K)*(F1S/(LAMG(K)*LAMG(K))+ & - F2S*(AGN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS11/ & - (LAMG(K)**CONS36))+DUM - -! IN WATER SUBSATURATION, GRAUPEL MELTS AND EVAPORATES - - IF (QVQVS(K).LT.1.) THEN - EPSG = 2.*PI*N0G(K)*RHO(K)*DV(K)* & - (F1S/(LAMG(K)*LAMG(K))+ & - F2S*(AGN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS11/ & - (LAMG(K)**CONS36)) -! bug fix V1.4 - EVPMG(K) = (QV3D(K)-QVS(K))*EPSG/AB(K) - EVPMG(K) = MAX(EVPMG(K),PGMLT(K)) - PGMLT(K) = PGMLT(K)-EVPMG(K) - END IF - END IF - -! HM, V3.2 -! RESET PRACG AND PRACS TO ZERO, THIS IS DONE BECAUSE THERE IS NO -! TRANSFER OF MASS FROM SNOW AND GRAUPEL TO RAIN DIRECTLY FROM COLLECTION -! ABOVE FREEZING, IT IS ONLY USED FOR ENHANCEMENT OF MELTING AND SHEDDING - - PRACG(K) = 0. - PRACS(K) = 0. - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -! FOR CLOUD ICE, ONLY PROCESSES OPERATING AT T > 273.15 IS -! MELTING, WHICH IS ALREADY CONSERVED DURING PROCESS -! CALCULATION - -! CONSERVATION OF QC - - DUM = (PRC(K)+PRA(K))*DT - - IF (DUM.GT.QC3D(K).AND.QC3D(K).GE.QSMALL) THEN - - RATIO = QC3D(K)/DUM - - PRC(K) = PRC(K)*RATIO - PRA(K) = PRA(K)*RATIO - - END IF - -! CONSERVATION OF SNOW - - DUM = (-PSMLT(K)-EVPMS(K)+PRACS(K))*DT - - IF (DUM.GT.QNI3D(K).AND.QNI3D(K).GE.QSMALL) THEN - -! NO SOURCE TERMS FOR SNOW AT T > FREEZING - RATIO = QNI3D(K)/DUM - - PSMLT(K) = PSMLT(K)*RATIO - EVPMS(K) = EVPMS(K)*RATIO - PRACS(K) = PRACS(K)*RATIO - - END IF - -! CONSERVATION OF GRAUPEL - - DUM = (-PGMLT(K)-EVPMG(K)+PRACG(K))*DT - - IF (DUM.GT.QG3D(K).AND.QG3D(K).GE.QSMALL) THEN - -! NO SOURCE TERM FOR GRAUPEL ABOVE FREEZING - RATIO = QG3D(K)/DUM - - PGMLT(K) = PGMLT(K)*RATIO - EVPMG(K) = EVPMG(K)*RATIO - PRACG(K) = PRACG(K)*RATIO - - END IF - -! CONSERVATION OF QR -! HM 12/13/06, ADDED CONSERVATION OF RAIN SINCE PRE IS NEGATIVE - - DUM = (-PRACS(K)-PRACG(K)-PRE(K)-PRA(K)-PRC(K)+PSMLT(K)+PGMLT(K))*DT - - IF (DUM.GT.QR3D(K).AND.QR3D(K).GE.QSMALL) THEN - - RATIO = (QR3D(K)/DT+PRACS(K)+PRACG(K)+PRA(K)+PRC(K)-PSMLT(K)-PGMLT(K))/ & - (-PRE(K)) - PRE(K) = PRE(K)*RATIO - - END IF - -!.................................... - - QV3DTEN(K) = QV3DTEN(K)+(-PRE(K)-EVPMS(K)-EVPMG(K)) - - T3DTEN(K) = T3DTEN(K)+(PRE(K)*XXLV(K)+(EVPMS(K)+EVPMG(K))*XXLS(K)+& - (PSMLT(K)+PGMLT(K)-PRACS(K)-PRACG(K))*XLF(K))/CPM(K) - - QC3DTEN(K) = QC3DTEN(K)+(-PRA(K)-PRC(K)) - QR3DTEN(K) = QR3DTEN(K)+(PRE(K)+PRA(K)+PRC(K)-PSMLT(K)-PGMLT(K)+PRACS(K)+PRACG(K)) - QNI3DTEN(K) = QNI3DTEN(K)+(PSMLT(K)+EVPMS(K)-PRACS(K)) - QG3DTEN(K) = QG3DTEN(K)+(PGMLT(K)+EVPMG(K)-PRACG(K)) -! fix 053011 -! NS3DTEN(K) = NS3DTEN(K)-NPRACS(K) -! HM, bug fix 5/12/08, npracg is subtracted from nr not ng -! NG3DTEN(K) = NG3DTEN(K) - NC3DTEN(K) = NC3DTEN(K)+ (-NPRA(K)-NPRC(K)) - NR3DTEN(K) = NR3DTEN(K)+ (NPRC1(K)+NRAGG(K)-NPRACG(K)) -#ifdef ECPP -! HM ADD, WRF-CHEM, ADD TENDENCIES FOR C2PREC - C2PREC(K) = PRA(K)+PRC(K) - if(QC3D(K).gt.1.0e-10) then - QSINK(K) = min(1.0, C2PREC(K)/QC3D(K)) - else - QSINK(K) = 0.0 - end if -#endif - - IF (PRE(K).LT.0.) THEN - DUM = PRE(K)*DT/QR3D(K) - DUM = MAX(-1.,DUM) - NSUBR(K) = DUM*NR3D(K)/DT - END IF - -! V1.3 move code below to before saturation adjustment - IF (EVPMS(K)+PSMLT(K).LT.0.) THEN - DUM = (EVPMS(K)+PSMLT(K))*DT/QNI3D(K) - DUM = MAX(-1.,DUM) - NSMLTS(K) = DUM*NS3D(K)/DT - END IF - IF (PSMLT(K).LT.0.) THEN - DUM = PSMLT(K)*DT/QNI3D(K) - DUM = MAX(-1.0,DUM) - NSMLTR(K) = DUM*NS3D(K)/DT - END IF - IF (EVPMG(K)+PGMLT(K).LT.0.) THEN - DUM = (EVPMG(K)+PGMLT(K))*DT/QG3D(K) - DUM = MAX(-1.,DUM) - NGMLTG(K) = DUM*NG3D(K)/DT - END IF - IF (PGMLT(K).LT.0.) THEN - DUM = PGMLT(K)*DT/QG3D(K) - DUM = MAX(-1.0,DUM) - NGMLTR(K) = DUM*NG3D(K)/DT - END IF - -! nsubr(k)=0. -! nsubs(k)=0. -! nsubg(k)=0. - - NS3DTEN(K) = NS3DTEN(K)+(NSMLTS(K)) - NG3DTEN(K) = NG3DTEN(K)+(NGMLTG(K)) - NR3DTEN(K) = NR3DTEN(K)+(NSUBR(K)-NSMLTR(K)-NGMLTR(K)) - - 300 CONTINUE - - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - IF(ISATADJ.EQ.0) THEN !PB 4/13/09 - -! NOW CALCULATE SATURATION ADJUSTMENT TO CONDENSE EXTRA VAPOR ABOVE -! WATER SATURATION - - DUMT = T3D(K)+DT*T3DTEN(K) - DUMQV = QV3D(K)+DT*QV3DTEN(K) -! hm, add fix for low pressure, 5/12/10 - dum=min(0.99*pres(k),POLYSVP(DUMT,0)) - DUMQSS = EP_2*dum/(PRES(K)-dum) - DUMQC = QC3D(K)+DT*QC3DTEN(K) - DUMQC = MAX(DUMQC,0.) - -! SATURATION ADJUSTMENT FOR LIQUID - - DUMS = DUMQV-DUMQSS - PCC(K) = DUMS/(1.+XXLV(K)**2*DUMQSS/(CPM(K)*RV*DUMT**2))/DT -! IF (PCC(K)*DT+DUMQC.LT.0.) THEN -! PCC(K) = -DUMQC/DT -! END IF -!+++mhwang - IF (PCC(K)*DT+QC3D(K)+DT*QC3DTEN(K).LT.0.) THEN - PCC(K) = -(QC3D(K)+DT*QC3DTEN(K))/DT - END IF -!---mhwang - - QV3DTEN(K) = QV3DTEN(K)-PCC(K) - T3DTEN(K) = T3DTEN(K)+PCC(K)*XXLV(K)/CPM(K) - QC3DTEN(K) = QC3DTEN(K)+PCC(K) - - END IF - -! hm 7/26/11, new output - - aut1d(k)=prc(k) - acc1d(k)=pra(k) - mlt1d(k)=-PSMLT(K)-PGMLT(K)+PRACS(K)+PRACG(K) - evpr1d(k)=-PRE(K)-EVPMS(K)-EVPMG(K) - if (pcc(k).lt.0.) then - evpc1d(k)=-pcc(k) - else if (pcc(k).gt.0.) then - con1d(k)=pcc(k) - end if - -!....................................................................... -! ACTIVATION OF CLOUD DROPLETS - -!bloss: only do activation if droplet number is predicted -!bloss IF (QC3D(K)+QC3DTEN(K)*DT.GE.QSMALL) THEN - IF (QC3D(K)+QC3DTEN(K)*DT.GE.QSMALL.AND.INUM.EQ.0) THEN - -! EFFECTIVE VERTICAL VELOCITY (M/S) - - IF (ISUB.EQ.0) THEN -! ADD SUB-GRID VERTICAL VELOCITY - DUM = W3D(K)+WVAR(K) - -! ASSUME MINIMUM EFF. SUB-GRID VELOCITY 0.10 M/S -#ifdef CLUBB_CRM - DUM = MAX(DUM,0.01) -#else - DUM = MAX(DUM,0.10) -#endif - - - ELSE IF (ISUB.EQ.1) THEN - DUM=W3D(K) - END IF - -! ONLY ACTIVATE IN REGIONS OF UPWARD MOTION - IF (DUM.GE.0.001) THEN - - IF (IBASE.EQ.1) THEN - -! ACTIVATE ONLY IF THERE IS LITTLE CLOUD WATER -! OR IF AT CLOUD BASE, OR AT LOWEST MODEL LEVEL (K=1) - - IDROP=0 - -! V1.3 USE CURRENT VALUE OF QC FOR IDROP - IF (QC3D(K).LE.0.05E-3/RHO(K)) THEN - IDROP=1 - END IF - IF (K.EQ.1) THEN - IDROP=1 - ELSE IF (K.GE.2) THEN - IF (QC3D(K).GT.0.05E-3/RHO(K).AND. & - QC3D(K-1).LE.0.05E-3/RHO(K-1)) THEN - IDROP=1 - END IF - END IF - - IF (IDROP.EQ.1) THEN -! ACTIVATE AT CLOUD BASE OR REGIONS WITH VERY LITTLE LIQ WATER - - IF (IACT.EQ.1) THEN -! USE ROGERS AND YAU (1989) TO RELATE NUMBER ACTIVATED TO W -! BASED ON TWOMEY 1959 - - DUM=DUM*100. ! CONVERT FROM M/S TO CM/S - DUM2 = 0.88*C1**(2./(K1+2.))*(7.E-2*DUM**1.5)**(K1/(K1+2.)) - DUM2=DUM2*1.E6 ! CONVERT FROM CM-3 TO M-3 - DUM2=DUM2/RHO(K) ! CONVERT FROM M-3 TO KG-1 -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 - - ELSE IF (IACT.EQ.2) THEN -! DROPLET ACTIVATION FROM ABDUL-RAZZAK AND GHAN (2000) - - SIGVL = 0.0761-1.55E-4*(T3D(K)-TMELT) - AACT = 2.*MW/(RHOW*RR)*SIGVL/T3D(K) - ALPHA = G*MW*XXLV(K)/(CPM(K)*RR*T3D(K)**2)-G*MA/(RR*T3D(K)) - GAMM = RR*T3D(K)/(EVS(K)*MW)+MW*XXLV(K)**2/(CPM(K)*PRES(K)*MA*T3D(K)) - - GG = 1./(RHOW*RR*T3D(K)/(EVS(K)*DV(K)*MW)+ XXLV(K)*RHOW/(KAP(K)*T3D(K))*(XXLV(K)*MW/ & - (T3D(K)*RR)-1.)) - - PSI = 2./3.*(ALPHA*DUM/GG)**0.5*AACT - - ETA1 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW1) - ETA2 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW2) - - SM1 = 2./BACT**0.5*(AACT/(3.*RM1))**1.5 - SM2 = 2./BACT**0.5*(AACT/(3.*RM2))**1.5 - - DUM1 = 1./SM1**2*(F11*(PSI/ETA1)**1.5+F21*(SM1**2/(ETA1+3.*PSI))**0.75) - DUM2 = 1./SM2**2*(F12*(PSI/ETA2)**1.5+F22*(SM2**2/(ETA2+3.*PSI))**0.75) - - SMAX = 1./(DUM1+DUM2)**0.5 - - UU1 = 2.*LOG(SM1/SMAX)/(4.242*LOG(SIG1)) - UU2 = 2.*LOG(SM2/SMAX)/(4.242*LOG(SIG2)) - DUM1 = NANEW1/2.*(1.-DERF1(UU1)) - DUM2 = NANEW2/2.*(1.-DERF1(UU2)) - - DUM2 = (DUM1+DUM2)/RHO(K) !CONVERT TO KG-1 - -! MAKE SURE THIS VALUE ISN'T GREATER THAN TOTAL NUMBER OF AEROSOL - - DUM2 = MIN((NANEW1+NANEW2)/RHO(K),DUM2) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#if (defined CRM && defined MODAL_AERO) - ELSE if (IACT.EQ.3) then - INES = 0 - CALL DROP_ACTIVATION_GHAN(DUM, T3D(k), RHO(k), & - DUM2, INES, SMAX, K) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0., DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#endif - END IF ! IACT - -!............................................................................. - ELSE IF (IDROP.EQ.0) THEN -! ACTIVATE IN CLOUD INTERIOR -! FIND EQUILIBRIUM SUPERSATURATION - - TAUC=1./(2.*PI*RHO(k)*DV(K)*NC3D(K)*(PGAM(K)+1.)/LAMC(K)) - IF (EPSR.GT.1.E-8) THEN - TAUR=1./EPSR - ELSE - TAUR=1.E8 - END IF - - DUM3=(QVS(K)*RHO(K)/(PRES(K)-EVS(K))+DQSDT/CP)*G*DUM - DUM3=DUM3*TAUC*TAUR/(TAUC+TAUR) - - IF (DUM3/QVS(K).GE.1.E-6) THEN - IF (IACT.EQ.1) THEN - -! FIND MAXIMUM ALLOWED ACTIVATION WITH NON-EQULIBRIUM SS - - DUM=DUM*100. ! CONVERT FROM M/S TO CM/S - DUMACT = 0.88*C1**(2./(K1+2.))*(7.E-2*DUM**1.5)**(K1/(K1+2.)) - -! USE POWER LAW CCN SPECTRA - -! CONVERT FROM ABSOLUTE SUPERSATURATION TO SUPERSATURATION RATIO IN % - DUM3=DUM3/QVS(K)*100. - - DUM2=C1*DUM3**K1 -! MAKE SURE VALUE DOESN'T EXCEED THAT FOR NON-EQUILIBRIUM SS - DUM2=MIN(DUM2,DUMACT) - DUM2=DUM2*1.E6 ! CONVERT FROM CM-3 TO M-3 - DUM2=DUM2/RHO(K) ! CONVERT FROM M-3 TO KG-1 -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 - - ELSE IF (IACT.EQ.2) THEN - -! FIND MAXIMUM ALLOWED ACTIVATION WITH NON-EQULIBRIUM SS - - SIGVL = 0.0761-1.55E-4*(T3D(K)-TMELT) - AACT = 2.*MW/(RHOW*RR)*SIGVL/T3D(K) - ALPHA = G*MW*XXLV(K)/(CPM(K)*RR*T3D(K)**2)-G*MA/(RR*T3D(K)) - GAMM = RR*T3D(K)/(EVS(K)*MW)+MW*XXLV(K)**2/(CPM(K)*PRES(K)*MA*T3D(K)) - - GG = 1./(RHOW*RR*T3D(K)/(EVS(K)*DV(K)*MW)+ XXLV(K)*RHOW/(KAP(K)*T3D(K))*(XXLV(K)*MW/ & - (T3D(K)*RR)-1.)) - - PSI = 2./3.*(ALPHA*DUM/GG)**0.5*AACT - - ETA1 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW1) - ETA2 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW2) - - SM1 = 2./BACT**0.5*(AACT/(3.*RM1))**1.5 - SM2 = 2./BACT**0.5*(AACT/(3.*RM2))**1.5 - - DUM1 = 1./SM1**2*(F11*(PSI/ETA1)**1.5+F21*(SM1**2/(ETA1+3.*PSI))**0.75) - DUM2 = 1./SM2**2*(F12*(PSI/ETA2)**1.5+F22*(SM2**2/(ETA2+3.*PSI))**0.75) - - SMAX = 1./(DUM1+DUM2)**0.5 - - UU1 = 2.*LOG(SM1/SMAX)/(4.242*LOG(SIG1)) - UU2 = 2.*LOG(SM2/SMAX)/(4.242*LOG(SIG2)) - DUM1 = NANEW1/2.*(1.-DERF1(UU1)) - DUM2 = NANEW2/2.*(1.-DERF1(UU2)) - - DUM2 = (DUM1+DUM2)/RHO(K) !CONVERT TO KG-1 - -! MAKE SURE THIS VALUE ISN'T GREATER THAN TOTAL NUMBER OF AEROSOL - - DUMACT = MIN((NANEW1+NANEW2)/RHO(K),DUM2) - -! USE LOGNORMAL AEROSOL - SIGVL = 0.0761-1.55E-4*(T3D(K)-TMELT) - AACT = 2.*MW/(RHOW*RR)*SIGVL/T3D(K) - - SM1 = 2./BACT**0.5*(AACT/(3.*RM1))**1.5 - SM2 = 2./BACT**0.5*(AACT/(3.*RM2))**1.5 - -! GET SUPERSATURATION RATIO FROM ABSOLUTE SUPERSATURATION - SMAX = DUM3/QVS(K) - - UU1 = 2.*LOG(SM1/SMAX)/(4.242*LOG(SIG1)) - UU2 = 2.*LOG(SM2/SMAX)/(4.242*LOG(SIG2)) - DUM1 = NANEW1/2.*(1.-DERF1(UU1)) - DUM2 = NANEW2/2.*(1.-DERF1(UU2)) - - DUM2 = (DUM1+DUM2)/RHO(K) !CONVERT TO KG-1 - -! MAKE SURE THIS VALUE ISN'T GREATER THAN TOTAL NUMBER OF AEROSOL - - DUM2 = MIN((NANEW1+NANEW2)/RHO(K),DUM2) - -! MAKE SURE ISN'T GREATER THAN NON-EQUIL. SS - DUM2=MIN(DUM2,DUMACT) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#if (defined CRM && defined MODAL_AERO) - ELSE if (IACT.EQ.3) then - INES =1 -! GET SUPERSATURATION RATIO FROM ABSOLUTE SUPERSATURATION - SMAX = DUM3/QVS(K) - CALL DROP_ACTIVATION_GHAN(DUM, T3D(k), RHO(k), & - DUM2, INES, SMAX, K) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0., DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#endif - END IF ! IACT - END IF ! DUM3/QVS > 1.E-6 - END IF ! IDROP = 1 - -!....................................................................... - ELSE IF (IBASE.EQ.2) THEN - - IF (IACT.EQ.1) THEN -! USE ROGERS AND YAU (1989) TO RELATE NUMBER ACTIVATED TO W -! BASED ON TWOMEY 1959 - - DUM=DUM*100. ! CONVERT FROM M/S TO CM/S - DUM2 = 0.88*C1**(2./(K1+2.))*(7.E-2*DUM**1.5)**(K1/(K1+2.)) - DUM2=DUM2*1.E6 ! CONVERT FROM CM-3 TO M-3 - DUM2=DUM2/RHO(K) ! CONVERT FROM M-3 TO KG-1 -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 - - ELSE IF (IACT.EQ.2) THEN - - SIGVL = 0.0761-1.55E-4*(T3D(K)-TMELT) - AACT = 2.*MW/(RHOW*RR)*SIGVL/T3D(K) - ALPHA = G*MW*XXLV(K)/(CPM(K)*RR*T3D(K)**2)-G*MA/(RR*T3D(K)) - GAMM = RR*T3D(K)/(EVS(K)*MW)+MW*XXLV(K)**2/(CPM(K)*PRES(K)*MA*T3D(K)) - - GG = 1./(RHOW*RR*T3D(K)/(EVS(K)*DV(K)*MW)+ XXLV(K)*RHOW/(KAP(K)*T3D(K))*(XXLV(K)*MW/ & - (T3D(K)*RR)-1.)) - - PSI = 2./3.*(ALPHA*DUM/GG)**0.5*AACT - - ETA1 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW1) - ETA2 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW2) - - SM1 = 2./BACT**0.5*(AACT/(3.*RM1))**1.5 - SM2 = 2./BACT**0.5*(AACT/(3.*RM2))**1.5 - - DUM1 = 1./SM1**2*(F11*(PSI/ETA1)**1.5+F21*(SM1**2/(ETA1+3.*PSI))**0.75) - DUM2 = 1./SM2**2*(F12*(PSI/ETA2)**1.5+F22*(SM2**2/(ETA2+3.*PSI))**0.75) - - SMAX = 1./(DUM1+DUM2)**0.5 - - UU1 = 2.*LOG(SM1/SMAX)/(4.242*LOG(SIG1)) - UU2 = 2.*LOG(SM2/SMAX)/(4.242*LOG(SIG2)) - DUM1 = NANEW1/2.*(1.-DERF1(UU1)) - DUM2 = NANEW2/2.*(1.-DERF1(UU2)) - - DUM2 = (DUM1+DUM2)/RHO(K) !CONVERT TO KG-1 - -! MAKE SURE THIS VALUE ISN'T GREATER THAN TOTAL NUMBER OF AEROSOL - - DUM2 = MIN((NANEW1+NANEW2)/RHO(K),DUM2) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#if (defined CRM && defined MODAL_AERO) - ELSE if (IACT.EQ.3) then - INES = 0 - CALL DROP_ACTIVATION_GHAN(DUM, T3D(k), RHO(k), & - DUM2, INES, SMAX, K) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0., DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#endif - END IF ! IACT - END IF ! IBASE - END IF ! W > 0.001 - END IF ! QC3D > QSMALL - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! SUBLIMATE, MELT, OR EVAPORATE NUMBER CONCENTRATION -! THIS FORMULATION ASSUMES 1:1 RATIO BETWEEN MASS LOSS AND -! LOSS OF NUMBER CONCENTRATION - -! IF (PCC(K).LT.0.) THEN -! DUM = PCC(K)*DT/QC3D(K) -! DUM = MAX(-1.,DUM) -! NSUBC(K) = DUM*NC3D(K)/DT -! END IF - -! UPDATE TENDENCIES - -! NC3DTEN(K) = NC3DTEN(K)+NSUBC(K) - -!..................................................................... -!..................................................................... - ELSE ! TEMPERATURE < 273.15 - -!...................................................................... -!HM ADD, ALLOW FOR CONSTANT DROPLET NUMBER -! INUM = 0, PREDICT DROPLET NUMBER -! INUM = 1, SET CONSTANT DROPLET NUMBER - - IF (INUM.EQ.1) THEN -! CONVERT NDCNST FROM CM-3 TO KG-1 - NC3D(K)=NDCNST*1.E6/RHO(K) - END IF - -! CALCULATE SIZE DISTRIBUTION PARAMETERS -! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE - - NI3D(K) = MAX(0.,NI3D(K)) - NS3D(K) = MAX(0.,NS3D(K)) - NC3D(K) = MAX(0.,NC3D(K)) - NR3D(K) = MAX(0.,NR3D(K)) - NG3D(K) = MAX(0.,NG3D(K)) - -!...................................................................... -! CLOUD ICE - - IF (QI3D(K).GE.QSMALL) THEN - LAMI(K) = (CONS12* & - NI3D(K)/QI3D(K))**(1./DI) - N0I(K) = NI3D(K)*LAMI(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMI(K).LT.LAMMINI) THEN - - LAMI(K) = LAMMINI - - N0I(K) = LAMI(K)**(DI+1.)*QI3D(K)/CONS12 - - NI3D(K) = N0I(K)/LAMI(K) - ELSE IF (LAMI(K).GT.LAMMAXI) THEN - LAMI(K) = LAMMAXI - N0I(K) = LAMI(K)**(DI+1.)*QI3D(K)/CONS12 - - NI3D(K) = N0I(K)/LAMI(K) - END IF - END IF - -!...................................................................... -! RAIN - - IF (QR3D(K).GE.QSMALL) THEN - LAMR(K) = (PI*RHOW*NR3D(K)/QR3D(K))**(1./3.) - N0RR(K) = NR3D(K)*LAMR(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMR(K).LT.LAMMINR) THEN - - LAMR(K) = LAMMINR - - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - ELSE IF (LAMR(K).GT.LAMMAXR) THEN - LAMR(K) = LAMMAXR - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - END IF - END IF - -!...................................................................... -! CLOUD DROPLETS - -! MARTIN ET AL. (1994) FORMULA FOR PGAM - - IF (QC3D(K).GE.QSMALL) THEN - - !bloss: option for fixing pgam - if(dofix_pgam) then - pgam(k) = pgam_fixed - else - -! DUM = PRES(K)/(R*T3D(K)) -! V1.5 -#ifndef CLUBB_CRM - PGAM(K)=0.0005714*(NC3D(K)/1.E6*RHO(K))+0.2714 -#else - if(doclubb_autoin) then - PGAM(K)=0.0005714*(NC3D(K)/1.E6*RHO(K)/max(CFL3D(K), cloud_frac_thresh))+0.2714 - else - PGAM(K)=0.0005714*(NC3D(K)/1.E6*RHO(K))+0.2714 - end if -#endif - - PGAM(K)=1./(PGAM(K)**2)-1. - PGAM(K)=MAX(PGAM(K),2.) - PGAM(K)=MIN(PGAM(K),10.) - - end if -! v1.4 -! interpolate - dumii=int(pgam(k)) - nu(k)=dnu(dumii)+(dnu(dumii+1)-dnu(dumii))* & - (pgam(k)-real(dumii)) - -! CALCULATE LAMC - - LAMC(K) = (CONS26*NC3D(K)*GAMMA(PGAM(K)+4.)/ & - (QC3D(K)*GAMMA(PGAM(K)+1.)))**(1./3.) - -! LAMMIN, 60 MICRON DIAMETER -! LAMMAX, 1 MICRON - - LAMMIN = (PGAM(K)+1.)/60.E-6 - LAMMAX = (PGAM(K)+1.)/1.E-6 - - IF (LAMC(K).LT.LAMMIN) THEN - LAMC(K) = LAMMIN - -#ifndef CLUBB_CRM - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 -#else - if(doclubb_autoin) then - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K)/max(CFL3D(K), cloud_frac_thresh))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 * max(CFL3D(K), cloud_frac_thresh) - else - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - endif -#endif - - ELSE IF (LAMC(K).GT.LAMMAX) THEN - LAMC(K) = LAMMAX -#ifndef CLUBB_CRM - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 -#else - if(doclubb_autoin) then - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K)/max(CFL3D(K), cloud_frac_thresh))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 * max(CFL3D(K), cloud_frac_thresh) - else - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - end if -#endif - - END IF - -! TO CALCULATE DROPLET FREEZING - - CDIST1(K) = NC3D(K)/GAMMA(PGAM(K)+1.) - - END IF - -!...................................................................... -! SNOW - - IF (QNI3D(K).GE.QSMALL) THEN - LAMS(K) = (CONS1*NS3D(K)/QNI3D(K))**(1./DS) - N0S(K) = NS3D(K)*LAMS(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMS(K).LT.LAMMINS) THEN - LAMS(K) = LAMMINS - N0S(K) = LAMS(K)**(DS+1.)*QNI3D(K)/CONS1 - - NS3D(K) = N0S(K)/LAMS(K) - - ELSE IF (LAMS(K).GT.LAMMAXS) THEN - - LAMS(K) = LAMMAXS - N0S(K) = LAMS(K)**(DS+1.)*QNI3D(K)/CONS1 - - NS3D(K) = N0S(K)/LAMS(K) - END IF - END IF - -!...................................................................... -! GRAUPEL - - IF (QG3D(K).GE.QSMALL) THEN - LAMG(K) = (CONS2*NG3D(K)/QG3D(K))**(1./DG) - N0G(K) = NG3D(K)*LAMG(K) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMG(K).LT.LAMMING) THEN - LAMG(K) = LAMMING - N0G(K) = LAMG(K)**(DG+1.)*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - - ELSE IF (LAMG(K).GT.LAMMAXG) THEN - - LAMG(K) = LAMMAXG - N0G(K) = LAMG(K)**(DG+1.)*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - END IF - END IF - -!..................................................................... -! ZERO OUT PROCESS RATES - - MNUCCC(K) = 0. - NNUCCC(K) = 0. - PRC(K) = 0. - NPRC(K) = 0. - NPRC1(K) = 0. - NSAGG(K) = 0. - PSACWS(K) = 0. - NPSACWS(K) = 0. - PSACWI(K) = 0. - NPSACWI(K) = 0. - PRACS(K) = 0. - NPRACS(K) = 0. - NMULTS(K) = 0. - QMULTS(K) = 0. - NMULTR(K) = 0. - QMULTR(K) = 0. - NMULTG(K) = 0. - QMULTG(K) = 0. - NMULTRG(K) = 0. - QMULTRG(K) = 0. - MNUCCR(K) = 0. - NNUCCR(K) = 0. - PRA(K) = 0. - NPRA(K) = 0. - NRAGG(K) = 0. - PRCI(K) = 0. - NPRCI(K) = 0. - PRAI(K) = 0. - NPRAI(K) = 0. - NNUCCD(K) = 0. - MNUCCD(K) = 0. - PCC(K) = 0. - PRE(K) = 0. - PRD(K) = 0. - PRDS(K) = 0. - EPRD(K) = 0. - EPRDS(K) = 0. - NSUBC(K) = 0. - NSUBI(K) = 0. - NSUBS(K) = 0. - NSUBR(K) = 0. - PIACR(K) = 0. - NIACR(K) = 0. - PRACI(K) = 0. - PIACRS(K) = 0. - NIACRS(K) = 0. - PRACIS(K) = 0. -! HM: ADD GRAUPEL PROCESSES - PRACG(K) = 0. - PSACR(K) = 0. - PSACWG(K) = 0. - PGSACW(K) = 0. - PGRACS(K) = 0. - PRDG(K) = 0. - EPRDG(K) = 0. - NPRACG(K) = 0. - NPSACWG(K) = 0. - NSCNG(K) = 0. - NGRACS(K) = 0. - NSUBG(K) = 0. - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! CALCULATION OF MICROPHYSICAL PROCESS RATES -! ACCRETION/AUTOCONVERSION/FREEZING/MELTING/COAG. -!....................................................................... -! FREEZING OF CLOUD DROPLETS -! ONLY ALLOWED BELOW -4 C - IF (QC3D(K).GE.QSMALL .AND. T3D(K).LT.269.15) THEN - -! NUMBER OF CONTACT NUCLEI (M^-3) FROM MEYERS ET AL., 1992 -! FACTOR OF 1000 IS TO CONVERT FROM L^-1 TO M^-3 - -! MEYERS CURVE - - NACNT = EXP(-2.80+0.262*(TMELT-T3D(K)))*1000. - -! COOPER CURVE -! NACNT = 5.*EXP(0.304*(TMELT-T3D(K))) - -! FLECTHER -! NACNT = 0.01*EXP(0.6*(TMELT-T3D(K))) - -! CONTACT FREEZING - -! MEAN FREE PATH - - DUM = 7.37*T3D(K)/(288.*10.*PRES(K))/100. - -! EFFECTIVE DIFFUSIVITY OF CONTACT NUCLEI -! BASED ON BROWNIAN DIFFUSION - - DAP(K) = CONS37*T3D(K)*(1.+DUM/RIN)/MU(K) - - MNUCCC(K) = CONS38*DAP(K)*NACNT*EXP(LOG(CDIST1(K))+ & - LOG(GAMMA(PGAM(K)+5.))-4.*LOG(LAMC(K))) - NNUCCC(K) = 2.*PI*DAP(K)*NACNT*CDIST1(K)* & - GAMMA(PGAM(K)+2.)/ & - LAMC(K) - -! IMMERSION FREEZING (BIGG 1953) - - MNUCCC(K) = MNUCCC(K)+CONS39* & - EXP(LOG(CDIST1(K))+LOG(GAMMA(7.+PGAM(K)))-6.*LOG(LAMC(K)))* & - EXP(AIMM*(TMELT-T3D(K))) - - NNUCCC(K) = NNUCCC(K)+ & - CONS40*EXP(LOG(CDIST1(K))+LOG(GAMMA(PGAM(K)+4.))-3.*LOG(LAMC(K))) & - *EXP(AIMM*(TMELT-T3D(K))) - -! PUT IN A CATCH HERE TO PREVENT DIVERGENCE BETWEEN NUMBER CONC. AND -! MIXING RATIO, SINCE STRICT CONSERVATION NOT CHECKED FOR NUMBER CONC - - NNUCCC(K) = MIN(NNUCCC(K),NC3D(K)/DT) - - END IF - -#ifdef CLUBB_CRM -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! For the case of clex9_oct14, we need to decrease the ice ! -! nucleation in order for the cloud to persist for realistic ! -! lengths. It is suggested to reduce by a factor of 100 ! -! This coefficient can be changed in the subroutine ! -! init_microphys of the microphys_driver subroutine ! -! ! - NNUCCC(K)=NNUCCC(K)*NNUCCC_REDUCE_COEF -! ! -! Change made by Marc Pilon on 11/16/11 ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#endif /* CLUBB_CRM */ - - - - -!................................................................. -!....................................................................... -! AUTOCONVERSION OF CLOUD LIQUID WATER TO RAIN -! FORMULA FROM BEHENG (1994) -! USING NUMERICAL SIMULATION OF STOCHASTIC COLLECTION EQUATION -! AND INITIAL CLOUD DROPLET SIZE DISTRIBUTION SPECIFIED -! AS A GAMMA DISTRIBUTION - -! USE MINIMUM VALUE OF 1.E-6 TO PREVENT FLOATING POINT ERROR - - IF (QC3D(K).GE.1.E-6) THEN - -! HM ADD 12/13/06, REPLACE WITH NEWER FORMULA -! FROM KHAIROUTDINOV AND KOGAN 2000, MWR - - IF (IRAIN.EQ.0) THEN - PRC(K)=1350.*QC3D(K)**2.47* & - (NC3D(K)/1.e6*RHO(K))**(-1.79) - -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - PRC(K)=PRC(K) * gamma(RELVAR(K)+2.47)/(gamma(RELVAR(K))*RELVAR(K)**2.47) - PRC(K)=PRC(K) * CFL3D(K)**0.32 ! CFL3D**(1.79-2.47+1) - end if -#endif - -! note: nprc1 is change in Nr, -! nprc is change in Nc - - NPRC1(K) = PRC(K)/CONS29 - NPRC(K) = PRC(K)/(QC3D(K)/NC3D(K)) - - NPRC(K) = MIN(NPRC(K),NC3D(K)/DT) - - ELSE IF (IRAIN.EQ.1) THEN - -! v1.4 -! replace with seifert and beheng - - dum = 1.-qc3d(k)/(qc3d(k)+qr3d(k)) - dum1 = 600.*dum**0.68*(1.-dum**0.68)**3 - - prc(k) = 9.44e9/(20.*2.6e-7)* & - (nu(k)+2.)*(nu(k)+4.)/(nu(k)+1.)**2* & - (rho(k)*qc3d(k)/1000.)**4/(rho(k)*nc3d(k)/1.e6)**2* & - (1.+dum1/(1.-dum)**2)*1000./rho(k) - - nprc(k) = prc(k)*2./2.6e-7*1000. - nprc1(k) = 0.5*nprc(k) - - END IF - END IF - -!....................................................................... -! SELF-COLLECTION OF DROPLET NOT INCLUDED IN KK2000 SCHEME - -! SNOW AGGREGATION FROM PASSARELLI, 1978, USED BY REISNER, 1998 -! THIS IS HARD-WIRED FOR BS = 0.4 FOR NOW - - IF (QNI3D(K).GE.1.E-8) THEN - NSAGG(K) = CONS15*ASN(K)*RHO(K)** & - ((2.+BS)/3.)*QNI3D(K)**((2.+BS)/3.)* & - (NS3D(K)*RHO(K))**((4.-BS)/3.)/ & - (RHO(K)) - END IF - -!....................................................................... -! ACCRETION OF CLOUD DROPLETS ONTO SNOW/GRAUPEL -! HERE USE CONTINUOUS COLLECTION EQUATION WITH -! SIMPLE GRAVITATIONAL COLLECTION KERNEL IGNORING - -! SNOW - - IF (QNI3D(K).GE.1.E-8 .AND. QC3D(K).GE.QSMALL) THEN - - PSACWS(K) = CONS13*ASN(K)*QC3D(K)*RHO(K)* & - N0S(K)/ & - LAMS(K)**(BS+3.) - NPSACWS(K) = CONS13*ASN(K)*NC3D(K)*RHO(K)* & - N0S(K)/ & - LAMS(K)**(BS+3.) - - END IF - -!............................................................................ -! COLLECTION OF CLOUD WATER BY GRAUPEL - - IF (QG3D(K).GE.1.E-8 .AND. QC3D(K).GE.QSMALL) THEN - - PSACWG(K) = CONS14*AGN(K)*QC3D(K)*RHO(K)* & - N0G(K)/ & - LAMG(K)**(BG+3.) - NPSACWG(K) = CONS14*AGN(K)*NC3D(K)*RHO(K)* & - N0G(K)/ & - LAMG(K)**(BG+3.) - END IF - -!....................................................................... -! HM, ADD 12/13/06 -! CLOUD ICE COLLECTING DROPLETS, ASSUME THAT CLOUD ICE MEAN DIAM > 100 MICRON -! BEFORE RIMING CAN OCCUR -! ASSUME THAT RIME COLLECTED ON CLOUD ICE DOES NOT LEAD -! TO HALLET-MOSSOP SPLINTERING - - IF (QI3D(K).GE.1.E-8 .AND. QC3D(K).GE.QSMALL) THEN - -! PUT IN SIZE DEPENDENT COLLECTION EFFICIENCY BASED ON STOKES LAW -! FROM THOMPSON ET AL. 2004, MWR - - IF (1./LAMI(K).GE.100.E-6) THEN - - PSACWI(K) = CONS16*AIN(K)*QC3D(K)*RHO(K)* & - N0I(K)/ & - LAMI(K)**(BI+3.) - NPSACWI(K) = CONS16*AIN(K)*NC3D(K)*RHO(K)* & - N0I(K)/ & - LAMI(K)**(BI+3.) - END IF - END IF - -!....................................................................... -! ACCRETION OF RAIN WATER BY SNOW -! FORMULA FROM IKAWA AND SAITO, 1991, USED BY REISNER ET AL, 1998 - - IF (QR3D(K).GE.1.E-8.AND.QNI3D(K).GE.1.E-8) THEN - - UMS = ASN(K)*CONS3/(LAMS(K)**BS) - UMR = ARN(K)*CONS4/(LAMR(K)**BR) - UNS = ASN(K)*CONS5/LAMS(K)**BS - UNR = ARN(K)*CONS6/LAMR(K)**BR - -! SET REASLISTIC LIMITS ON FALLSPEEDS -! bug fix, 10/08/09 - dum=(rhosu/rho(k))**0.54 - UMS=MIN(UMS,1.2*dum) - UNS=MIN(UNS,1.2*dum) - UMR=MIN(UMR,9.1*dum) - UNR=MIN(UNR,9.1*dum) - - PRACS(K) = CONS41*(((1.2*UMR-0.95*UMS)**2+ & - 0.08*UMS*UMR)**0.5*RHO(K)* & - N0RR(K)*N0S(K)/LAMR(K)**3* & - (5./(LAMR(K)**3*LAMS(K))+ & - 2./(LAMR(K)**2*LAMS(K)**2)+ & - 0.5/(LAMR(k)*LAMS(k)**3))) - - NPRACS(K) = CONS32*RHO(K)*(1.7*(UNR-UNS)**2+ & - 0.3*UNR*UNS)**0.5*N0RR(K)*N0S(K)* & - (1./(LAMR(K)**3*LAMS(K))+ & - 1./(LAMR(K)**2*LAMS(K)**2)+ & - 1./(LAMR(K)*LAMS(K)**3)) - -! MAKE SURE PRACS DOESN'T EXCEED TOTAL RAIN MIXING RATIO -! AS THIS MAY OTHERWISE RESULT IN TOO MUCH TRANSFER OF WATER DURING -! RIME-SPLINTERING - - PRACS(K) = MIN(PRACS(K),QR3D(K)/DT) - -! COLLECTION OF SNOW BY RAIN - NEEDED FOR GRAUPEL CONVERSION CALCULATIONS -! ONLY CALCULATE IF SNOW AND RAIN MIXING RATIOS EXCEED 0.1 G/KG - -! V1.3 -! ASSUME COLLECTION OF SNOW BY RAIN PRODUCES GRAUPEL NOT HAIL - -! V1.5 -! IF (IHAIL.EQ.0) THEN - IF (QNI3D(K).GE.0.1E-3.AND.QR3D(K).GE.0.1E-3) THEN - PSACR(K) = CONS31*(((1.2*UMR-0.95*UMS)**2+ & - 0.08*UMS*UMR)**0.5*RHO(K)* & - N0RR(K)*N0S(K)/LAMS(K)**3* & - (5./(LAMS(K)**3*LAMR(K))+ & - 2./(LAMS(K)**2*LAMR(K)**2)+ & - 0.5/(LAMS(K)*LAMR(K)**3))) - END IF -! END IF - - END IF - -!....................................................................... - -! COLLECTION OF RAINWATER BY GRAUPEL, FROM IKAWA AND SAITO 1990, -! USED BY REISNER ET AL 1998 - IF (QR3D(K).GE.1.E-8.AND.QG3D(K).GE.1.E-8) THEN - - UMG = AGN(K)*CONS7/(LAMG(K)**BG) - UMR = ARN(K)*CONS4/(LAMR(K)**BR) - UNG = AGN(K)*CONS8/LAMG(K)**BG - UNR = ARN(K)*CONS6/LAMR(K)**BR - -! SET REASLISTIC LIMITS ON FALLSPEEDS -! bug fix, 10/08/09 - dum=(rhosu/rho(k))**0.54 - UMG=MIN(UMG,20.*dum) - UNG=MIN(UNG,20.*dum) - UMR=MIN(UMR,9.1*dum) - UNR=MIN(UNR,9.1*dum) - - PRACG(K) = CONS41*(((1.2*UMR-0.95*UMG)**2+ & - 0.08*UMG*UMR)**0.5*RHO(K)* & - N0RR(K)*N0G(K)/LAMR(K)**3* & - (5./(LAMR(K)**3*LAMG(K))+ & - 2./(LAMR(K)**2*LAMG(K)**2)+ & - 0.5/(LAMR(k)*LAMG(k)**3))) - - NPRACG(K) = CONS32*RHO(K)*(1.7*(UNR-UNG)**2+ & - 0.3*UNR*UNG)**0.5*N0RR(K)*N0G(K)* & - (1./(LAMR(K)**3*LAMG(K))+ & - 1./(LAMR(K)**2*LAMG(K)**2)+ & - 1./(LAMR(K)*LAMG(K)**3)) - -! MAKE SURE PRACG DOESN'T EXCEED TOTAL RAIN MIXING RATIO -! AS THIS MAY OTHERWISE RESULT IN TOO MUCH TRANSFER OF WATER DURING -! RIME-SPLINTERING - - PRACG(K) = MIN(PRACG(K),QR3D(K)/DT) - - END IF - -!....................................................................... -! RIME-SPLINTERING - SNOW -! HALLET-MOSSOP (1974) -! NUMBER OF SPLINTERS FORMED IS BASED ON MASS OF RIMED WATER - -! DUM1 = MASS OF INDIVIDUAL SPLINTERS - -! HM ADD THRESHOLD SNOW AND DROPLET MIXING RATIO FOR RIME-SPLINTERING -! TO LIMIT RIME-SPLINTERING IN STRATIFORM CLOUDS -! THESE THRESHOLDS CORRESPOND WITH GRAUPEL THRESHOLDS IN RH 1984 - -!v1.4 - IF (QNI3D(K).GE.0.1E-3) THEN - IF (QC3D(K).GE.0.5E-3.OR.QR3D(K).GE.0.1E-3) THEN - IF (PSACWS(K).GT.0..OR.PRACS(K).GT.0.) THEN - IF (T3D(K).LT.270.16 .AND. T3D(K).GT.265.16) THEN - - IF (T3D(K).GT.270.16) THEN - FMULT = 0. - ELSE IF (T3D(K).LE.270.16.AND.T3D(K).GT.268.16) THEN - FMULT = (270.16-T3D(K))/2. - ELSE IF (T3D(K).GE.265.16.AND.T3D(K).LE.268.16) THEN - FMULT = (T3D(K)-265.16)/3. - ELSE IF (T3D(K).LT.265.16) THEN - FMULT = 0. - END IF - -! 1000 IS TO CONVERT FROM KG TO G - -! SPLINTERING FROM DROPLETS ACCRETED ONTO SNOW - - IF (PSACWS(K).GT.0.) THEN - NMULTS(K) = 35.E4*PSACWS(K)*FMULT*1000. - QMULTS(K) = NMULTS(K)*MMULT - -! CONSTRAIN SO THAT TRANSFER OF MASS FROM SNOW TO ICE CANNOT BE MORE MASS -! THAN WAS RIMED ONTO SNOW - - QMULTS(K) = MIN(QMULTS(K),PSACWS(K)) - PSACWS(K) = PSACWS(K)-QMULTS(K) - - END IF - -! RIMING AND SPLINTERING FROM ACCRETED RAINDROPS - - IF (PRACS(K).GT.0.) THEN - NMULTR(K) = 35.E4*PRACS(K)*FMULT*1000. - QMULTR(K) = NMULTR(K)*MMULT - -! CONSTRAIN SO THAT TRANSFER OF MASS FROM SNOW TO ICE CANNOT BE MORE MASS -! THAN WAS RIMED ONTO SNOW - - QMULTR(K) = MIN(QMULTR(K),PRACS(K)) - - PRACS(K) = PRACS(K)-QMULTR(K) - - END IF - - END IF - END IF - END IF - END IF - -!....................................................................... -! RIME-SPLINTERING - GRAUPEL -! HALLET-MOSSOP (1974) -! NUMBER OF SPLINTERS FORMED IS BASED ON MASS OF RIMED WATER - -! DUM1 = MASS OF INDIVIDUAL SPLINTERS - -! HM ADD THRESHOLD SNOW MIXING RATIO FOR RIME-SPLINTERING -! TO LIMIT RIME-SPLINTERING IN STRATIFORM CLOUDS - -! V1.3 -! ONLY CALCULATE FOR GRAUPEL NOT HAIL -! V1.5 -! IF (IHAIL.EQ.0) THEN -! v1.4 - IF (QG3D(K).GE.0.1E-3) THEN - IF (QC3D(K).GE.0.5E-3.OR.QR3D(K).GE.0.1E-3) THEN - IF (PSACWG(K).GT.0..OR.PRACG(K).GT.0.) THEN - IF (T3D(K).LT.270.16 .AND. T3D(K).GT.265.16) THEN - - IF (T3D(K).GT.270.16) THEN - FMULT = 0. - ELSE IF (T3D(K).LE.270.16.AND.T3D(K).GT.268.16) THEN - FMULT = (270.16-T3D(K))/2. - ELSE IF (T3D(K).GE.265.16.AND.T3D(K).LE.268.16) THEN - FMULT = (T3D(K)-265.16)/3. - ELSE IF (T3D(K).LT.265.16) THEN - FMULT = 0. - END IF - -! 1000 IS TO CONVERT FROM KG TO G - -! SPLINTERING FROM DROPLETS ACCRETED ONTO GRAUPEL - - IF (PSACWG(K).GT.0.) THEN - NMULTG(K) = 35.E4*PSACWG(K)*FMULT*1000. - QMULTG(K) = NMULTG(K)*MMULT - -! CONSTRAIN SO THAT TRANSFER OF MASS FROM GRAUPEL TO ICE CANNOT BE MORE MASS -! THAN WAS RIMED ONTO GRAUPEL - - QMULTG(K) = MIN(QMULTG(K),PSACWG(K)) - PSACWG(K) = PSACWG(K)-QMULTG(K) - - END IF - -! RIMING AND SPLINTERING FROM ACCRETED RAINDROPS - - IF (PRACG(K).GT.0.) THEN - NMULTRG(K) = 35.E4*PRACG(K)*FMULT*1000. - QMULTRG(K) = NMULTRG(K)*MMULT - -! CONSTRAIN SO THAT TRANSFER OF MASS FROM GRAUPEL TO ICE CANNOT BE MORE MASS -! THAN WAS RIMED ONTO GRAUPEL - - QMULTRG(K) = MIN(QMULTRG(K),PRACG(K)) - PRACG(K) = PRACG(K)-QMULTRG(K) - - END IF - - END IF - END IF - END IF - END IF -! END IF - -!........................................................................ -! CONVERSION OF RIMED CLOUD WATER ONTO SNOW TO GRAUPEL -! ASSUME CONVERTED SNOW FORMS GRAUPEL NOT HAIL -! HAIL ASSUMED TO ONLY FORM BY FREEZING OF RAIN -! OR COLLISIONS OF RAIN WITH CLOUD ICE - -! V1.3 -! V1.5 -! IF (IHAIL.EQ.0) THEN - IF (PSACWS(K).GT.0.) THEN -! ONLY ALLOW CONVERSION IF QNI > 0.1 AND QC > 0.5 G/KG FOLLOWING RUTLEDGE AND HOBBS (1984) - IF (QNI3D(K).GE.0.1E-3.AND.QC3D(K).GE.0.5E-3) THEN - -! PORTION OF RIMING CONVERTED TO GRAUPEL (REISNER ET AL. 1998, ORIGINALLY IS1991) - PGSACW(K) = MIN(PSACWS(K),CONS17*DT*N0S(K)*QC3D(K)*QC3D(K)* & - ASN(K)*ASN(K)/ & - (RHO(K)*LAMS(K)**(2.*BS+2.))) - -! MIX RAT CONVERTED INTO GRAUPEL AS EMBRYO (REISNER ET AL. 1998, ORIG M1990) - DUM = MAX(RHOSN/(RHOG-RHOSN)*PGSACW(K),0.) - -! NUMBER CONCENTRAITON OF EMBRYO GRAUPEL FROM RIMING OF SNOW - NSCNG(K) = DUM/MG0*RHO(K) -! LIMIT MAX NUMBER CONVERTED TO SNOW NUMBER - NSCNG(K) = MIN(NSCNG(K),NS3D(K)/DT) - -! PORTION OF RIMING LEFT FOR SNOW - PSACWS(K) = PSACWS(K) - PGSACW(K) - END IF - END IF - -! CONVERSION OF RIMED RAINWATER ONTO SNOW CONVERTED TO GRAUPEL - - IF (PRACS(K).GT.0.) THEN -! ONLY ALLOW CONVERSION IF QNI > 0.1 AND QR > 0.1 G/KG FOLLOWING RUTLEDGE AND HOBBS (1984) - IF (QNI3D(K).GE.0.1E-3.AND.QR3D(K).GE.0.1E-3) THEN -! PORTION OF COLLECTED RAINWATER CONVERTED TO GRAUPEL (REISNER ET AL. 1998) - DUM = CONS18*(4./LAMS(K))**3*(4./LAMS(K))**3 & - /(CONS18*(4./LAMS(K))**3*(4./LAMS(K))**3+ & - CONS19*(4./LAMR(K))**3*(4./LAMR(K))**3) - DUM=MIN(DUM,1.) - DUM=MAX(DUM,0.) - PGRACS(K) = (1.-DUM)*PRACS(K) - NGRACS(K) = (1.-DUM)*NPRACS(K) -! LIMIT MAX NUMBER CONVERTED TO MIN OF EITHER RAIN OR SNOW NUMBER CONCENTRATION - NGRACS(K) = MIN(NGRACS(K),NR3D(K)/DT) - NGRACS(K) = MIN(NGRACS(K),NS3D(K)/DT) - -! AMOUNT LEFT FOR SNOW PRODUCTION - PRACS(K) = PRACS(K) - PGRACS(K) - NPRACS(K) = NPRACS(K) - NGRACS(K) -! CONVERSION TO GRAUPEL DUE TO COLLECTION OF SNOW BY RAIN - PSACR(K)=PSACR(K)*(1.-DUM) - END IF - END IF -! END IF - -!....................................................................... -! FREEZING OF RAIN DROPS -! FREEZING ALLOWED BELOW -4 C - - IF (T3D(K).LT.269.15.AND.QR3D(K).GE.QSMALL) THEN - -! IMMERSION FREEZING (BIGG 1953) - MNUCCR(K) = CONS20*NR3D(K)*EXP(AIMM*(TMELT-T3D(K)))/LAMR(K)**3 & - /LAMR(K)**3 - - NNUCCR(K) = PI*NR3D(K)*BIMM*EXP(AIMM*(TMELT-T3D(K)))/LAMR(K)**3 - -! PREVENT DIVERGENCE BETWEEN MIXING RATIO AND NUMBER CONC - NNUCCR(K) = MIN(NNUCCR(K),NR3D(K)/DT) - - END IF - -!....................................................................... -! ACCRETION OF CLOUD LIQUID WATER BY RAIN -! CONTINUOUS COLLECTION EQUATION WITH -! GRAVITATIONAL COLLECTION KERNEL, DROPLET FALL SPEED NEGLECTED - - IF (QR3D(K).GE.1.E-8 .AND. QC3D(K).GE.1.E-8) THEN - -! 12/13/06 HM ADD, REPLACE WITH NEWER FORMULA FROM -! KHAIROUTDINOV AND KOGAN 2000, MWR - - IF (IRAIN.EQ.0) THEN - - DUM=(QC3D(K)*QR3D(K)) - PRA(K) = 67.*(DUM)**1.15 -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - PRA(K)=PRA(K) * accre_enhan(K)*gamma(RELVAR(K)+1.15)/(gamma(RELVAR(K))*RELVAR(K)**1.15) - PRA(K) = PRA(K) /(max(CLDMAXR(K), cloud_frac_thresh))**1.15 ! PRA = (QC3D/CFL3D * QR3D/CLDMAXR * CFL3D)**1.15 - end if -#endif - NPRA(K) = PRA(K)/(QC3D(K)/NC3D(K)) - - ELSE IF (IRAIN.EQ.1) THEN - -! v1.4 -! seifert and beheng (2001) formulation - - dum = 1.-qc3d(k)/(qc3d(k)+qr3d(k)) - dum1 = (dum/(dum+5.e-4))**4 - pra(k) = 5.78e3*rho(k)/1000.*qc3d(k)*qr3d(k)*dum1 - npra(k) = pra(k)*rho(k)/1000.*(nc3d(k)*rho(k)/1.e6)/ & - (qc3d(k)*rho(k)/1000.)*1.e6/rho(k) - - END IF - END IF -!....................................................................... -! SELF-COLLECTION OF RAIN DROPS -! FROM BEHENG(1994) -! FROM NUMERICAL SIMULATION OF THE STOCHASTIC COLLECTION EQUATION -! AS DESCRINED ABOVE FOR AUTOCONVERSION - -! v1.4 replace with seifert and beheng (2001) - - IF (QR3D(K).GE.1.E-8) THEN -! include breakup add 10/09/09 - dum1=300.e-6 - if (1./lamr(k).lt.dum1) then - dum=1. - else if (1./lamr(k).ge.dum1) then - dum=2.-exp(2300.*(1./lamr(k)-dum1)) - end if -! NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K) - NRAGG(K) = -5.78*dum*NR3D(K)*QR3D(K)*RHO(K) - END IF - -!....................................................................... -! AUTOCONVERSION OF CLOUD ICE TO SNOW -! FOLLOWING HARRINGTON ET AL. (1995) WITH MODIFICATION -! HERE IT IS ASSUMED THAT AUTOCONVERSION CAN ONLY OCCUR WHEN THE -! ICE IS GROWING, I.E. IN CONDITIONS OF ICE SUPERSATURATION -#ifndef CLUBB_CRM - IF (QI3D(K).GE.1.E-8 .AND.QVQVSI(K).GE.1.) THEN - -! COFFI = 2./LAMI(K) -! IF (COFFI.GE.DCS) THEN - NPRCI(K) = CONS21*(QV3D(K)-QVI(K))*RHO(K) & - *N0I(K)*EXP(-LAMI(K)*DCS)*DV(K)/ABI(K) - PRCI(K) = CONS22*NPRCI(K) - NPRCI(K) = MIN(NPRCI(K),NI3D(K)/DT) - -! END IF - END IF -#else - IF(.not.doclubb_gridmean) THEN - IF (QI3D(K).GE.1.E-8 .AND.QVQVSI(K).GE.1.) THEN - -! COFFI = 2./LAMI(K) -! IF (COFFI.GE.DCS) THEN - NPRCI(K) = CONS21*(QV3D(K)-QVI(K))*RHO(K) & - *N0I(K)*EXP(-LAMI(K)*DCS)*DV(K)/ABI(K) - PRCI(K) = CONS22*NPRCI(K) - NPRCI(K) = MIN(NPRCI(K),NI3D(K)/DT) - -! END IF - END IF - ELSE ! doclubb_gridmean - IF (QI3D(K).GE.1.E-8) THEN -! inside liquid clouds, using QVS - NPRCI(k) = CONS21*(QVS(K)-QVI(K))*RHO(K) & - *N0I(K)*EXP(-LAMI(K)*DCS)*DV(K)/ABI(K) * CFL3D(K) -! outside liquid clouds, using ambient QV3D - IF(QVQVSI(K).GE.1.) THEN - NPRCI(k) = NPRCI(k) + CONS21*(QV3D(K)-QVI(K))*RHO(K) & - *N0I(K)*EXP(-LAMI(K)*DCS)*DV(K)/ABI(K) * (CFI3D(K)-CFL3D(K)) - ENDIF - NPRCI(K) = NPRCI(K)/max(CFI3D(K), cloud_frac_thresh) - PRCI(K) = CONS22*NPRCI(K) - NPRCI(K) = MIN(NPRCI(K),NI3D(K)/DT) - END IF - END IF -#endif - -!....................................................................... -! ACCRETION OF CLOUD ICE BY SNOW -! FOR THIS CALCULATION, IT IS ASSUMED THAT THE VS >> VI -! AND DS >> DI FOR CONTINUOUS COLLECTION - - IF (QNI3D(K).GE.1.E-8 .AND. QI3D(K).GE.QSMALL) THEN - PRAI(K) = CONS23*ASN(K)*QI3D(K)*RHO(K)*N0S(K)/ & - LAMS(K)**(BS+3.) - NPRAI(K) = CONS23*ASN(K)*NI3D(K)* & - RHO(K)*N0S(K)/ & - LAMS(K)**(BS+3.) - NPRAI(K)=MIN(NPRAI(K),NI3D(K)/DT) - END IF - -!....................................................................... -! HM, ADD 12/13/06, COLLISION OF RAIN AND ICE TO PRODUCE SNOW OR GRAUPEL -! FOLLOWS REISNER ET AL. 1998 -! ASSUMED FALLSPEED AND SIZE OF ICE CRYSTAL << THAN FOR RAIN - - IF (QR3D(K).GE.1.E-8.AND.QI3D(K).GE.1.E-8.AND.T3D(K).LE.TMELT) THEN - -! ALLOW GRAUPEL FORMATION FROM RAIN-ICE COLLISIONS ONLY IF RAIN MIXING RATIO > 0.1 G/KG, -! OTHERWISE ADD TO SNOW - - IF (QR3D(K).GE.0.1E-3) THEN - NIACR(K)=CONS24*NI3D(K)*N0RR(K)*ARN(K) & - /LAMR(K)**(BR+3.)*RHO(K) - PIACR(K)=CONS25*NI3D(K)*N0RR(K)*ARN(K) & - /LAMR(K)**(BR+3.)/LAMR(K)**3*RHO(K) - PRACI(K)=CONS24*QI3D(K)*N0RR(K)*ARN(K)/ & - LAMR(K)**(BR+3.)*RHO(K) - NIACR(K)=MIN(NIACR(K),NR3D(K)/DT) - NIACR(K)=MIN(NIACR(K),NI3D(K)/DT) - ELSE - NIACRS(K)=CONS24*NI3D(K)*N0RR(K)*ARN(K) & - /LAMR(K)**(BR+3.)*RHO(K) - PIACRS(K)=CONS25*NI3D(K)*N0RR(K)*ARN(K) & - /LAMR(K)**(BR+3.)/LAMR(K)**3*RHO(K) - PRACIS(K)=CONS24*QI3D(K)*N0RR(K)*ARN(K)/ & - LAMR(K)**(BR+3.)*RHO(K) - NIACRS(K)=MIN(NIACRS(K),NR3D(K)/DT) - NIACRS(K)=MIN(NIACRS(K),NI3D(K)/DT) - END IF - END IF - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! NUCLEATION OF CLOUD ICE FROM HOMOGENEOUS AND HETEROGENEOUS FREEZING ON AEROSOL - - IF (INUC.EQ.0) THEN - -! FREEZING OF AEROSOL ONLY ALLOWED BELOW -5 C -! AND ABOVE DELIQUESCENCE THRESHOLD OF 80% -! AND ABOVE ICE SATURATION - -! add threshold according to Greg Thomspon - - if ((QVQVS(K).GE.0.999.and.T3D(K).le.265.15).or. & - QVQVSI(K).ge.1.08) then - -! hm, modify dec. 5, 2006, replace with cooper curve - kc2 = 0.005*exp(0.304*(TMELT-T3D(K)))*1000. ! convert from L-1 to m-3 -! limit to 500 L-1 - kc2 = min(kc2,500.e3) - kc2=MAX(kc2/rho(k),0.) ! convert to kg-1 - - IF (KC2.GT.NI3D(K)+NS3D(K)+NG3D(K)) THEN - NNUCCD(K) = (KC2-NI3D(K)-NS3D(K)-NG3D(K))/DT - MNUCCD(K) = NNUCCD(K)*MI0 - END IF - - END IF - - ELSE IF (INUC.EQ.1) THEN - - IF (T3D(K).LT.TMELT.AND.QVQVSI(K).GT.1.) THEN - - KC2 = 0.16*1000./RHO(K) ! CONVERT FROM L-1 TO KG-1 - IF (KC2.GT.NI3D(K)+NS3D(K)+NG3D(K)) THEN - NNUCCD(K) = (KC2-NI3D(K)-NS3D(K)-NG3D(K))/DT - MNUCCD(K) = NNUCCD(K)*MI0 - END IF - END IF - - END IF - -#ifdef CLUBB_CRM -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! For the case of clex9_oct14, we need to decrease the ice ! -! nucleation in order for the cloud to persist for realistic ! -! lengths. It is suggested to reduce by a factor of 100 ! -! This coefficent can be changed in subroutine init_microphys ! -! in the microphys_driver subroutine. ! -! ! - NNUCCD(K)=NNUCCD(K)*NNUCCD_REDUCE_COEF -! -! Change made by Marc Pilon on 11/16/11 ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#endif /* CLUBB_CRM */ - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - 101 CONTINUE - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! CALCULATE EVAP/SUB/DEP TERMS FOR QI,QNI,QR - -! NO VENTILATION FOR CLOUD ICE - - IF (QI3D(K).GE.QSMALL) THEN - - EPSI = 2.*PI*N0I(K)*RHO(K)*DV(K)/(LAMI(K)*LAMI(K)) - - ELSE - EPSI = 0. - END IF - - IF (QNI3D(K).GE.QSMALL) THEN - EPSS = 2.*PI*N0S(K)*RHO(K)*DV(K)* & - (F1S/(LAMS(K)*LAMS(K))+ & - F2S*(ASN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS10/ & - (LAMS(K)**CONS35)) - ELSE - EPSS = 0. - END IF - - IF (QG3D(K).GE.QSMALL) THEN - EPSG = 2.*PI*N0G(K)*RHO(K)*DV(K)* & - (F1S/(LAMG(K)*LAMG(K))+ & - F2S*(AGN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS11/ & - (LAMG(K)**CONS36)) - - - ELSE - EPSG = 0. - END IF - - IF (QR3D(K).GE.QSMALL) THEN - EPSR = 2.*PI*N0RR(K)*RHO(K)*DV(K)* & - (F1R/(LAMR(K)*LAMR(K))+ & - F2R*(ARN(K)*RHO(K)/MU(K))**0.5* & - SC(K)**(1./3.)*CONS9/ & - (LAMR(K)**CONS34)) - ELSE - EPSR = 0. - END IF - -! ONLY INCLUDE REGION OF ICE SIZE DIST < DCS -! DUM IS FRACTION OF D*N(D) < DCS - -! LOGIC BELOW FOLLOWS THAT OF HARRINGTON ET AL. 1995 (JAS) - IF (QI3D(K).GE.QSMALL) THEN - DUM=(1.-EXP(-LAMI(K)*DCS)*(1.+LAMI(K)*DCS)) - PRD(K) = EPSI*(QV3D(K)-QVI(K))/ABI(K)*DUM -#ifdef CLUBB_CRM - if(doclubb_gridmean) then -! For ice clouds outside liquid clouds, using ambient QV - PRD(K) = PRD(K) * (CFI3D(K)-CFL3D(K)) -! For ice clouds inside liquid clouds, using saturation vapor pressure over liquid - PRD(K) = PRD(K) + EPSI*(QVS(K)-QVI(K))/ABI(K)*DUM * CFL3D(K) - PRD(K) = PRD(K) / max(CFI3D(K), cloud_frac_thresh) - end if -#endif - ELSE - DUM=0. - END IF -! ADD DEPOSITION IN TAIL OF ICE SIZE DIST TO SNOW IF SNOW IS PRESENT - IF (QNI3D(K).GE.QSMALL) THEN - PRDS(K) = EPSS*(QV3D(K)-QVI(K))/ABI(K)+ & - EPSI*(QV3D(K)-QVI(K))/ABI(K)*(1.-DUM) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - PRDS(K) = (EPSS*(QV3D(K)-QVI(K))/ABI(K)*(CLDMAXALL(K)-CFL3D(K))+ & - EPSS*(QVS(K)-QVI(K))/ABI(K) * CFL3D(K))/max(CLDMAXALL(K), cloud_frac_thresh) & - + (EPSI*(QV3D(K)-QVI(K))/ABI(K)*(1.-DUM)*(CFI3D(K)-CFL3D(K))+ & - EPSI*(QVS(K)-QVI(K))/ABI(K)*(1.-DUM)*CFL3D(K))/max(CFI3D(K), cloud_frac_thresh) - end if -#endif -! OTHERWISE ADD TO CLOUD ICE - ELSE -#ifndef CLUBB_CRM - PRD(K) = PRD(K)+EPSI*(QV3D(K)-QVI(K))/ABI(K)*(1.-DUM) -#else - if(.not.doclubb_gridmean) then - PRD(K) = PRD(K)+EPSI*(QV3D(K)-QVI(K))/ABI(K)*(1.-DUM) - else - PRD(K) = PRD(K)+(EPSI*(QV3D(K)-QVI(K))/ABI(K)*(1.-DUM) * (CFI3D(K) - CFL3D(K)) & - + EPSI*(QVS(K)-QVI(K))/ABI(K)*(1.-DUM) * CFL3D(K))/max(CFI3D(K), cloud_frac_thresh) - end if -#endif - END IF - -! VAPOR DPEOSITION ON GRAUPEL - PRDG(K) = EPSG*(QV3D(K)-QVI(K))/ABI(K) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then -! For graupel outside liquid clouds, using ambient QV - PRDG(K) = PRDG(K)*(CLDMAXALL(K)-CFL3D(K)) -! For graueple insdie liquid clouds, using QVS - PRDG(K) = PRDG(K) + EPSG*(QVS(K)-QVI(K))/ABI(K) * CFL3D(K) - PRDG(K) = PRDG(K) / max(CLDMAXALL(K), cloud_frac_thresh) - end if -#endif - -! NO CONDENSATION ONTO RAIN, ONLY EVAP - - IF (QV3D(K).LT.QVS(K)) THEN - PRE(K) = EPSR*(QV3D(K)-QVS(K))/AB(K) - PRE(K) = MIN(PRE(K),0.) - ELSE - PRE(K) = 0. - END IF - -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - PRE(K) = PRE(K) * max(CLDMAXR(K)-CFL3D(K), 0.0)/max(CLDMAXR(K), cloud_frac_thresh) - if(CFL3D(K).gt.0.10) then ! when there is enough liquid present, - ! no evaporation of rain is allowed - PRE(K) = 0.0 - end if - - end if -#endif - -! MAKE SURE NOT PUSHED INTO ICE SUPERSAT/SUBSAT -! FORMULA FROM REISNER 2 SCHEME - - DUM = (QV3D(K)-QVI(K))/DT - - FUDGEF = 0.9999 - SUM_DEP = PRD(K)+PRDS(K)+MNUCCD(K)+PRDG(K) - - IF( (DUM.GT.0. .AND. SUM_DEP.GT.DUM*FUDGEF) .OR. & - (DUM.LT.0. .AND. SUM_DEP.LT.DUM*FUDGEF) ) THEN - MNUCCD(K) = FUDGEF*MNUCCD(K)*DUM/SUM_DEP - PRD(K) = FUDGEF*PRD(K)*DUM/SUM_DEP - PRDS(K) = FUDGEF*PRDS(K)*DUM/SUM_DEP - PRDG(K) = FUDGEF*PRDG(K)*DUM/SUM_DEP - ENDIF - -! IF CLOUD ICE/SNOW/GRAUPEL VAP DEPOSITION IS NEG, THEN ASSIGN TO SUBLIMATION PROCESSES - - IF (PRD(K).LT.0.) THEN - EPRD(K)=PRD(K) - PRD(K)=0. - END IF - IF (PRDS(K).LT.0.) THEN - EPRDS(K)=PRDS(K) - PRDS(K)=0. - END IF - IF (PRDG(K).LT.0.) THEN - EPRDG(K)=PRDG(K) - PRDG(K)=0. - END IF - -!....................................................................... -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -! CONSERVATION OF WATER -! THIS IS ADOPTED LOOSELY FROM MM5 RESINER CODE. HOWEVER, HERE WE -! ONLY ADJUST PROCESSES THAT ARE NEGATIVE, RATHER THAN ALL PROCESSES. -! THIS SECTION IS SEPARATED INTO TWO PARTS, IF T < 0 C, T > 0 C -! DUE TO DIFFERENT PROCESSES THAT ACT DEPENDING ON FREEZING/ABOVE FREEZING - -! IF MIXING RATIOS LESS THAN QSMALL, THEN NO DEPLETION OF WATER -! THROUGH MICROPHYSICAL PROCESSES, SKIP CONSERVATION - -! NOTE: CONSERVATION CHECK NOT APPLIED TO NUMBER CONCENTRATION SPECIES. ADDITIONAL CATCH -! BELOW WILL PREVENT NEGATIVE NUMBER CONCENTRATION -! FOR EACH MICROPHYSICAL PROCESS WHICH PROVIDES A SOURCE FOR NUMBER, THERE IS A CHECK -! TO MAKE SURE THAT CAN'T EXCEED TOTAL NUMBER OF DEPLETED SPECIES WITH THE TIME -! STEP - -!****SENSITIVITY - NO ICE - - IF (ILIQ.EQ.1) THEN - MNUCCC(K)=0. - NNUCCC(K)=0. - MNUCCR(K)=0. - NNUCCR(K)=0. - MNUCCD(K)=0. - NNUCCD(K)=0. - END IF - -! ****SENSITIVITY - NO GRAUPEL - IF (IGRAUP.EQ.1) THEN - PRACG(K) = 0. - PSACR(K) = 0. - PSACWG(K) = 0. - PGSACW(K) = 0. - PGRACS(K) = 0. - PRDG(K) = 0. - EPRDG(K) = 0. - EVPMG(K) = 0. - PGMLT(K) = 0. - NPRACG(K) = 0. - NPSACWG(K) = 0. - NSCNG(K) = 0. - NGRACS(K) = 0. - NSUBG(K) = 0. - NGMLTG(K) = 0. - NGMLTR(K) = 0. -! fix 053011 - PIACRS(K)=PIACRS(K)+PIACR(K) - PIACR(K) = 0. - END IF - -! CONSERVATION OF QC - - DUM = (PRC(K)+PRA(K)+MNUCCC(K)+PSACWS(K)+PSACWI(K)+QMULTS(K)+PSACWG(K)+PGSACW(K)+QMULTG(K))*DT - - IF (DUM.GT.QC3D(K).AND.QC3D(K).GE.QSMALL) THEN - RATIO = QC3D(K)/DUM - - PRC(K) = PRC(K)*RATIO - PRA(K) = PRA(K)*RATIO - MNUCCC(K) = MNUCCC(K)*RATIO - PSACWS(K) = PSACWS(K)*RATIO - PSACWI(K) = PSACWI(K)*RATIO - QMULTS(K) = QMULTS(K)*RATIO - QMULTG(K) = QMULTG(K)*RATIO - PSACWG(K) = PSACWG(K)*RATIO - PGSACW(K) = PGSACW(K)*RATIO - END IF - -! CONSERVATION OF QI - - DUM = (-PRD(K)-MNUCCC(K)+PRCI(K)+PRAI(K)-QMULTS(K)-QMULTG(K)-QMULTR(K)-QMULTRG(K) & - -MNUCCD(K)+PRACI(K)+PRACIS(K)-EPRD(K)-PSACWI(K))*DT - - IF (DUM.GT.QI3D(K).AND.QI3D(K).GE.QSMALL) THEN - - RATIO = (QI3D(K)/DT+PRD(K)+MNUCCC(K)+QMULTS(K)+QMULTG(K)+QMULTR(K)+QMULTRG(K)+ & - MNUCCD(K)+PSACWI(K))/ & - (PRCI(K)+PRAI(K)+PRACI(K)+PRACIS(K)-EPRD(K)) - - PRCI(K) = PRCI(K)*RATIO - PRAI(K) = PRAI(K)*RATIO - PRACI(K) = PRACI(K)*RATIO - PRACIS(K) = PRACIS(K)*RATIO - EPRD(K) = EPRD(K)*RATIO - - END IF - -! CONSERVATION OF QR - - DUM=((PRACS(K)-PRE(K))+(QMULTR(K)+QMULTRG(K)-PRC(K))+(MNUCCR(K)-PRA(K))+ & - PIACR(K)+PIACRS(K)+PGRACS(K)+PRACG(K))*DT - - IF (DUM.GT.QR3D(K).AND.QR3D(K).GE.QSMALL) THEN - - RATIO = (QR3D(K)/DT+PRC(K)+PRA(K))/ & - (-PRE(K)+QMULTR(K)+QMULTRG(K)+PRACS(K)+MNUCCR(K)+PIACR(K)+PIACRS(K)+PGRACS(K)+PRACG(K)) - - PRE(K) = PRE(K)*RATIO - PRACS(K) = PRACS(K)*RATIO - QMULTR(K) = QMULTR(K)*RATIO - QMULTRG(K) = QMULTRG(K)*RATIO - MNUCCR(K) = MNUCCR(K)*RATIO - PIACR(K) = PIACR(K)*RATIO - PIACRS(K) = PIACRS(K)*RATIO - PGRACS(K) = PGRACS(K)*RATIO - PRACG(K) = PRACG(K)*RATIO - - END IF - -! CONSERVATION OF QNI -! CONSERVATION FOR GRAUPEL SCHEME - - IF (IGRAUP.EQ.0) THEN - - DUM = (-PRDS(K)-PSACWS(K)-PRAI(K)-PRCI(K)-PRACS(K)-EPRDS(K)+PSACR(K)-PIACRS(K)-PRACIS(K))*DT - - IF (DUM.GT.QNI3D(K).AND.QNI3D(K).GE.QSMALL) THEN - - RATIO = (QNI3D(K)/DT+PRDS(K)+PSACWS(K)+PRAI(K)+PRCI(K)+PRACS(K)+PIACRS(K)+PRACIS(K))/(-EPRDS(K)+PSACR(K)) - - EPRDS(K) = EPRDS(K)*RATIO - PSACR(K) = PSACR(K)*RATIO - - END IF - -! FOR NO GRAUPEL, NEED TO INCLUDE FREEZING OF RAIN FOR SNOW - ELSE IF (IGRAUP.EQ.1) THEN - - DUM = (-PRDS(K)-PSACWS(K)-PRAI(K)-PRCI(K)-PRACS(K)-EPRDS(K)+PSACR(K)-PIACRS(K)-PRACIS(K)-MNUCCR(K))*DT - - IF (DUM.GT.QNI3D(K).AND.QNI3D(K).GE.QSMALL) THEN - - RATIO = (QNI3D(K)/DT+PRDS(K)+PSACWS(K)+PRAI(K)+PRCI(K)+PRACS(K)+PIACRS(K)+PRACIS(K)+MNUCCR(K))/(-EPRDS(K)+PSACR(K)) - - EPRDS(K) = EPRDS(K)*RATIO - PSACR(K) = PSACR(K)*RATIO - - END IF - - END IF - -! CONSERVATION OF QG - - DUM = (-PSACWG(K)-PRACG(K)-PGSACW(K)-PGRACS(K)-PRDG(K)-MNUCCR(K)-EPRDG(K)-PIACR(K)-PRACI(K)-PSACR(K))*DT - - IF (DUM.GT.QG3D(K).AND.QG3D(K).GE.QSMALL) THEN - - RATIO = (QG3D(K)/DT+PSACWG(K)+PRACG(K)+PGSACW(K)+PGRACS(K)+PRDG(K)+MNUCCR(K)+PSACR(K)+& - PIACR(K)+PRACI(K))/(-EPRDG(K)) - - EPRDG(K) = EPRDG(K)*RATIO - - END IF - -! TENDENCIES - - QV3DTEN(K) = QV3DTEN(K)+(-PRE(K)-PRD(K)-PRDS(K)-MNUCCD(K)-EPRD(K)-EPRDS(K)-PRDG(K)-EPRDG(K)) - -! BUG FIX HM, 3/1/11, INCLUDE PIACR AND PIACRS - T3DTEN(K) = T3DTEN(K)+(PRE(K) & - *XXLV(K)+(PRD(K)+PRDS(K)+ & - MNUCCD(K)+EPRD(K)+EPRDS(K)+PRDG(K)+EPRDG(K))*XXLS(K)+ & - (PSACWS(K)+PSACWI(K)+MNUCCC(K)+MNUCCR(K)+ & - QMULTS(K)+QMULTG(K)+QMULTR(K)+QMULTRG(K)+PRACS(K) & - +PSACWG(K)+PRACG(K)+PGSACW(K)+PGRACS(K)+PIACR(K)+PIACRS(K))*XLF(K))/CPM(K) - - QC3DTEN(K) = QC3DTEN(K)+ & - (-PRA(K)-PRC(K)-MNUCCC(K)+PCC(K)- & - PSACWS(K)-PSACWI(K)-QMULTS(K)-QMULTG(K)-PSACWG(K)-PGSACW(K)) - QI3DTEN(K) = QI3DTEN(K)+ & - (PRD(K)+EPRD(K)+PSACWI(K)+MNUCCC(K)-PRCI(K)- & - PRAI(K)+QMULTS(K)+QMULTG(K)+QMULTR(K)+QMULTRG(K)+MNUCCD(K)-PRACI(K)-PRACIS(K)) - QR3DTEN(K) = QR3DTEN(K)+ & - (PRE(K)+PRA(K)+PRC(K)-PRACS(K)-MNUCCR(K)-QMULTR(K)-QMULTRG(K) & - -PIACR(K)-PIACRS(K)-PRACG(K)-PGRACS(K)) - - IF (IGRAUP.EQ.0) THEN - - QNI3DTEN(K) = QNI3DTEN(K)+ & - (PRAI(K)+PSACWS(K)+PRDS(K)+PRACS(K)+PRCI(K)+EPRDS(K)-PSACR(K)+PIACRS(K)+PRACIS(K)) - NS3DTEN(K) = NS3DTEN(K)+(NSAGG(K)+NPRCI(K)-NSCNG(K)-NGRACS(K)+NIACRS(K)) - QG3DTEN(K) = QG3DTEN(K)+(PRACG(K)+PSACWG(K)+PGSACW(K)+PGRACS(K)+ & - PRDG(K)+EPRDG(K)+MNUCCR(K)+PIACR(K)+PRACI(K)+PSACR(K)) - NG3DTEN(K) = NG3DTEN(K)+(NSCNG(K)+NGRACS(K)+NNUCCR(K)+NIACR(K)) - -! FOR NO GRAUPEL, NEED TO INCLUDE FREEZING OF RAIN FOR SNOW - ELSE IF (IGRAUP.EQ.1) THEN - - QNI3DTEN(K) = QNI3DTEN(K)+ & - (PRAI(K)+PSACWS(K)+PRDS(K)+PRACS(K)+PRCI(K)+EPRDS(K)-PSACR(K)+PIACRS(K)+PRACIS(K)+MNUCCR(K)) - NS3DTEN(K) = NS3DTEN(K)+(NSAGG(K)+NPRCI(K)-NSCNG(K)-NGRACS(K)+NIACRS(K)+NNUCCR(K)) - - END IF - - NC3DTEN(K) = NC3DTEN(K)+(-NNUCCC(K)-NPSACWS(K) & - -NPRA(K)-NPRC(K)-NPSACWI(K)-NPSACWG(K)) - - NI3DTEN(K) = NI3DTEN(K)+ & - (NNUCCC(K)-NPRCI(K)-NPRAI(K)+NMULTS(K)+NMULTG(K)+NMULTR(K)+NMULTRG(K)+ & - NNUCCD(K)-NIACR(K)-NIACRS(K)) - - NR3DTEN(K) = NR3DTEN(K)+(NPRC1(K)-NPRACS(K)-NNUCCR(K) & - +NRAGG(K)-NIACR(K)-NIACRS(K)-NPRACG(K)-NGRACS(K)) - -! V1.3 move code below to before saturation adjustment - IF (EPRD(K).LT.0.) THEN - DUM = EPRD(K)*DT/QI3D(K) - DUM = MAX(-1.,DUM) - NSUBI(K) = DUM*NI3D(K)/DT - END IF - IF (EPRDS(K).LT.0.) THEN - DUM = EPRDS(K)*DT/QNI3D(K) - DUM = MAX(-1.,DUM) - NSUBS(K) = DUM*NS3D(K)/DT - END IF - IF (PRE(K).LT.0.) THEN - DUM = PRE(K)*DT/QR3D(K) - DUM = MAX(-1.,DUM) - NSUBR(K) = DUM*NR3D(K)/DT - END IF - IF (EPRDG(K).LT.0.) THEN - DUM = EPRDG(K)*DT/QG3D(K) - DUM = MAX(-1.,DUM) - NSUBG(K) = DUM*NG3D(K)/DT - END IF - -! nsubr(k)=0. -! nsubs(k)=0. -! nsubg(k)=0. - - NI3DTEN(K) = NI3DTEN(K)+NSUBI(K) - NS3DTEN(K) = NS3DTEN(K)+NSUBS(K) - NG3DTEN(K) = NG3DTEN(K)+NSUBG(K) - NR3DTEN(K) = NR3DTEN(K)+NSUBR(K) -#ifdef ECPP -! HM ADD, WRF-CHEM, ADD TENDENCIES FOR C2PREC - C2PREC(K) = PRA(K)+PRC(K)+PSACWS(K)+QMULTS(K)+QMULTG(K)+PSACWG(K)+ & - PGSACW(K)+MNUCCC(K)+PSACWI(K) - if(QC3D(K).gt.1.0e-10) then - QSINK(K) = min(1.0, C2PREC(K)/QC3D(K)) - else - QSINK(K) = 0.0 - end if -#endif /*ECPP*/ - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - IF(ISATADJ.EQ.0) THEN !PB 4/13/09 - -! NOW CALCULATE SATURATION ADJUSTMENT TO CONDENSE EXTRA VAPOR ABOVE -! WATER SATURATION - - DUMT = T3D(K)+DT*T3DTEN(K) - DUMQV = QV3D(K)+DT*QV3DTEN(K) -! hm, add fix for low pressure, 5/12/10 - dum=min(0.99*pres(k),POLYSVP(DUMT,0)) - DUMQSS = EP_2*dum/(PRES(K)-dum) - DUMQC = QC3D(K)+DT*QC3DTEN(K) - DUMQC = MAX(DUMQC,0.) - -! SATURATION ADJUSTMENT FOR LIQUID - - DUMS = DUMQV-DUMQSS - PCC(K) = DUMS/(1.+XXLV(K)**2*DUMQSS/(CPM(K)*RV*DUMT**2))/DT -! IF (PCC(K)*DT+DUMQC.LT.0.) THEN -! PCC(K) = -DUMQC/DT -! END IF -!+++mhwang - IF (PCC(K)*DT+QC3D(K)+DT*QC3DTEN(K).LT.0.) THEN - PCC(K) = -(QC3D(K)+DT*QC3DTEN(K))/DT - END IF -!---mhwang - - QV3DTEN(K) = QV3DTEN(K)-PCC(K) - T3DTEN(K) = T3DTEN(K)+PCC(K)*XXLV(K)/CPM(K) - QC3DTEN(K) = QC3DTEN(K)+PCC(K) - - END IF - -! hm 7/26/11, new output - - aut1d(k)=prc(k) - acc1d(k)=pra(k) - evpr1d(k)=-PRE(K) - if (pcc(k).lt.0.) then - evpc1d(k)=-pcc(k) - else if (pcc(k).gt.0.) then - con1d(k)=pcc(k) - end if - sub1d(k)=-EPRD(K)-EPRDS(K)-EPRDG(K) - dep1d(k)=PRD(K)+PRDS(K)+MNUCCD(K)+PRDG(K) -!....................................................................... -! ACTIVATION OF CLOUD DROPLETS - -!bloss: only do activation if droplet number is predicted -!bloss IF (QC3D(K)+QC3DTEN(K)*DT.GE.QSMALL) THEN - IF (QC3D(K)+QC3DTEN(K)*DT.GE.QSMALL.AND.INUM.EQ.0) THEN - -! EFFECTIVE VERTICAL VELOCITY (M/S) - - IF (ISUB.EQ.0) THEN -! ADD SUB-GRID VERTICAL VELOCITY - DUM = W3D(K)+WVAR(K) - -! ASSUME MINIMUM EFF. SUB-GRID VELOCITY 0.10 M/S -#ifdef CLUBB_CRM - DUM = MAX(DUM,0.01) -#else - DUM = MAX(DUM,0.10) -#endif - - ELSE IF (ISUB.EQ.1) THEN - DUM=W3D(K) - END IF - -! ONLY ACTIVATE IN REGIONS OF UPWARD MOTION - IF (DUM.GE.0.001) THEN - - IF (IBASE.EQ.1) THEN - -! ACTIVATE ONLY IF THERE IS LITTLE CLOUD WATER -! OR IF AT CLOUD BASE, OR AT LOWEST MODEL LEVEL (K=1) - - IDROP=0 - -! V1.3 USE CURRENT VALUE OF QC FOR IDROP - IF (QC3D(K).LE.0.05E-3/RHO(K)) THEN - IDROP=1 - END IF - IF (K.EQ.1) THEN - IDROP=1 - ELSE IF (K.GE.2) THEN - IF (QC3D(K).GT.0.05E-3/RHO(K).AND. & - QC3D(K-1).LE.0.05E-3/RHO(K-1)) THEN - IDROP=1 - END IF - END IF - - IF (IDROP.EQ.1) THEN -! ACTIVATE AT CLOUD BASE OR REGIONS WITH VERY LITTLE LIQ WATER - - IF (IACT.EQ.1) THEN -! USE ROGERS AND YAU (1989) TO RELATE NUMBER ACTIVATED TO W -! BASED ON TWOMEY 1959 - - DUM=DUM*100. ! CONVERT FROM M/S TO CM/S - DUM2 = 0.88*C1**(2./(K1+2.))*(7.E-2*DUM**1.5)**(K1/(K1+2.)) - DUM2=DUM2*1.E6 ! CONVERT FROM CM-3 TO M-3 - DUM2=DUM2/RHO(K) ! CONVERT FROM M-3 TO KG-1 -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 - - ELSE IF (IACT.EQ.2) THEN -! DROPLET ACTIVATION FROM ABDUL-RAZZAK AND GHAN (2000) - - SIGVL = 0.0761-1.55E-4*(T3D(K)-TMELT) - AACT = 2.*MW/(RHOW*RR)*SIGVL/T3D(K) - ALPHA = G*MW*XXLV(K)/(CPM(K)*RR*T3D(K)**2)-G*MA/(RR*T3D(K)) - GAMM = RR*T3D(K)/(EVS(K)*MW)+MW*XXLV(K)**2/(CPM(K)*PRES(K)*MA*T3D(K)) - - GG = 1./(RHOW*RR*T3D(K)/(EVS(K)*DV(K)*MW)+ XXLV(K)*RHOW/(KAP(K)*T3D(K))*(XXLV(K)*MW/ & - (T3D(K)*RR)-1.)) - - PSI = 2./3.*(ALPHA*DUM/GG)**0.5*AACT - - ETA1 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW1) - ETA2 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW2) - - SM1 = 2./BACT**0.5*(AACT/(3.*RM1))**1.5 - SM2 = 2./BACT**0.5*(AACT/(3.*RM2))**1.5 - - DUM1 = 1./SM1**2*(F11*(PSI/ETA1)**1.5+F21*(SM1**2/(ETA1+3.*PSI))**0.75) - DUM2 = 1./SM2**2*(F12*(PSI/ETA2)**1.5+F22*(SM2**2/(ETA2+3.*PSI))**0.75) - - SMAX = 1./(DUM1+DUM2)**0.5 - - UU1 = 2.*LOG(SM1/SMAX)/(4.242*LOG(SIG1)) - UU2 = 2.*LOG(SM2/SMAX)/(4.242*LOG(SIG2)) - DUM1 = NANEW1/2.*(1.-DERF1(UU1)) - DUM2 = NANEW2/2.*(1.-DERF1(UU2)) - - DUM2 = (DUM1+DUM2)/RHO(K) !CONVERT TO KG-1 - -! MAKE SURE THIS VALUE ISN'T GREATER THAN TOTAL NUMBER OF AEROSOL - - DUM2 = MIN((NANEW1+NANEW2)/RHO(K),DUM2) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#if (defined CRM && defined MODAL_AERO) - ELSE if (IACT.EQ.3) then - INES = 0 - CALL DROP_ACTIVATION_GHAN(DUM, T3D(k), RHO(k), & - DUM2, INES, SMAX, K) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0., DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#endif - END IF ! IACT - -!............................................................................. - ELSE IF (IDROP.EQ.0) THEN -! ACTIVATE IN CLOUD INTERIOR -! FIND EQUILIBRIUM SUPERSATURATION - - TAUC=1./(2.*PI*RHO(k)*DV(K)*NC3D(K)*(PGAM(K)+1.)/LAMC(K)) - IF (EPSR.GT.1.E-8) THEN - TAUR=1./EPSR - ELSE - TAUR=1.E8 - END IF - IF (EPSI.GT.1.E-8) THEN - TAUI=1./EPSI - ELSE - TAUI=1.E8 - END IF - IF (EPSS.GT.1.E-8) THEN - TAUS=1./EPSS - ELSE - TAUS=1.E8 - END IF - IF (EPSG.GT.1.E-8) THEN - TAUG=1./EPSG - ELSE - TAUG=1.E8 - END IF - -! EQUILIBRIUM SS INCLUDING BERGERON EFFECT - - DUM3=(QVS(K)*RHO(K)/(PRES(K)-EVS(K))+DQSDT/CP)*G*DUM - DUM3=(DUM3*TAUC*TAUR*TAUI*TAUS*TAUG- & - (QVS(K)-QVI(K))*(TAUC*TAUR*TAUI*TAUG+TAUC*TAUR*TAUS*TAUG+TAUC*TAUR*TAUI*TAUS))/ & - (TAUC*TAUR*TAUI*TAUG+TAUC*TAUR*TAUS*TAUG+TAUC*TAUR*TAUI*TAUS+ & - TAUR*TAUI*TAUS*TAUG+TAUC*TAUI*TAUS*TAUG) - - IF (DUM3/QVS(K).GE.1.E-6) THEN - IF (IACT.EQ.1) THEN - -! FIND MAXIMUM ALLOWED ACTIVATION WITH NON-EQULIBRIUM SS - - DUM=DUM*100. ! CONVERT FROM M/S TO CM/S - DUMACT = 0.88*C1**(2./(K1+2.))*(7.E-2*DUM**1.5)**(K1/(K1+2.)) - -! USE POWER LAW CCN SPECTRA - -! CONVERT FROM ABSOLUTE SUPERSATURATION TO SUPERSATURATION RATIO IN % - DUM3=DUM3/QVS(K)*100. - - DUM2=C1*DUM3**K1 -! MAKE SURE VALUE DOESN'T EXCEED THAT FOR NON-EQUILIBRIUM SS - DUM2=MIN(DUM2,DUMACT) - DUM2=DUM2*1.E6 ! CONVERT FROM CM-3 TO M-3 - DUM2=DUM2/RHO(K) ! CONVERT FROM M-3 TO KG-1 -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 - - ELSE IF (IACT.EQ.2) THEN - -! FIND MAXIMUM ALLOWED ACTIVATION WITH NON-EQULIBRIUM SS - - SIGVL = 0.0761-1.55E-4*(T3D(K)-TMELT) - AACT = 2.*MW/(RHOW*RR)*SIGVL/T3D(K) - ALPHA = G*MW*XXLV(K)/(CPM(K)*RR*T3D(K)**2)-G*MA/(RR*T3D(K)) - GAMM = RR*T3D(K)/(EVS(K)*MW)+MW*XXLV(K)**2/(CPM(K)*PRES(K)*MA*T3D(K)) - - GG = 1./(RHOW*RR*T3D(K)/(EVS(K)*DV(K)*MW)+ XXLV(K)*RHOW/(KAP(K)*T3D(K))*(XXLV(K)*MW/ & - (T3D(K)*RR)-1.)) - - PSI = 2./3.*(ALPHA*DUM/GG)**0.5*AACT - - ETA1 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW1) - ETA2 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW2) - - SM1 = 2./BACT**0.5*(AACT/(3.*RM1))**1.5 - SM2 = 2./BACT**0.5*(AACT/(3.*RM2))**1.5 - - DUM1 = 1./SM1**2*(F11*(PSI/ETA1)**1.5+F21*(SM1**2/(ETA1+3.*PSI))**0.75) - DUM2 = 1./SM2**2*(F12*(PSI/ETA2)**1.5+F22*(SM2**2/(ETA2+3.*PSI))**0.75) - - SMAX = 1./(DUM1+DUM2)**0.5 - - UU1 = 2.*LOG(SM1/SMAX)/(4.242*LOG(SIG1)) - UU2 = 2.*LOG(SM2/SMAX)/(4.242*LOG(SIG2)) - DUM1 = NANEW1/2.*(1.-DERF1(UU1)) - DUM2 = NANEW2/2.*(1.-DERF1(UU2)) - - DUM2 = (DUM1+DUM2)/RHO(K) !CONVERT TO KG-1 - -! MAKE SURE THIS VALUE ISN'T GREATER THAN TOTAL NUMBER OF AEROSOL - - DUMACT = MIN((NANEW1+NANEW2)/RHO(K),DUM2) - -! USE LOGNORMAL AEROSOL - SIGVL = 0.0761-1.55E-4*(T3D(K)-TMELT) - AACT = 2.*MW/(RHOW*RR)*SIGVL/T3D(K) - - SM1 = 2./BACT**0.5*(AACT/(3.*RM1))**1.5 - SM2 = 2./BACT**0.5*(AACT/(3.*RM2))**1.5 - -! GET SUPERSATURATION RATIO FROM ABSOLUTE SUPERSATURATION - SMAX = DUM3/QVS(K) - - UU1 = 2.*LOG(SM1/SMAX)/(4.242*LOG(SIG1)) - UU2 = 2.*LOG(SM2/SMAX)/(4.242*LOG(SIG2)) - DUM1 = NANEW1/2.*(1.-DERF1(UU1)) - DUM2 = NANEW2/2.*(1.-DERF1(UU2)) - - DUM2 = (DUM1+DUM2)/RHO(K) !CONVERT TO KG-1 - -! MAKE SURE THIS VALUE ISN'T GREATER THAN TOTAL NUMBER OF AEROSOL - - DUM2 = MIN((NANEW1+NANEW2)/RHO(K),DUM2) - -! MAKE SURE ISN'T GREATER THAN NON-EQUIL. SS - DUM2=MIN(DUM2,DUMACT) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#if (defined CRM && defined MODAL_AERO) - ELSE if (IACT.EQ.3) then -! GET SUPERSATURATION RATIO FROM ABSOLUTE SUPERSATURATION - SMAX = DUM3/QVS(K) - - INES = 1 - CALL DROP_ACTIVATION_GHAN(DUM, T3D(k), RHO(k), & - DUM2, INES, SMAX, K) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0., DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#endif - - END IF ! IACT - END IF ! DUM3/QVS > 1.E-6 - END IF ! IDROP = 1 - -!....................................................................... - ELSE IF (IBASE.EQ.2) THEN - - IF (IACT.EQ.1) THEN -! USE ROGERS AND YAU (1989) TO RELATE NUMBER ACTIVATED TO W -! BASED ON TWOMEY 1959 - - DUM=DUM*100. ! CONVERT FROM M/S TO CM/S - DUM2 = 0.88*C1**(2./(K1+2.))*(7.E-2*DUM**1.5)**(K1/(K1+2.)) - DUM2=DUM2*1.E6 ! CONVERT FROM CM-3 TO M-3 - DUM2=DUM2/RHO(K) ! CONVERT FROM M-3 TO KG-1 -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 - - ELSE IF (IACT.EQ.2) THEN - - SIGVL = 0.0761-1.55E-4*(T3D(K)-TMELT) - AACT = 2.*MW/(RHOW*RR)*SIGVL/T3D(K) - ALPHA = G*MW*XXLV(K)/(CPM(K)*RR*T3D(K)**2)-G*MA/(RR*T3D(K)) - GAMM = RR*T3D(K)/(EVS(K)*MW)+MW*XXLV(K)**2/(CPM(K)*PRES(K)*MA*T3D(K)) - - GG = 1./(RHOW*RR*T3D(K)/(EVS(K)*DV(K)*MW)+ XXLV(K)*RHOW/(KAP(K)*T3D(K))*(XXLV(K)*MW/ & - (T3D(K)*RR)-1.)) - - PSI = 2./3.*(ALPHA*DUM/GG)**0.5*AACT - - ETA1 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW1) - ETA2 = (ALPHA*DUM/GG)**1.5/(2.*PI*RHOW*GAMM*NANEW2) - - SM1 = 2./BACT**0.5*(AACT/(3.*RM1))**1.5 - SM2 = 2./BACT**0.5*(AACT/(3.*RM2))**1.5 - - DUM1 = 1./SM1**2*(F11*(PSI/ETA1)**1.5+F21*(SM1**2/(ETA1+3.*PSI))**0.75) - DUM2 = 1./SM2**2*(F12*(PSI/ETA2)**1.5+F22*(SM2**2/(ETA2+3.*PSI))**0.75) - - SMAX = 1./(DUM1+DUM2)**0.5 - - UU1 = 2.*LOG(SM1/SMAX)/(4.242*LOG(SIG1)) - UU2 = 2.*LOG(SM2/SMAX)/(4.242*LOG(SIG2)) - DUM1 = NANEW1/2.*(1.-DERF1(UU1)) - DUM2 = NANEW2/2.*(1.-DERF1(UU2)) - - DUM2 = (DUM1+DUM2)/RHO(K) !CONVERT TO KG-1 - -! MAKE SURE THIS VALUE ISN'T GREATER THAN TOTAL NUMBER OF AEROSOL - - DUM2 = MIN((NANEW1+NANEW2)/RHO(K),DUM2) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0.,DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#if (defined CRM && defined MODAL_AERO) - ELSE if (IACT.EQ.3) then - INES = 0 - CALL DROP_ACTIVATION_GHAN(DUM, T3D(k), RHO(k), & - DUM2, INES, SMAX, K) -#ifdef CLUBB_CRM - if(doclubb_gridmean) then - DUM2 = DUM2 * CFL3D(K) - end if -#endif - DUM2 = (DUM2-NC3D(K))/DT - DUM2 = MAX(0., DUM2) - NC3DTEN(K) = NC3DTEN(K)+DUM2 -#endif - END IF ! IACT - END IF ! IBASE - END IF ! W > 0.001 - END IF ! QC3D > QSMALL - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! SUBLIMATE, MELT, OR EVAPORATE NUMBER CONCENTRATION -! THIS FORMULATION ASSUMES 1:1 RATIO BETWEEN MASS LOSS AND -! LOSS OF NUMBER CONCENTRATION - -! IF (PCC(K).LT.0.) THEN -! DUM = PCC(K)*DT/QC3D(K) -! DUM = MAX(-1.,DUM) -! NSUBC(K) = DUM*NC3D(K)/DT -! END IF - - -! nsubr(k)=0. -! nsubs(k)=0. -! nsubg(k)=0. - - END IF !!!!!! TEMPERATURE - -! SWITCH LTRUE TO 1, SINCE HYDROMETEORS ARE PRESENT - LTRUE = 1 - - 200 CONTINUE -#ifdef CLUBB_CRM -! ADDITION BY UWM TO WEIGHT BY SGS CLOUD FRACTION - IF ( CF3D(K) > cloud_frac_thresh ) THEN - - T3D(K) = T3D_INIT + ( T3D(K) - T3D_INIT ) * CF3D(K) ! Absolute temp. - T3DTEN(K) = T3DTEN(K) * CF3D(K) ! Absolute temperature tendency - - QV3D(K) = QV_INIT + ( QV3D(K) - QSAT_INIT ) * CF3D(K) ! Vapor - QV3DTEN(K) = QV3DTEN(K) * CF3D(K) ! Vapor mix ratio time tendency - - QC3D(K) = QC3D(K) * CF3D(K) ! Cloud mix ratio - QC3DTEN(K) = QC3DTEN(K) * CF3D(K) ! Cloud mix ratio time tendency - - IF ( INUM == 0 ) THEN - NC3D(K) = NC3D(K) * CF3D(K) ! Cloud drop num conc - NC3DTEN(K) = NC3DTEN(K) * CF3D(K) ! Cloud drop num conc time tendency - END IF - - QR3D(K) = QR3D(K) * CF3D(K) ! Rain mix ratio - QR3DTEN(K) = QR3DTEN(K) * CF3D(K) ! Rain mix ratio time tendency - - NR3D(K) = NR3D(K) * CF3D(K) ! Rain num conc - NR3DTEN(K) = NR3DTEN(K) * CF3D(K) ! Rain num conc time tendency - - IF ( ILIQ == 0 ) THEN - QI3D(K) = QI3D(K) * CF3D(K) ! Ice mix ratio - QI3DTEN(K) = QI3DTEN(K) * CF3D(K) ! Ice mix ratio time tendency - - NI3D(K) = NI3D(K) * CF3D(K) ! Ice num conc - NI3DTEN(K) = NI3DTEN(K) * CF3D(K) ! Ice num conc time tendency - - QNI3D(K) = QNI3D(K) * CF3D(K) ! Snow mix ratio - QNI3DTEN(K) = QNI3DTEN(K) * CF3D(K) ! Snow mix ratio time tendency - - NS3D(K) = NS3D(K) * CF3D(K) ! Snow num conc - NS3DTEN(K) = NS3DTEN(K) * CF3D(K) ! Snow num conc time tendency - END IF - IF ( IGRAUP == 0 ) THEN - QG3D(K) = QG3D(K) * CF3D(K) ! Graupel mix ratio - QG3DTEN(K) = QG3DTEN(K) * CF3D(K) ! Graupel mix ratio time tendency - - NG3D(K) = NG3D(K) * CF3D(K) ! Graupel num conc - NG3DTEN(K) = NG3DTEN(K) * CF3D(K) ! Graupel num conc time tendency - END IF -! +++mhwang -! add individual microphysical process rates - PRC(K) = PRC(K) * CF3D(K) - PRA(K) = PRA(K) * CF3D(K) - PSMLT(K) = PSMLT(K) * CF3D(K) - EVPMS(K) = EVPMS(K) * CF3D(K) - PRACS(K) = PRACS(K) * CF3D(K) - EVPMG(K) = EVPMG(K) * CF3D(K) - PRACG(K) = PRACG(K) * CF3D(K) - PRE(K) = PRE(K) * CF3D(K) - PGMLT(K) = PGMLT(K) * CF3D(K) - - MNUCCC(K) = MNUCCC(K) * CF3D(K) - PSACWS(K) = PSACWS(K) * CF3D(K) - PSACWI(K) = PSACWI(k) * CF3D(K) - QMULTS(K) = QMULTS(K) * CF3D(K) - QMULTG(K) = QMULTG(K) * CF3D(K) - PSACWG(K) = PSACWG(K) * CF3D(K) - PGSACW(K) = PGSACW(K) * CF3D(K) - - PRD(K) = PRD(K) * CF3D(K) - PRCI(K) = PRCI(K) * CF3D(K) - PRAI(K) = PRAI(K) * CF3D(K) - QMULTR(K) = QMULTR(K) * CF3D(K) - QMULTRG(K) = QMULTRG(K) * CF3D(K) - MNUCCD(K) = MNUCCD(K) * CF3D(K) - PRACI(K) = PRACI(K) * CF3D(K) - PRACIS(K) = PRACIS(K) * CF3D(K) - EPRD(K) = EPRD(K) * CF3D(K) - - MNUCCR(K) = MNUCCR(K) * CF3D(K) - PIACR(K) = PIACR(K) * CF3D(K) - PIACRS(K) = PIACRS(K) * CF3D(K) - PGRACS(K) = PGRACS(K) * CF3D(K) - - PRDS(K) = PRDS(K) * CF3D(K) - EPRDS(K) = EPRDS(K) * CF3D(K) - PSACR(K) = PSACR(K) * CF3D(K) - - PRDG(K) = PRDG(K) * CF3D(K) - EPRDG(K) = EPRDG(K) * CF3D(K) - -! Rain drop number process rates - NPRC1(K) = NPRC1(K)* CF3D(K) - NRAGG(K) = NRAGG(K) * CF3D(K) - NPRACG(K) = NPRACG(K) * CF3D(K) - NSUBR(K) = NSUBR(K) * CF3D(K) - NSMLTR(K) = NSMLTR(K) * CF3D(K) - NGMLTR(K) = NGMLTR(K) * CF3D(K) - NPRACS(K) = NPRACS(K) * CF3D(K) - NNUCCR(K) = NNUCCR(K) * CF3D(K) - NIACR(K) = NIACR(K) * CF3D(K) - NIACRS(K) = NIACRS(K) * CF3D(K) - NGRACS(K) = NGRACS(K) * CF3D(K) - -! hm 7/26/11, new output - aut1d(k)=prc(k) - acc1d(k)=pra(k) - mlt1d(k)=-PSMLT(K)-PGMLT(K)+PRACS(K)+PRACG(K) - evpr1d(k)=-PRE(K)-EVPMS(K)-EVPMG(K) - if (pcc(k).lt.0.) then - evpc1d(k)=-pcc(k) - else if (pcc(k).gt.0.) then - con1d(k)=pcc(k) - end if - sub1d(k)=-EPRD(K)-EPRDS(K)-EPRDG(K) - dep1d(k)=PRD(K)+PRDS(K)+MNUCCD(K)+PRDG(K) - - END IF ! CF3D(K) > 0.01 -#endif /*CLUBB_CRM*/ - - END DO - -! V1.3 move precip initialization to here -! INITIALIZE PRECIP AND SNOW RATES - - PRECRT = 0. - SNOWRT = 0. - -! IF THERE ARE NO HYDROMETEORS, THEN SKIP TO END OF SUBROUTINE - - IF (LTRUE.EQ.0) GOTO 400 - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -!....................................................................... -! CALCULATE SEDIMENATION -! THE NUMERICS HERE FOLLOW FROM REISNER ET AL. (1998) -! FALLOUT TERMS ARE CALCULATED ON SPLIT TIME STEPS TO ENSURE NUMERICAL -! STABILITY, I.E. COURANT# < 1 - -!....................................................................... - - NSTEP = 1 - -! v3 5/27/11 - DO K = KTE,KTS,-1 - - DUMI(K) = QI3D(K)+QI3DTEN(K)*DT - DUMQS(K) = QNI3D(K)+QNI3DTEN(K)*DT - DUMR(K) = QR3D(K)+QR3DTEN(K)*DT - DUMFNI(K) = NI3D(K)+NI3DTEN(K)*DT - DUMFNS(K) = NS3D(K)+NS3DTEN(K)*DT - DUMFNR(K) = NR3D(K)+NR3DTEN(K)*DT - DUMC(K) = QC3D(K)+QC3DTEN(K)*DT - DUMFNC(K) = NC3D(K)+NC3DTEN(K)*DT - DUMG(K) = QG3D(K)+QG3DTEN(K)*DT - DUMFNG(K) = NG3D(K)+NG3DTEN(K)*DT - -! SWITCH FOR CONSTANT DROPLET NUMBER - IF (INUM.EQ.1) THEN - DUMFNC(K) = NC3D(K) - END IF - -! GET DUMMY LAMDA FOR SEDIMENTATION CALCULATIONS - -! MAKE SURE NUMBER CONCENTRATIONS ARE POSITIVE - DUMFNI(K) = MAX(0.,DUMFNI(K)) - DUMFNS(K) = MAX(0.,DUMFNS(K)) - DUMFNC(K) = MAX(0.,DUMFNC(K)) - DUMFNR(K) = MAX(0.,DUMFNR(K)) - DUMFNG(K) = MAX(0.,DUMFNG(K)) - -!...................................................................... -! CLOUD ICE - - IF (DUMI(K).GE.QSMALL) THEN - DLAMI = (CONS12*DUMFNI(K)/DUMI(K))**(1./DI) - DLAMI=MAX(DLAMI,LAMMINI) - DLAMI=MIN(DLAMI,LAMMAXI) - END IF -!...................................................................... -! RAIN - - IF (DUMR(K).GE.QSMALL) THEN - DLAMR = (PI*RHOW*DUMFNR(K)/DUMR(K))**(1./3.) - DLAMR=MAX(DLAMR,LAMMINR) - DLAMR=MIN(DLAMR,LAMMAXR) - END IF -!...................................................................... -! CLOUD DROPLETS - - IF (DUMC(K).GE.QSMALL) THEN - !bloss: option for fixing pgam - if(dofix_pgam) then - pgam(k) = pgam_fixed - else - -! DUM = PRES(K)/(R*T3D(K)) -! V1.5 - PGAM(K)=0.0005714*(NC3D(K)/1.E6*RHO(K))+0.2714 - PGAM(K)=1./(PGAM(K)**2)-1. - PGAM(K)=MAX(PGAM(K),2.) - PGAM(K)=MIN(PGAM(K),10.) - - end if - - DLAMC = (CONS26*DUMFNC(K)*GAMMA(PGAM(K)+4.)/(DUMC(K)*GAMMA(PGAM(K)+1.)))**(1./3.) - LAMMIN = (PGAM(K)+1.)/60.E-6 - LAMMAX = (PGAM(K)+1.)/1.E-6 - DLAMC=MAX(DLAMC,LAMMIN) - DLAMC=MIN(DLAMC,LAMMAX) - END IF -!...................................................................... -! SNOW - - IF (DUMQS(K).GE.QSMALL) THEN - DLAMS = (CONS1*DUMFNS(K)/ DUMQS(K))**(1./DS) - DLAMS=MAX(DLAMS,LAMMINS) - DLAMS=MIN(DLAMS,LAMMAXS) - END IF -!...................................................................... -! GRAUPEL - - IF (DUMG(K).GE.QSMALL) THEN - DLAMG = (CONS2*DUMFNG(K)/ DUMG(K))**(1./DG) - DLAMG=MAX(DLAMG,LAMMING) - DLAMG=MIN(DLAMG,LAMMAXG) - END IF - -!...................................................................... -! CALCULATE NUMBER-WEIGHTED AND MASS-WEIGHTED TERMINAL FALL SPEEDS - -! CLOUD WATER - - IF (DUMC(K).GE.QSMALL) THEN - UNC = ACN(K)*GAMMA(1.+BC+PGAM(K))/ (DLAMC**BC*GAMMA(PGAM(K)+1.)) - UMC = ACN(K)*GAMMA(4.+BC+PGAM(K))/ (DLAMC**BC*GAMMA(PGAM(K)+4.)) - ELSE - UMC = 0. - UNC = 0. - END IF - - IF (DUMI(K).GE.QSMALL) THEN - UNI = AIN(K)*CONS27/DLAMI**BI - UMI = AIN(K)*CONS28/(DLAMI**BI) - ELSE - UMI = 0. - UNI = 0. - END IF - - IF (DUMR(K).GE.QSMALL) THEN - UNR = ARN(K)*CONS6/DLAMR**BR - UMR = ARN(K)*CONS4/(DLAMR**BR) - ELSE - UMR = 0. - UNR = 0. - END IF - - IF (DUMQS(K).GE.QSMALL) THEN - UMS = ASN(K)*CONS3/(DLAMS**BS) - UNS = ASN(K)*CONS5/DLAMS**BS - ELSE - UMS = 0. - UNS = 0. - END IF - - IF (DUMG(K).GE.QSMALL) THEN - UMG = AGN(K)*CONS7/(DLAMG**BG) - UNG = AGN(K)*CONS8/DLAMG**BG - ELSE - UMG = 0. - UNG = 0. - END IF - -! SET REALISTIC LIMITS ON FALLSPEED - -! bug fix, 10/08/09 - dum=(rhosu/rho(k))**0.54 - UMS=MIN(UMS,1.2*dum) - UNS=MIN(UNS,1.2*dum) -! v3 5/27/11 -! fix for correction by AA 4/6/11 - UMI=MIN(UMI,1.2*(rhosu/rho(k))**0.35) - UNI=MIN(UNI,1.2*(rhosu/rho(k))**0.35) - UMR=MIN(UMR,9.1*dum) - UNR=MIN(UNR,9.1*dum) - UMG=MIN(UMG,20.*dum) - UNG=MIN(UNG,20.*dum) - - FR(K) = UMR - FI(K) = UMI - FNI(K) = UNI - FS(K) = UMS - FNS(K) = UNS - FNR(K) = UNR - FC(K) = UMC - FNC(K) = UNC - FG(K) = UMG - FNG(K) = UNG - -! V3.3 MODIFY FALLSPEED BELOW LEVEL OF PRECIP - - IF (K.LE.KTE-1) THEN - IF (FR(K).LT.1.E-10) THEN - FR(K)=FR(K+1) - END IF - IF (FI(K).LT.1.E-10) THEN - FI(K)=FI(K+1) - END IF - IF (FNI(K).LT.1.E-10) THEN - FNI(K)=FNI(K+1) - END IF - IF (FS(K).LT.1.E-10) THEN - FS(K)=FS(K+1) - END IF - IF (FNS(K).LT.1.E-10) THEN - FNS(K)=FNS(K+1) - END IF - IF (FNR(K).LT.1.E-10) THEN - FNR(K)=FNR(K+1) - END IF - IF (FC(K).LT.1.E-10) THEN - FC(K)=FC(K+1) - END IF - IF (FNC(K).LT.1.E-10) THEN - FNC(K)=FNC(K+1) - END IF - IF (FG(K).LT.1.E-10) THEN - FG(K)=FG(K+1) - END IF - IF (FNG(K).LT.1.E-10) THEN - FNG(K)=FNG(K+1) - END IF - END IF ! K LE KTE-1 - -! CALCULATE NUMBER OF SPLIT TIME STEPS - - RGVM = MAX(FR(K),FI(K),FS(K),FC(K),FNI(K),FNR(K),FNS(K),FNC(K),FG(K),FNG(K)) -! VVT CHANGED IFIX -> INT (GENERIC FUNCTION) - NSTEP = MAX(INT(RGVM*DT/DZQ(K)+1.),NSTEP) - -! MULTIPLY VARIABLES BY RHO - DUMR(k) = DUMR(k)*RHO(K) - DUMI(k) = DUMI(k)*RHO(K) - DUMFNI(k) = DUMFNI(K)*RHO(K) - DUMQS(k) = DUMQS(K)*RHO(K) - DUMFNS(k) = DUMFNS(K)*RHO(K) - DUMFNR(k) = DUMFNR(K)*RHO(K) - DUMC(k) = DUMC(K)*RHO(K) - DUMFNC(k) = DUMFNC(K)*RHO(K) - DUMG(k) = DUMG(K)*RHO(K) - DUMFNG(k) = DUMFNG(K)*RHO(K) - - END DO - - DO N = 1,NSTEP - - DO K = KTS,KTE - FALOUTR(K) = FR(K)*DUMR(K) - FALOUTI(K) = FI(K)*DUMI(K) - FALOUTNI(K) = FNI(K)*DUMFNI(K) - FALOUTS(K) = FS(K)*DUMQS(K) - FALOUTNS(K) = FNS(K)*DUMFNS(K) - FALOUTNR(K) = FNR(K)*DUMFNR(K) - FALOUTC(K) = FC(K)*DUMC(K) - FALOUTNC(K) = FNC(K)*DUMFNC(K) - FALOUTG(K) = FG(K)*DUMG(K) - FALOUTNG(K) = FNG(K)*DUMFNG(K) - END DO - -! TOP OF MODEL - - K = KTE - FALTNDR = FALOUTR(K)/DZQ(k) - FALTNDI = FALOUTI(K)/DZQ(k) - FALTNDNI = FALOUTNI(K)/DZQ(k) - FALTNDS = FALOUTS(K)/DZQ(k) - FALTNDNS = FALOUTNS(K)/DZQ(k) - FALTNDNR = FALOUTNR(K)/DZQ(k) - FALTNDC = FALOUTC(K)/DZQ(k) - FALTNDNC = FALOUTNC(K)/DZQ(k) - FALTNDG = FALOUTG(K)/DZQ(k) - FALTNDNG = FALOUTNG(K)/DZQ(k) -! ADD FALLOUT TERMS TO EULERIAN TENDENCIES - - QRSTEN(K) = QRSTEN(K)-FALTNDR/NSTEP/RHO(k) - QISTEN(K) = QISTEN(K)-FALTNDI/NSTEP/RHO(k) - NI3DTEN(K) = NI3DTEN(K)-FALTNDNI/NSTEP/RHO(k) - QNISTEN(K) = QNISTEN(K)-FALTNDS/NSTEP/RHO(k) - NS3DTEN(K) = NS3DTEN(K)-FALTNDNS/NSTEP/RHO(k) - NR3DTEN(K) = NR3DTEN(K)-FALTNDNR/NSTEP/RHO(k) - QCSTEN(K) = QCSTEN(K)-FALTNDC/NSTEP/RHO(k) - NC3DTEN(K) = NC3DTEN(K)-FALTNDNC/NSTEP/RHO(k) - QGSTEN(K) = QGSTEN(K)-FALTNDG/NSTEP/RHO(k) - NG3DTEN(K) = NG3DTEN(K)-FALTNDNG/NSTEP/RHO(k) - - NISTEN(K) = NISTEN(K)-FALTNDNI/NSTEP/RHO(k) - NSSTEN(K) = NSSTEN(K)-FALTNDNS/NSTEP/RHO(k) - NRSTEN(K) = NRSTEN(K)-FALTNDNR/NSTEP/RHO(k) - NCSTEN(K) = NCSTEN(K)-FALTNDNC/NSTEP/RHO(k) - NGSTEN(K) = NGSTEN(K)-FALTNDNG/NSTEP/RHO(k) - - DUMR(K) = DUMR(K)-FALTNDR*DT/NSTEP - DUMI(K) = DUMI(K)-FALTNDI*DT/NSTEP - DUMFNI(K) = DUMFNI(K)-FALTNDNI*DT/NSTEP - DUMQS(K) = DUMQS(K)-FALTNDS*DT/NSTEP - DUMFNS(K) = DUMFNS(K)-FALTNDNS*DT/NSTEP - DUMFNR(K) = DUMFNR(K)-FALTNDNR*DT/NSTEP - DUMC(K) = DUMC(K)-FALTNDC*DT/NSTEP - DUMFNC(K) = DUMFNC(K)-FALTNDNC*DT/NSTEP - DUMG(K) = DUMG(K)-FALTNDG*DT/NSTEP - DUMFNG(K) = DUMFNG(K)-FALTNDNG*DT/NSTEP - - DO K = KTE-1,KTS,-1 - FALTNDR = (FALOUTR(K+1)-FALOUTR(K))/DZQ(K) - FALTNDI = (FALOUTI(K+1)-FALOUTI(K))/DZQ(K) - FALTNDNI = (FALOUTNI(K+1)-FALOUTNI(K))/DZQ(K) - FALTNDS = (FALOUTS(K+1)-FALOUTS(K))/DZQ(K) - FALTNDNS = (FALOUTNS(K+1)-FALOUTNS(K))/DZQ(K) - FALTNDNR = (FALOUTNR(K+1)-FALOUTNR(K))/DZQ(K) - FALTNDC = (FALOUTC(K+1)-FALOUTC(K))/DZQ(K) - FALTNDNC = (FALOUTNC(K+1)-FALOUTNC(K))/DZQ(K) - FALTNDG = (FALOUTG(K+1)-FALOUTG(K))/DZQ(K) - FALTNDNG = (FALOUTNG(K+1)-FALOUTNG(K))/DZQ(K) - -! ADD FALLOUT TERMS TO EULERIAN TENDENCIES - - QRSTEN(K) = QRSTEN(K)+FALTNDR/NSTEP/RHO(k) - QISTEN(K) = QISTEN(K)+FALTNDI/NSTEP/RHO(k) - NI3DTEN(K) = NI3DTEN(K)+FALTNDNI/NSTEP/RHO(k) - QNISTEN(K) = QNISTEN(K)+FALTNDS/NSTEP/RHO(k) - NS3DTEN(K) = NS3DTEN(K)+FALTNDNS/NSTEP/RHO(k) - NR3DTEN(K) = NR3DTEN(K)+FALTNDNR/NSTEP/RHO(k) - QCSTEN(K) = QCSTEN(K)+FALTNDC/NSTEP/RHO(k) - NC3DTEN(K) = NC3DTEN(K)+FALTNDNC/NSTEP/RHO(k) - QGSTEN(K) = QGSTEN(K)+FALTNDG/NSTEP/RHO(k) - NG3DTEN(K) = NG3DTEN(K)+FALTNDNG/NSTEP/RHO(k) - - NISTEN(K) = NISTEN(K)+FALTNDNI/NSTEP/RHO(k) - NSSTEN(K) = NSSTEN(K)+FALTNDNS/NSTEP/RHO(k) - NRSTEN(K) = NRSTEN(K)+FALTNDNR/NSTEP/RHO(k) - NCSTEN(K) = NCSTEN(K)+FALTNDNC/NSTEP/RHO(k) - NGSTEN(K) = NGSTEN(K)+FALTNDNG/NSTEP/RHO(k) - - DUMR(K) = DUMR(K)+FALTNDR*DT/NSTEP - DUMI(K) = DUMI(K)+FALTNDI*DT/NSTEP - DUMFNI(K) = DUMFNI(K)+FALTNDNI*DT/NSTEP - DUMQS(K) = DUMQS(K)+FALTNDS*DT/NSTEP - DUMFNS(K) = DUMFNS(K)+FALTNDNS*DT/NSTEP - DUMFNR(K) = DUMFNR(K)+FALTNDNR*DT/NSTEP - DUMC(K) = DUMC(K)+FALTNDC*DT/NSTEP - DUMFNC(K) = DUMFNC(K)+FALTNDNC*DT/NSTEP - DUMG(K) = DUMG(K)+FALTNDG*DT/NSTEP - DUMFNG(K) = DUMFNG(K)+FALTNDNG*DT/NSTEP - -#ifdef ECPP - RSED(K)=RSED(K)+FALOUTR(K)/NSTEP - ISED(K)=ISED(K)+FALOUTI(K)/NSTEP - CSED(K)=CSED(K)+FALOUTC(K)/NSTEP - SSED(K)=SSED(K)+FALOUTS(K)/NSTEP - GSED(K)=GSED(K)+FALOUTG(K)/NSTEP -#endif - - END DO - -! GET PRECIPITATION AND SNOWFALL ACCUMULATION DURING THE TIME STEP -! FACTOR OF 1000 CONVERTS FROM M TO MM, BUT DIVISION BY DENSITY -! OF LIQUID WATER CANCELS THIS FACTOR OF 1000 - - PRECRT = PRECRT+(FALOUTR(KTS)+FALOUTC(KTS)+FALOUTS(KTS)+FALOUTI(KTS)+FALOUTG(KTS)) & - *DT/NSTEP - SNOWRT = SNOWRT+(FALOUTS(KTS)+FALOUTI(KTS)+FALOUTG(KTS))*DT/NSTEP - - END DO - - DO K=KTS,KTE - -! ADD ON SEDIMENTATION TENDENCIES FOR MIXING RATIO TO REST OF TENDENCIES - - QR3DTEN(K)=QR3DTEN(K)+QRSTEN(K) - QI3DTEN(K)=QI3DTEN(K)+QISTEN(K) - QC3DTEN(K)=QC3DTEN(K)+QCSTEN(K) - QG3DTEN(K)=QG3DTEN(K)+QGSTEN(K) - QNI3DTEN(K)=QNI3DTEN(K)+QNISTEN(K) - -! PUT ALL CLOUD ICE IN SNOW CATEGORY IF MEAN DIAMETER EXCEEDS 2 * dcs - -! V1.7 -!hm 7/9/09 bug fix -! IF (QI3D(K).GE.QSMALL.AND.T3D(K).LT.273.15) THEN - IF (QI3D(K).GE.QSMALL.AND.T3D(K).LT.TMELT.AND.LAMI(K).GE.1.E-10) THEN - - IF (1./LAMI(K).GE.2.*DCS) THEN - QNI3DTEN(K) = QNI3DTEN(K)+QI3D(K)/DT+ QI3DTEN(K) - NS3DTEN(K) = NS3DTEN(K)+NI3D(K)/DT+ NI3DTEN(K) - QI3DTEN(K) = -QI3D(K)/DT - NI3DTEN(K) = -NI3D(K)/DT - END IF - END IF - -! hm add tendencies here, then call sizeparameter -! to ensure consisitency between mixing ratio and number concentration - - QC3D(k) = QC3D(k)+QC3DTEN(k)*DT - QI3D(k) = QI3D(k)+QI3DTEN(k)*DT - QNI3D(k) = QNI3D(k)+QNI3DTEN(k)*DT - QR3D(k) = QR3D(k)+QR3DTEN(k)*DT - NC3D(k) = NC3D(k)+NC3DTEN(k)*DT - NI3D(k) = NI3D(k)+NI3DTEN(k)*DT - NS3D(k) = NS3D(k)+NS3DTEN(k)*DT - NR3D(k) = NR3D(k)+NR3DTEN(k)*DT - - IF (IGRAUP.EQ.0) THEN - QG3D(k) = QG3D(k)+QG3DTEN(k)*DT - NG3D(k) = NG3D(k)+NG3DTEN(k)*DT - END IF - -! ADD TEMPERATURE AND WATER VAPOR TENDENCIES FROM MICROPHYSICS - T3D(K) = T3D(K)+T3DTEN(k)*DT - QV3D(K) = QV3D(K)+QV3DTEN(k)*DT - -! SATURATION VAPOR PRESSURE AND MIXING RATIO - -! hm, add fix for low pressure, 5/12/10 - EVS(K) = min(0.99*pres(k),POLYSVP(T3D(K),0)) ! PA - EIS(K) = min(0.99*pres(k),POLYSVP(T3D(K),1)) ! PA - -! MAKE SURE ICE SATURATION DOESN'T EXCEED WATER SAT. NEAR FREEZING - - IF (EIS(K).GT.EVS(K)) EIS(K) = EVS(K) - - QVS(K) = EP_2*EVS(K)/(PRES(K)-EVS(K)) - QVI(K) = EP_2*EIS(K)/(PRES(K)-EIS(K)) - - QVQVS(K) = QV3D(K)/QVS(K) - QVQVSI(K) = QV3D(K)/QVI(K) - -! AT SUBSATURATION, REMOVE SMALL AMOUNTS OF CLOUD/PRECIP WATER - -! V1.3, change limit from 10^-7 to 10^-6 -! V1.7 7/9/09 change limit from 10^-6 to 10^-8 - - IF (QVQVS(K).LT.0.9) THEN - IF (QR3D(K).LT.1.E-8) THEN - QV3D(K)=QV3D(K)+QR3D(K) - T3D(K)=T3D(K)-QR3D(K)*XXLV(K)/CPM(K) - QR3D(K)=0. - END IF - IF (QC3D(K).LT.1.E-8) THEN - QV3D(K)=QV3D(K)+QC3D(K) - T3D(K)=T3D(K)-QC3D(K)*XXLV(K)/CPM(K) - QC3D(K)=0. - END IF - END IF - - IF (QVQVSI(K).LT.0.9) THEN - IF (QI3D(K).LT.1.E-8) THEN - QV3D(K)=QV3D(K)+QI3D(K) - T3D(K)=T3D(K)-QI3D(K)*XXLS(K)/CPM(K) - QI3D(K)=0. - END IF - IF (QNI3D(K).LT.1.E-8) THEN - QV3D(K)=QV3D(K)+QNI3D(K) - T3D(K)=T3D(K)-QNI3D(K)*XXLS(K)/CPM(K) - QNI3D(K)=0. - END IF - IF (QG3D(K).LT.1.E-8) THEN - QV3D(K)=QV3D(K)+QG3D(K) - T3D(K)=T3D(K)-QG3D(K)*XXLS(K)/CPM(K) - QG3D(K)=0. - END IF - END IF - -!.................................................................. -! IF MIXING RATIO < QSMALL SET MIXING RATIO AND NUMBER CONC TO ZERO - - IF (QC3D(K).LT.QSMALL) THEN -!+++mhwang - QV3D(K)=QV3D(K)+QC3D(K) - T3D(K)=T3D(K)-QC3D(K)*XXLV(K)/CPM(K) -!---mhwang - QC3D(K) = 0. - NC3D(K) = 0. - EFFC(K) = 0. - END IF - IF (QR3D(K).LT.QSMALL) THEN -!+++mhwang - QV3D(K)=QV3D(K)+QR3D(K) - T3D(K)=T3D(K)-QR3D(K)*XXLV(K)/CPM(K) -!---mhwang - QR3D(K) = 0. - NR3D(K) = 0. - EFFR(K) = 0. - END IF - IF (QI3D(K).LT.QSMALL) THEN -!+++mhwang - QV3D(K)=QV3D(K)+QI3D(K) - T3D(K)=T3D(K)-QI3D(K)*XXLS(K)/CPM(K) -!+++mhwang - QI3D(K) = 0. - NI3D(K) = 0. - EFFI(K) = 0. - END IF - IF (QNI3D(K).LT.QSMALL) THEN -!+++mhwang - QV3D(K)=QV3D(K)+QNI3D(K) - T3D(K)=T3D(K)-QNI3D(K)*XXLS(K)/CPM(K) -!+++mhwang - QNI3D(K) = 0. - NS3D(K) = 0. - EFFS(K) = 0. - END IF - IF (QG3D(K).LT.QSMALL) THEN -!+++mhwang - QV3D(K)=QV3D(K)+QG3D(K) - T3D(K)=T3D(K)-QG3D(K)*XXLS(K)/CPM(K) -!+++mhwang - QG3D(K) = 0. - NG3D(K) = 0. - EFFG(K) = 0. - END IF - -!.................................. -! IF THERE IS NO CLOUD/PRECIP WATER, THEN SKIP CALCULATIONS - - IF (QC3D(K).LT.QSMALL.AND.QI3D(K).LT.QSMALL.AND.QNI3D(K).LT.QSMALL & - .AND.QR3D(K).LT.QSMALL.AND.QG3D(K).LT.QSMALL) GOTO 500 - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! CALCULATE INSTANTANEOUS PROCESSES - -! ADD MELTING OF CLOUD ICE TO FORM RAIN - - IF (QI3D(K).GE.QSMALL.AND.T3D(K).GE.TMELT) THEN - QR3D(K) = QR3D(K)+QI3D(K) - T3D(K) = T3D(K)-QI3D(K)*XLF(K)/CPM(K) -! hm 7/26/11, new output - mlt1d(k)=mlt1d(k)+qi3d(k)/dt - QI3D(K) = 0. - NR3D(K) = NR3D(K)+NI3D(K) - NI3D(K) = 0. - END IF - -! ****SENSITIVITY - NO ICE - IF (ILIQ.EQ.1) GOTO 778 - -! HOMOGENEOUS FREEZING OF CLOUD WATER - - IF (T3D(K).LE.233.15.AND.QC3D(K).GE.QSMALL) THEN - QI3D(K)=QI3D(K)+QC3D(K) - T3D(K)=T3D(K)+QC3D(K)*XLF(K)/CPM(K) - QC3D(K)=0. -#ifdef CLUBB_CRM -!+++mhwang test how SAM_CLUBB sensitive to this - NI3D(K)=NI3D(K)+NC3D(K) * NNUCCC_REDUCE_COEF ! -#else - NI3D(K)=NI3D(K)+NC3D(K) -#endif - NC3D(K)=0. - END IF - -! HOMOGENEOUS FREEZING OF RAIN - - IF (IGRAUP.EQ.0) THEN - - IF (T3D(K).LE.233.15.AND.QR3D(K).GE.QSMALL) THEN - QG3D(K) = QG3D(K)+QR3D(K) - T3D(K) = T3D(K)+QR3D(K)*XLF(K)/CPM(K) - QR3D(K) = 0. - NG3D(K) = NG3D(K)+ NR3D(K) - NR3D(K) = 0. - END IF - - ELSE IF (IGRAUP.EQ.1) THEN - - IF (T3D(K).LE.233.15.AND.QR3D(K).GE.QSMALL) THEN - QNI3D(K) = QNI3D(K)+QR3D(K) - T3D(K) = T3D(K)+QR3D(K)*XLF(K)/CPM(K) - QR3D(K) = 0. - NS3D(K) = NS3D(K)+NR3D(K) - NR3D(K) = 0. - END IF - - END IF - - 778 CONTINUE - -! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE - - NI3D(K) = MAX(0.,NI3D(K)) - NS3D(K) = MAX(0.,NS3D(K)) - NC3D(K) = MAX(0.,NC3D(K)) - NR3D(K) = MAX(0.,NR3D(K)) - NG3D(K) = MAX(0.,NG3D(K)) - -!...................................................................... -! CLOUD ICE - - IF (QI3D(K).GE.QSMALL) THEN - LAMI(K) = (CONS12* & - NI3D(K)/QI3D(K))**(1./DI) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMI(K).LT.LAMMINI) THEN - - LAMI(K) = LAMMINI - - N0I(K) = LAMI(K)**(DI+1.)*QI3D(K)/CONS12 - - NI3D(K) = N0I(K)/LAMI(K) - ELSE IF (LAMI(K).GT.LAMMAXI) THEN - LAMI(K) = LAMMAXI - N0I(K) = LAMI(K)**(DI+1.)*QI3D(K)/CONS12 - - NI3D(K) = N0I(K)/LAMI(K) - END IF - END IF - -!...................................................................... -! RAIN - - IF (QR3D(K).GE.QSMALL) THEN - LAMR(K) = (PI*RHOW*NR3D(K)/QR3D(K))**(1./3.) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMR(K).LT.LAMMINR) THEN - - LAMR(K) = LAMMINR - - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - ELSE IF (LAMR(K).GT.LAMMAXR) THEN - LAMR(K) = LAMMAXR - N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW) - - NR3D(K) = N0RR(K)/LAMR(K) - END IF - - END IF - -!...................................................................... -! CLOUD DROPLETS - -! MARTIN ET AL. (1994) FORMULA FOR PGAM - - IF (QC3D(K).GE.QSMALL) THEN - - !bloss: option for fixing pgam - if(dofix_pgam) then - pgam(k) = pgam_fixed - else - -! DUM = PRES(K)/(R*T3D(K)) -! V1.5 - PGAM(K)=0.0005714*(NC3D(K)/1.E6*RHO(K))+0.2714 - PGAM(K)=1./(PGAM(K)**2)-1. - PGAM(K)=MAX(PGAM(K),2.) - PGAM(K)=MIN(PGAM(K),10.) - - end if - -! CALCULATE LAMC - - LAMC(K) = (CONS26*NC3D(K)*GAMMA(PGAM(K)+4.)/ & - (QC3D(K)*GAMMA(PGAM(K)+1.)))**(1./3.) - -! LAMMIN, 60 MICRON DIAMETER -! LAMMAX, 1 MICRON - - LAMMIN = (PGAM(K)+1.)/60.E-6 - LAMMAX = (PGAM(K)+1.)/1.E-6 - - IF (LAMC(K).LT.LAMMIN) THEN - LAMC(K) = LAMMIN - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - - ELSE IF (LAMC(K).GT.LAMMAX) THEN - LAMC(K) = LAMMAX - NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+ & - LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26 - - END IF - - END IF - -!...................................................................... -! SNOW - - IF (QNI3D(K).GE.QSMALL) THEN - LAMS(K) = (CONS1*NS3D(K)/QNI3D(K))**(1./DS) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMS(K).LT.LAMMINS) THEN - LAMS(K) = LAMMINS - N0S(K) = LAMS(K)**(DS+1.)*QNI3D(K)/CONS1 - - NS3D(K) = N0S(K)/LAMS(K) - - ELSE IF (LAMS(K).GT.LAMMAXS) THEN - - LAMS(K) = LAMMAXS - N0S(K) = LAMS(K)**(DS+1.)*QNI3D(K)/CONS1 - NS3D(K) = N0S(K)/LAMS(K) - END IF - - END IF - -!...................................................................... -! GRAUPEL - - IF (QG3D(K).GE.QSMALL) THEN - LAMG(K) = (CONS2*NG3D(K)/QG3D(K))**(1./DG) - -! CHECK FOR SLOPE - -! ADJUST VARS - - IF (LAMG(K).LT.LAMMING) THEN - LAMG(K) = LAMMING - N0G(K) = LAMG(K)**(DG+1.)*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - - ELSE IF (LAMG(K).GT.LAMMAXG) THEN - - LAMG(K) = LAMMAXG - N0G(K) = LAMG(K)**(DG+1.)*QG3D(K)/CONS2 - - NG3D(K) = N0G(K)/LAMG(K) - END IF - - END IF - - 500 CONTINUE - -! CALCULATE EFFECTIVE RADIUS - -#ifdef CLUBB_CRM - ! Account for subgrid scale effective droplet radii - IF ( CF3D(K) > cloud_frac_thresh ) THEN - TMPQSMALL = QSMALL / CF3D(K) - ELSE - TMPQSMALL = QSMALL - END IF - - IF (QI3D(K).GE.TMPQSMALL) THEN - EFFI(K) = 3./LAMI(K)/2.*1.E6 - ELSE - EFFI(K) = 25. - END IF - - IF (QNI3D(K).GE.TMPQSMALL) THEN - EFFS(K) = 3./LAMS(K)/2.*1.E6 - ELSE - EFFS(K) = 25. - END IF - - IF (QR3D(K).GE.TMPQSMALL) THEN - EFFR(K) = 3./LAMR(K)/2.*1.E6 - ELSE - EFFR(K) = 25. - END IF - - IF (QC3D(K).GE.TMPQSMALL) THEN - EFFC(K) = GAMMA(PGAM(K)+4.)/ & - GAMMA(PGAM(K)+3.)/LAMC(K)/2.*1.E6 - ELSE - EFFC(K) = 25. - END IF - - IF (QG3D(K).GE.TMPQSMALL) THEN - EFFG(K) = 3./LAMG(K)/2.*1.E6 - ELSE - EFFG(K) = 25. - END IF -#else - IF (QI3D(K).GE.QSMALL) THEN - EFFI(K) = 3./LAMI(K)/2.*1.E6 - ELSE - EFFI(K) = 25. - END IF - - IF (QNI3D(K).GE.QSMALL) THEN - EFFS(K) = 3./LAMS(K)/2.*1.E6 - ELSE - EFFS(K) = 25. - END IF - - IF (QR3D(K).GE.QSMALL) THEN - EFFR(K) = 3./LAMR(K)/2.*1.E6 - ELSE - EFFR(K) = 25. - END IF - - IF (QC3D(K).GE.QSMALL) THEN - EFFC(K) = GAMMA(PGAM(K)+4.)/ & - GAMMA(PGAM(K)+3.)/LAMC(K)/2.*1.E6 - ELSE - EFFC(K) = 25. - END IF - - IF (QG3D(K).GE.QSMALL) THEN - EFFG(K) = 3./LAMG(K)/2.*1.E6 - ELSE - EFFG(K) = 25. - END IF -#endif /*CLUBB_CRM*/ - -! HM ADD 1/10/06, ADD UPPER BOUND ON ICE NUMBER, THIS IS NEEDED -! TO PREVENT VERY LARGE ICE NUMBER DUE TO HOMOGENEOUS FREEZING -! OF DROPLETS, ESPECIALLY WHEN INUM = 1, SET MAX AT 10 CM-3 - NI3D(K) = MIN(NI3D(K),10.E6/RHO(K)) -! ADD BOUND ON DROPLET NUMBER - CANNOT EXCEED AEROSOL CONCENTRATION - IF (INUM.EQ.0.AND.IACT.EQ.2) THEN - NC3D(K) = MIN(NC3D(K),(NANEW1+NANEW2)/RHO(K)) - END IF -! SWITCH FOR CONSTANT DROPLET NUMBER - IF (INUM.EQ.1) THEN -! CHANGE NDCNST FROM CM-3 TO KG-1 - NC3D(K) = NDCNST*1.E6/RHO(K) - END IF -#ifdef CLUBB_CRM -! ADDITION BY UWM TO ENSURE THE POSITIVE DEFINITENESS OF VAPOR WATER MIXING RATIO - CALL POSITIVE_QV_ADJ( QV3D(K), QC3D(K), QR3D(K), QI3D(K), & - QNI3D(K), QG3D(K), T3D(K) ) -#endif /*CLUBB_CRM*/ - -#ifdef ECPP -! calculate relative humidity -! - ! SATURATION VAPOR PRESSURE AND MIXING RATIO - - EVS(K) = POLYSVP(T3D(K),0) ! PA -! MAKE SURE ICE SATURATION DOESN'T EXCEED WATER SAT. NEAR FREEZING - QVS(K) = .622*EVS(K)/(PRES(K)-EVS(K)) - QVQVS(K) = QV3D(K)/QVS(K) - RH3D(K)= min(1.0, QVQVS(K)) -#endif /*ECPP*/ - - END DO !!! K LOOP - - 400 CONTINUE - -! ALL DONE !!!!!!!!!!! - RETURN - END SUBROUTINE M2005MICRO_GRAUPEL - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - REAL FUNCTION POLYSVP (T,TYPE) - -!------------------------------------------- - -! COMPUTE SATURATION VAPOR PRESSURE - -! POLYSVP RETURNED IN UNITS OF PA. -! T IS INPUT IN UNITS OF K. -! TYPE REFERS TO SATURATION WITH RESPECT TO LIQUID (0) OR ICE (1) - - IMPLICIT NONE - - REAL DUM - REAL T - INTEGER TYPE - -! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM FLATAU ET AL. 1992, TABLE 4 (RIGHT-HAND COLUMN) - -! ice - real a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i - data a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i /& - 6.11147274, 0.503160820, 0.188439774e-1, & - 0.420895665e-3, 0.615021634e-5,0.602588177e-7, & - 0.385852041e-9, 0.146898966e-11, 0.252751365e-14/ - -! liquid - real a0,a1,a2,a3,a4,a5,a6,a7,a8 - -! V1.7 - data a0,a1,a2,a3,a4,a5,a6,a7,a8 /& - 6.11239921, 0.443987641, 0.142986287e-1, & - 0.264847430e-3, 0.302950461e-5, 0.206739458e-7, & - 0.640689451e-10,-0.952447341e-13,-0.976195544e-15/ - real dt - -! ICE - - IF (TYPE.EQ.1) THEN - -! POLYSVP = 10.**(-9.09718*(273.16/T-1.)-3.56654* & -! LOG10(273.16/T)+0.876793*(1.-T/273.16)+ & -! LOG10(6.1071))*100. - - - dt = max(-80.,t-273.16) - polysvp = a0i + dt*(a1i+dt*(a2i+dt*(a3i+dt*(a4i+dt*(a5i+dt*(a6i+dt*(a7i+a8i*dt))))))) - polysvp = polysvp*100. - - END IF - -! LIQUID - - IF (TYPE.EQ.0) THEN - - dt = max(-80.,t-273.16) - polysvp = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) - polysvp = polysvp*100. - -! POLYSVP = 10.**(-7.90298*(373.16/T-1.)+ & -! 5.02808*LOG10(373.16/T)- & -! 1.3816E-7*(10**(11.344*(1.-T/373.16))-1.)+ & -! 8.1328E-3*(10**(-3.49149*(373.16/T-1.))-1.)+ & -! LOG10(1013.246))*100. - - END IF - - - END FUNCTION POLYSVP - -!------------------------------------------------------------------------------ - - REAL FUNCTION GAMMA(X) -!---------------------------------------------------------------------- -! -! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X. -! COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1. -! THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA -! FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS. COEFFICIENTS -! FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED. -! THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2. -! THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE -! COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE -! MACHINE-DEPENDENT CONSTANTS. -! -! -!******************************************************************* -!******************************************************************* -! -! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS -! -! BETA - RADIX FOR THE FLOATING-POINT REPRESENTATION -! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS -! XBIG - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE -! IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION -! GAMMA(XBIG) = BETA**MAXEXP -! XINF - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER; -! APPROXIMATELY BETA**MAXEXP -! EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT -! 1.0+EPS .GT. 1.0 -! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT -! 1/XMININ IS MACHINE REPRESENTABLE -! -! APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE: -! -! BETA MAXEXP XBIG -! -! CRAY-1 (S.P.) 2 8191 966.961 -! CYBER 180/855 -! UNDER NOS (S.P.) 2 1070 177.803 -! IEEE (IBM/XT, -! SUN, ETC.) (S.P.) 2 128 35.040 -! IEEE (IBM/XT, -! SUN, ETC.) (D.P.) 2 1024 171.624 -! IBM 3033 (D.P.) 16 63 57.574 -! VAX D-FORMAT (D.P.) 2 127 34.844 -! VAX G-FORMAT (D.P.) 2 1023 171.489 -! -! XINF EPS XMININ -! -! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466 -! CYBER 180/855 -! UNDER NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294 -! IEEE (IBM/XT, -! SUN, ETC.) (S.P.) 3.40E+38 1.19E-7 1.18E-38 -! IEEE (IBM/XT, -! SUN, ETC.) (D.P.) 1.79D+308 2.22D-16 2.23D-308 -! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76 -! VAX D-FORMAT (D.P.) 1.70D+38 1.39D-17 5.88D-39 -! VAX G-FORMAT (D.P.) 8.98D+307 1.11D-16 1.12D-308 -! -!******************************************************************* -!******************************************************************* -! -! ERROR RETURNS -! -! THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR -! WHEN OVERFLOW WOULD OCCUR. THE COMPUTATION IS BELIEVED -! TO BE FREE OF UNDERFLOW AND OVERFLOW. -! -! -! INTRINSIC FUNCTIONS REQUIRED ARE: -! -! INT, DBLE, EXP, LOG, REAL, SIN -! -! -! REFERENCES: AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL -! FUNCTIONS W. J. CODY, LECTURE NOTES IN MATHEMATICS, -! 506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON -! (ED.), SPRINGER VERLAG, BERLIN, 1976. -! -! COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND -! SONS, NEW YORK, 1968. -! -! LATEST MODIFICATION: OCTOBER 12, 1989 -! -! AUTHORS: W. J. CODY AND L. STOLTZ -! APPLIED MATHEMATICS DIVISION -! ARGONNE NATIONAL LABORATORY -! ARGONNE, IL 60439 -! -!---------------------------------------------------------------------- - implicit none - INTEGER I,N - LOGICAL PARITY - REAL & - CONV,EPS,FACT,HALF,ONE,RES,SUM,TWELVE, & - TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO - REAL, DIMENSION(7) :: C - REAL, DIMENSION(8) :: P - REAL, DIMENSION(8) :: Q -!---------------------------------------------------------------------- -! MATHEMATICAL CONSTANTS -!---------------------------------------------------------------------- - DATA ONE,HALF,TWELVE,TWO,ZERO/1.0E0,0.5E0,12.0E0,2.0E0,0.0E0/ - - -!---------------------------------------------------------------------- -! MACHINE DEPENDENT PARAMETERS -!---------------------------------------------------------------------- - DATA XBIG,XMININ,EPS/35.040E0,1.18E-38,1.19E-7/,XINF/3.4E38/ -!---------------------------------------------------------------------- -! NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX -! APPROXIMATION OVER (1,2). -!---------------------------------------------------------------------- - DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1, & - -3.79804256470945635097577E+2,6.29331155312818442661052E+2, & - 8.66966202790413211295064E+2,-3.14512729688483675254357E+4, & - -3.61444134186911729807069E+4,6.64561438202405440627855E+4/ - DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2, & - -1.01515636749021914166146E+3,-3.10777167157231109440444E+3, & - 2.25381184209801510330112E+4,4.75584627752788110767815E+3, & - -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/ -!---------------------------------------------------------------------- -! COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF). -!---------------------------------------------------------------------- - DATA C/-1.910444077728E-03,8.4171387781295E-04, & - -5.952379913043012E-04,7.93650793500350248E-04, & - -2.777777777777681622553E-03,8.333333333333333331554247E-02, & - 5.7083835261E-03/ -!---------------------------------------------------------------------- -! STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT -!---------------------------------------------------------------------- - CONV(I) = REAL(I) - PARITY=.FALSE. - FACT=ONE - N=0 - Y=X - IF(Y.LE.ZERO)THEN -!---------------------------------------------------------------------- -! ARGUMENT IS NEGATIVE -!---------------------------------------------------------------------- - Y=-X - Y1=AINT(Y) - RES=Y-Y1 - IF(RES.NE.ZERO)THEN - IF(Y1.NE.AINT(Y1*HALF)*TWO)PARITY=.TRUE. - FACT=-PI/SIN(PI*RES) - Y=Y+ONE - ELSE - RES=XINF - GOTO 900 - ENDIF - ENDIF -!---------------------------------------------------------------------- -! ARGUMENT IS POSITIVE -!---------------------------------------------------------------------- - IF(Y.LT.EPS)THEN -!---------------------------------------------------------------------- -! ARGUMENT .LT. EPS -!---------------------------------------------------------------------- - IF(Y.GE.XMININ)THEN - RES=ONE/Y - ELSE - RES=XINF - GOTO 900 - ENDIF - ELSEIF(Y.LT.TWELVE)THEN - Y1=Y - IF(Y.LT.ONE)THEN -!---------------------------------------------------------------------- -! 0.0 .LT. ARGUMENT .LT. 1.0 -!---------------------------------------------------------------------- - Z=Y - Y=Y+ONE - ELSE -!---------------------------------------------------------------------- -! 1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY -!---------------------------------------------------------------------- - N=INT(Y)-1 - Y=Y-CONV(N) - Z=Y-ONE - ENDIF -!---------------------------------------------------------------------- -! EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0 -!---------------------------------------------------------------------- - XNUM=ZERO - XDEN=ONE - DO I=1,8 - XNUM=(XNUM+P(I))*Z - XDEN=XDEN*Z+Q(I) - END DO - RES=XNUM/XDEN+ONE - IF(Y1.LT.Y)THEN -!---------------------------------------------------------------------- -! ADJUST RESULT FOR CASE 0.0 .LT. ARGUMENT .LT. 1.0 -!---------------------------------------------------------------------- - RES=RES/Y1 - ELSEIF(Y1.GT.Y)THEN -!---------------------------------------------------------------------- -! ADJUST RESULT FOR CASE 2.0 .LT. ARGUMENT .LT. 12.0 -!---------------------------------------------------------------------- - DO I=1,N - RES=RES*Y - Y=Y+ONE - END DO - ENDIF - ELSE -!---------------------------------------------------------------------- -! EVALUATE FOR ARGUMENT .GE. 12.0, -!---------------------------------------------------------------------- - IF(Y.LE.XBIG)THEN - YSQ=Y*Y - SUM=C(7) - DO I=1,6 - SUM=SUM/YSQ+C(I) - END DO - SUM=SUM/Y-Y+SQRTPI - SUM=SUM+(Y-HALF)*LOG(Y) - RES=EXP(SUM) - ELSE - RES=XINF - GOTO 900 - ENDIF - ENDIF -!---------------------------------------------------------------------- -! FINAL ADJUSTMENTS AND RETURN -!---------------------------------------------------------------------- - IF(PARITY)RES=-RES - IF(FACT.NE.ONE)RES=FACT/RES - 900 GAMMA=RES - RETURN -! ---------- LAST LINE OF GAMMA ---------- - END FUNCTION GAMMA - - - REAL FUNCTION DERF1(X) - IMPLICIT NONE - REAL X - REAL, DIMENSION(0 : 64) :: A, B - REAL W,T,Y - INTEGER K,I - DATA A/ & - 0.00000000005958930743E0, -0.00000000113739022964E0, & - 0.00000001466005199839E0, -0.00000016350354461960E0, & - 0.00000164610044809620E0, -0.00001492559551950604E0, & - 0.00012055331122299265E0, -0.00085483269811296660E0, & - 0.00522397762482322257E0, -0.02686617064507733420E0, & - 0.11283791670954881569E0, -0.37612638903183748117E0, & - 1.12837916709551257377E0, & - 0.00000000002372510631E0, -0.00000000045493253732E0, & - 0.00000000590362766598E0, -0.00000006642090827576E0, & - 0.00000067595634268133E0, -0.00000621188515924000E0, & - 0.00005103883009709690E0, -0.00037015410692956173E0, & - 0.00233307631218880978E0, -0.01254988477182192210E0, & - 0.05657061146827041994E0, -0.21379664776456006580E0, & - 0.84270079294971486929E0, & - 0.00000000000949905026E0, -0.00000000018310229805E0, & - 0.00000000239463074000E0, -0.00000002721444369609E0, & - 0.00000028045522331686E0, -0.00000261830022482897E0, & - 0.00002195455056768781E0, -0.00016358986921372656E0, & - 0.00107052153564110318E0, -0.00608284718113590151E0, & - 0.02986978465246258244E0, -0.13055593046562267625E0, & - 0.67493323603965504676E0, & - 0.00000000000382722073E0, -0.00000000007421598602E0, & - 0.00000000097930574080E0, -0.00000001126008898854E0, & - 0.00000011775134830784E0, -0.00000111992758382650E0, & - 0.00000962023443095201E0, -0.00007404402135070773E0, & - 0.00050689993654144881E0, -0.00307553051439272889E0, & - 0.01668977892553165586E0, -0.08548534594781312114E0, & - 0.56909076642393639985E0, & - 0.00000000000155296588E0, -0.00000000003032205868E0, & - 0.00000000040424830707E0, -0.00000000471135111493E0, & - 0.00000005011915876293E0, -0.00000048722516178974E0, & - 0.00000430683284629395E0, -0.00003445026145385764E0, & - 0.00024879276133931664E0, -0.00162940941748079288E0, & - 0.00988786373932350462E0, -0.05962426839442303805E0, & - 0.49766113250947636708E0 / - DATA (B(I), I = 0, 12) / & - -0.00000000029734388465E0, 0.00000000269776334046E0, & - -0.00000000640788827665E0, -0.00000001667820132100E0, & - -0.00000021854388148686E0, 0.00000266246030457984E0, & - 0.00001612722157047886E0, -0.00025616361025506629E0, & - 0.00015380842432375365E0, 0.00815533022524927908E0, & - -0.01402283663896319337E0, -0.19746892495383021487E0, & - 0.71511720328842845913E0 / - DATA (B(I), I = 13, 25) / & - -0.00000000001951073787E0, -0.00000000032302692214E0, & - 0.00000000522461866919E0, 0.00000000342940918551E0, & - -0.00000035772874310272E0, 0.00000019999935792654E0, & - 0.00002687044575042908E0, -0.00011843240273775776E0, & - -0.00080991728956032271E0, 0.00661062970502241174E0, & - 0.00909530922354827295E0, -0.20160072778491013140E0, & - 0.51169696718727644908E0 / - DATA (B(I), I = 26, 38) / & - 0.00000000003147682272E0, -0.00000000048465972408E0, & - 0.00000000063675740242E0, 0.00000003377623323271E0, & - -0.00000015451139637086E0, -0.00000203340624738438E0, & - 0.00001947204525295057E0, 0.00002854147231653228E0, & - -0.00101565063152200272E0, 0.00271187003520095655E0, & - 0.02328095035422810727E0, -0.16725021123116877197E0, & - 0.32490054966649436974E0 / - DATA (B(I), I = 39, 51) / & - 0.00000000002319363370E0, -0.00000000006303206648E0, & - -0.00000000264888267434E0, 0.00000002050708040581E0, & - 0.00000011371857327578E0, -0.00000211211337219663E0, & - 0.00000368797328322935E0, 0.00009823686253424796E0, & - -0.00065860243990455368E0, -0.00075285814895230877E0, & - 0.02585434424202960464E0, -0.11637092784486193258E0, & - 0.18267336775296612024E0 / - DATA (B(I), I = 52, 64) / & - -0.00000000000367789363E0, 0.00000000020876046746E0, & - -0.00000000193319027226E0, -0.00000000435953392472E0, & - 0.00000018006992266137E0, -0.00000078441223763969E0, & - -0.00000675407647949153E0, 0.00008428418334440096E0, & - -0.00017604388937031815E0, -0.00239729611435071610E0, & - 0.02064129023876022970E0, -0.06905562880005864105E0, & - 0.09084526782065478489E0 / - W = ABS(X) - IF (W .LT. 2.2D0) THEN - T = W * W - K = INT(T) - T = T - K - K = K * 13 - Y = ((((((((((((A(K) * T + A(K + 1)) * T + & - A(K + 2)) * T + A(K + 3)) * T + A(K + 4)) * T + & - A(K + 5)) * T + A(K + 6)) * T + A(K + 7)) * T + & - A(K + 8)) * T + A(K + 9)) * T + A(K + 10)) * T + & - A(K + 11)) * T + A(K + 12)) * W - ELSE IF (W .LT. 6.9D0) THEN - K = INT(W) - T = W - K - K = 13 * (K - 2) - Y = (((((((((((B(K) * T + B(K + 1)) * T + & - B(K + 2)) * T + B(K + 3)) * T + B(K + 4)) * T + & - B(K + 5)) * T + B(K + 6)) * T + B(K + 7)) * T + & - B(K + 8)) * T + B(K + 9)) * T + B(K + 10)) * T + & - B(K + 11)) * T + B(K + 12) - Y = Y * Y - Y = Y * Y - Y = Y * Y - Y = 1 - Y * Y - ELSE - Y = 1 - END IF - IF (X .LT. 0) Y = -Y - DERF1 = Y - END FUNCTION DERF1 - -!+---+-----------------------------------------------------------------+ -! - subroutine radar_init - - IMPLICIT NONE - INTEGER:: n - PI5 = PI*PI*PI*PI*PI - lamda4 = lamda_radar*lamda_radar*lamda_radar*lamda_radar - m_w_0 = m_complex_water_ray (lamda_radar, 0.0d0) - m_i_0 = m_complex_ice_maetzler (lamda_radar, 0.0d0) - K_w = (ABS( (m_w_0*m_w_0 - 1.0) /(m_w_0*m_w_0 + 2.0) ))**2 - - do n = 1, nbins+1 - simpson(n) = 0.0d0 - enddo - do n = 1, nbins-1, 2 - simpson(n) = simpson(n) + basis(1) - simpson(n+1) = simpson(n+1) + basis(2) - simpson(n+2) = simpson(n+2) + basis(3) - enddo - - do n = 1, slen - mixingrulestring_s(n:n) = char(0) - matrixstring_s(n:n) = char(0) - inclusionstring_s(n:n) = char(0) - hoststring_s(n:n) = char(0) - hostmatrixstring_s(n:n) = char(0) - hostinclusionstring_s(n:n) = char(0) - mixingrulestring_g(n:n) = char(0) - matrixstring_g(n:n) = char(0) - inclusionstring_g(n:n) = char(0) - hoststring_g(n:n) = char(0) - hostmatrixstring_g(n:n) = char(0) - hostinclusionstring_g(n:n) = char(0) - enddo - - mixingrulestring_s = 'maxwellgarnett' - hoststring_s = 'air' - matrixstring_s = 'water' - inclusionstring_s = 'spheroidal' - hostmatrixstring_s = 'icewater' - hostinclusionstring_s = 'spheroidal' - - mixingrulestring_g = 'maxwellgarnett' - hoststring_g = 'air' - matrixstring_g = 'water' - inclusionstring_g = 'spheroidal' - hostmatrixstring_g = 'icewater' - hostinclusionstring_g = 'spheroidal' - - end subroutine radar_init -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION m_complex_water_ray(lambda,T) - -! Complex refractive Index of Water as function of Temperature T -! [deg C] and radar wavelength lambda [m]; valid for -! lambda in [0.001,1.0] m; T in [-10.0,30.0] deg C -! after Ray (1972) - - IMPLICIT NONE - REAL(kind=selected_real_kind(12)), INTENT(IN):: T,lambda - REAL(kind=selected_real_kind(12)):: epsinf,epss,epsr,epsi - REAL(kind=selected_real_kind(12)):: alpha,lambdas,sigma,nenner - COMPLEX*16, PARAMETER:: i = (0d0,1d0) - - epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T - epss = 78.54d+0 * (1.0 - 4.579d-3 * (T - 25.0) & - + 1.190d-5 * (T - 25.0)*(T - 25.0) & - - 2.800d-8 * (T - 25.0)*(T - 25.0)*(T - 25.0)) - alpha = -16.8129d0/(T+273.16) + 0.0609265d0 - lambdas = 0.00033836d0 * exp(2513.98d0/(T+273.16)) * 1e-2 - - nenner = 1.d0+2.d0*(lambdas/lambda)**(1d0-alpha)*sin(alpha*PI*0.5) & - + (lambdas/lambda)**(2d0-2d0*alpha) - epsr = epsinf + ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & - * sin(alpha*PI*0.5)+1d0)) / nenner - epsi = ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & - * cos(alpha*PI*0.5)+0d0)) / nenner & - + lambda*1.25664/1.88496 - - m_complex_water_ray = SQRT(CMPLX(epsr,-epsi)) - - END FUNCTION m_complex_water_ray - -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION m_complex_ice_maetzler(lambda,T) - -! complex refractive index of ice as function of Temperature T -! [deg C] and radar wavelength lambda [m]; valid for -! lambda in [0.0001,30] m; T in [-250.0,0.0] C -! Original comment from the Matlab-routine of Prof. Maetzler: -! Function for calculating the relative permittivity of pure ice in -! the microwave region, according to C. Maetzler, "Microwave -! properties of ice and snow", in B. Schmitt et al. (eds.) Solar -! System Ices, Astrophys. and Space Sci. Library, Vol. 227, Kluwer -! Academic Publishers, Dordrecht, pp. 241-257 (1998). Input: -! TK = temperature (K), range 20 to 273.15 -! f = frequency in GHz, range 0.01 to 3000 - - IMPLICIT NONE - REAL(kind=selected_real_kind(12)), INTENT(IN):: T,lambda - REAL(kind=selected_real_kind(12)):: f,c,TK,B1,B2,b,deltabeta,betam,beta,theta,alfa - - c = 2.99d8 - TK = T + 273.16 - f = c / lambda * 1d-9 - - B1 = 0.0207 - B2 = 1.16d-11 - b = 335.0d0 - deltabeta = EXP(-10.02 + 0.0364*(TK-273.16)) - betam = (B1/TK) * ( EXP(b/TK) / ((EXP(b/TK)-1)**2) ) + B2*f*f - beta = betam + deltabeta - theta = 300. / TK - 1. - alfa = (0.00504d0 + 0.0062d0*theta) * EXP(-22.1d0*theta) - m_complex_ice_maetzler = 3.1884 + 9.1e-4*(TK-273.16) - m_complex_ice_maetzler = m_complex_ice_maetzler & - + CMPLX(0.0d0, (alfa/f + beta*f)) - m_complex_ice_maetzler = SQRT(CONJG(m_complex_ice_maetzler)) - - END FUNCTION m_complex_ice_maetzler -!+---+-----------------------------------------------------------------+ - - subroutine rayleigh_soak_wetgraupel (x_g, a_geo, b_geo, fmelt, & - meltratio_outside, m_w, m_i, lambda, C_back, & - mixingrule,matrix,inclusion, & - host,hostmatrix,hostinclusion) - - IMPLICIT NONE - - REAL(kind=selected_real_kind(12)), INTENT(in):: x_g, a_geo, b_geo, fmelt, lambda, & - meltratio_outside - REAL(kind=selected_real_kind(12)), INTENT(out):: C_back - COMPLEX*16, INTENT(in):: m_w, m_i - CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion, & - host, hostmatrix, hostinclusion - - COMPLEX*16:: m_core, m_air - REAL(kind=selected_real_kind(12)):: D_large, D_g, rhog, x_w, xw_a, fm, fmgrenz, & - volg, vg, volair, volice, volwater, & - meltratio_outside_grenz, mra - INTEGER:: error - real :: rho_i, rho_w - - rho_i = 900. - rho_w = 1000. - - -! refractive index of air: - m_air = (1.0d0,0.0d0) - -! Limiting the degree of melting --- for safety: - fm = DMAX1(DMIN1(fmelt, 1.0d0), 0.0d0) -! Limiting the ratio of (melting on outside)/(melting on inside): - mra = DMAX1(DMIN1(meltratio_outside, 1.0d0), 0.0d0) - -! ! The relative portion of meltwater melting at outside should increase -! ! from the given input value (between 0 and 1) -! ! to 1 as the degree of melting approaches 1, -! ! so that the melting particle "converges" to a water drop. -! ! Simplest assumption is linear: - mra = mra + (1.0d0-mra)*fm - - x_w = x_g * fm - - D_g = a_geo * x_g**b_geo - - if (D_g .ge. 1d-12) then - - vg = PI/6. * D_g**3 - rhog = DMAX1(DMIN1(x_g / vg, DBLE(rho_i)), 10.0d0) - vg = x_g / rhog - - meltratio_outside_grenz = 1.0d0 - rhog / rho_w - - if (mra .le. meltratio_outside_grenz) then - !..In this case, it cannot happen that, during melting, all the - !.. air inclusions within the ice particle get filled with - !.. meltwater. This only happens at the end of all melting. - volg = vg * (1.0d0 - mra * fm) - - else - !..In this case, at some melting degree fm, all the air - !.. inclusions get filled with meltwater. - fmgrenz=(rho_i-rhog)/(mra*rho_i-rhog+rho_i*rhog/rho_w) - - if (fm .le. fmgrenz) then - !.. not all air pockets are filled: - volg = (1.0 - mra * fm) * vg - else - !..all air pockets are filled with meltwater, now the - !.. entire ice sceleton melts homogeneously: - volg = (x_g - x_w) / rho_i + x_w / rho_w - endif - - endif - - D_large = (6.0 / PI * volg) ** (1./3.) - volice = (x_g - x_w) / (volg * rho_i) - volwater = x_w / (rho_w * volg) - volair = 1.0 - volice - volwater - - !..complex index of refraction for the ice-air-water mixture - !.. of the particle: - m_core = get_m_mix_nested (m_air, m_i, m_w, volair, volice, & - volwater, mixingrule, host, matrix, inclusion, & - hostmatrix, hostinclusion, error) - if (error .ne. 0) then - C_back = 0.0d0 - return - endif - - !..Rayleigh-backscattering coefficient of melting particle: - C_back = (ABS((m_core**2-1.0d0)/(m_core**2+2.0d0)))**2 & - * PI5 * D_large**6 / lamda4 - - else - C_back = 0.0d0 - endif - - end subroutine rayleigh_soak_wetgraupel -!+---+-----------------------------------------------------------------+ - - complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, & - volice, volwater, mixingrule, host, matrix, & - inclusion, hostmatrix, hostinclusion, cumulerror) - - IMPLICIT NONE - - REAL(kind=selected_real_kind(12)), INTENT(in):: volice, volair, volwater - COMPLEX*16, INTENT(in):: m_a, m_i, m_w - CHARACTER(len=*), INTENT(in):: mixingrule, host, matrix, & - inclusion, hostmatrix, hostinclusion - INTEGER, INTENT(out):: cumulerror - - REAL(kind=selected_real_kind(12)):: vol1, vol2 - COMPLEX*16:: mtmp - INTEGER:: error - - !..Folded: ( (m1 + m2) + m3), where m1,m2,m3 could each be - !.. air, ice, or water - - cumulerror = 0 - get_m_mix_nested = CMPLX(1.0d0,0.0d0) - - if (host .eq. 'air') then - - if (matrix .eq. 'air') then - write(mp_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - !bloss CALL wrf_debug(150, mp_debug) - cumulerror = cumulerror + 1 - else - vol1 = volice / MAX(volice+volwater,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, 0.0d0, vol1, vol2, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'air') then - get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & - volair, (1.0d0-volair), 0.0d0, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'icewater') then - get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & - volair, (1.0d0-volair), 0.0d0, mixingrule, & - 'ice', hostinclusion, error) - cumulerror = cumulerror + error - else - write(mp_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', & - hostmatrix - !bloss CALL wrf_debug(150, mp_debug) - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'ice') then - - if (matrix .eq. 'ice') then - write(mp_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - !bloss CALL wrf_debug(150, mp_debug) - cumulerror = cumulerror + 1 - else - vol1 = volair / MAX(volair+volwater,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, vol1, 0.0d0, vol2, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'ice') then - get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & - (1.0d0-volice), volice, 0.0d0, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'airwater') then - get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & - (1.0d0-volice), volice, 0.0d0, mixingrule, & - 'air', hostinclusion, error) - cumulerror = cumulerror + error - else - write(mp_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', & - hostmatrix - !bloss CALL wrf_debug(150, mp_debug) - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'water') then - - if (matrix .eq. 'water') then - write(mp_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix - !bloss CALL wrf_debug(150, mp_debug) - cumulerror = cumulerror + 1 - else - vol1 = volair / MAX(volice+volair,1d-10) - vol2 = 1.0d0 - vol1 - mtmp = get_m_mix (m_a, m_i, m_w, vol1, vol2, 0.0d0, & - mixingrule, matrix, inclusion, error) - cumulerror = cumulerror + error - - if (hostmatrix .eq. 'water') then - get_m_mix_nested = get_m_mix (2.0d0*m_a, mtmp, m_w, & - 0.0d0, (1.0d0-volwater), volwater, mixingrule, & - hostmatrix, hostinclusion, error) - cumulerror = cumulerror + error - elseif (hostmatrix .eq. 'airice') then - get_m_mix_nested = get_m_mix (2.0d0*m_a, mtmp, m_w, & - 0.0d0, (1.0d0-volwater), volwater, mixingrule, & - 'ice', hostinclusion, error) - cumulerror = cumulerror + error - else - write(mp_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', & - hostmatrix - !bloss CALL wrf_debug(150, mp_debug) - cumulerror = cumulerror + 1 - endif - endif - - elseif (host .eq. 'none') then - - get_m_mix_nested = get_m_mix (m_a, m_i, m_w, & - volair, volice, volwater, mixingrule, & - matrix, inclusion, error) - cumulerror = cumulerror + error - - else - write(mp_debug,*) 'GET_M_MIX_NESTED: unknown matrix: ', host - !bloss CALL wrf_debug(150, mp_debug) - cumulerror = cumulerror + 1 - endif - - IF (cumulerror .ne. 0) THEN - write(mp_debug,*) 'GET_M_MIX_NESTED: error encountered' - !bloss CALL wrf_debug(150, mp_debug) - get_m_mix_nested = CMPLX(1.0d0,0.0d0) - endif - - end function get_m_mix_nested - -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION get_m_mix (m_a, m_i, m_w, volair, volice, & - volwater, mixingrule, matrix, inclusion, error) - - IMPLICIT NONE - - REAL(kind=selected_real_kind(12)), INTENT(in):: volice, volair, volwater - COMPLEX*16, INTENT(in):: m_a, m_i, m_w - CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion - INTEGER, INTENT(out):: error - - error = 0 - get_m_mix = CMPLX(1.0d0,0.0d0) - - if (mixingrule .eq. 'maxwellgarnett') then - if (matrix .eq. 'ice') then - get_m_mix = m_complex_maxwellgarnett(volice, volair, volwater, & - m_i, m_a, m_w, inclusion, error) - elseif (matrix .eq. 'water') then - get_m_mix = m_complex_maxwellgarnett(volwater, volair, volice, & - m_w, m_a, m_i, inclusion, error) - elseif (matrix .eq. 'air') then - get_m_mix = m_complex_maxwellgarnett(volair, volwater, volice, & - m_a, m_w, m_i, inclusion, error) - else - write(mp_debug,*) 'GET_M_MIX: unknown matrix: ', matrix - !bloss CALL wrf_debug(150, mp_debug) - error = 1 - endif - - else - write(mp_debug,*) 'GET_M_MIX: unknown mixingrule: ', mixingrule - !bloss CALL wrf_debug(150, mp_debug) - error = 2 - endif - - if (error .ne. 0) then - write(mp_debug,*) 'GET_M_MIX: error encountered' - !bloss CALL wrf_debug(150, mp_debug) - endif - - END FUNCTION get_m_mix - -!+---+-----------------------------------------------------------------+ - - COMPLEX*16 FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, & - m1, m2, m3, inclusion, error) - - IMPLICIT NONE - - COMPLEX*16 :: m1, m2, m3 - REAL(kind=selected_real_kind(12)) :: vol1, vol2, vol3 - CHARACTER(len=*) :: inclusion - - COMPLEX*16 :: beta2, beta3, m1t, m2t, m3t - INTEGER, INTENT(out) :: error - - error = 0 - - if (DABS(vol1+vol2+vol3-1.0d0) .gt. 1d-6) then - write(mp_debug,*) 'M_COMPLEX_MAXWELLGARNETT: sum of the ', & - 'partial volume fractions is not 1...ERROR' - !bloss CALL wrf_debug(150, mp_debug) - m_complex_maxwellgarnett=CMPLX(-999.99d0,-999.99d0) - error = 1 - return - endif - - m1t = m1**2 - m2t = m2**2 - m3t = m3**2 - - if (inclusion .eq. 'spherical') then - beta2 = 3.0d0*m1t/(m2t+2.0d0*m1t) - beta3 = 3.0d0*m1t/(m3t+2.0d0*m1t) - elseif (inclusion .eq. 'spheroidal') then - beta2 = 2.0d0*m1t/(m2t-m1t) * (m2t/(m2t-m1t)*LOG(m2t/m1t)-1.0d0) - beta3 = 2.0d0*m1t/(m3t-m1t) * (m3t/(m3t-m1t)*LOG(m3t/m1t)-1.0d0) - else - write(mp_debug,*) 'M_COMPLEX_MAXWELLGARNETT: ', & - 'unknown inclusion: ', inclusion - !bloss CALL wrf_debug(150, mp_debug) - m_complex_maxwellgarnett=CMPLX(-999.99d0,-999.99d0, kind=kind(0.d0)) - error = 1 - return - endif - - m_complex_maxwellgarnett = & - SQRT(((1.0d0-vol2-vol3)*m1t + vol2*beta2*m2t + vol3*beta3*m3t) / & - (1.0d0-vol2-vol3+vol2*beta2+vol3*beta3)) - - END FUNCTION m_complex_maxwellgarnett - -!+---+-----------------------------------------------------------------+ -!..Compute radar reflectivity assuming 10 cm wavelength radar and using -!.. Rayleigh approximation. Only complication is melted snow/graupel -!.. which we treat as water-coated ice spheres and use Uli Blahak's -!.. library of routines. The meltwater fraction is simply the amount -!.. of frozen species remaining from what initially existed at the -!.. melting level interface. -!+---+-----------------------------------------------------------------+ - subroutine calc_refl10cm (qv1d, qr1d, qs1d, qg1d, t1d, p1d, dBZ, & - kts, kte, ii, jj, nr1d, ns1d, ng1d) - - IMPLICIT NONE - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii, jj - REAL, DIMENSION(kts:kte), INTENT(IN):: & - qv1d, qr1d, qs1d, qg1d, t1d, p1d, nr1d, ns1d, ng1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ - -!..Local variables - REAL, DIMENSION(kts:kte):: temp, pres, qv, rho - REAL, DIMENSION(kts:kte):: rr, rs, rg,rnr,rns,rng - - REAL(kind=selected_real_kind(12)), DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g,ilams,n0_s - - REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel - - REAL(kind=selected_real_kind(12)):: lamg - REAL(kind=selected_real_kind(12)):: fmelt_s, fmelt_g - - INTEGER:: i, k, k_0 - LOGICAL:: melti - LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg - -!..Single melting snow/graupel particle 70% meltwater on external sfc - REAL(kind=selected_real_kind(12)), PARAMETER:: melt_outside_s = 0.7d0 - REAL(kind=selected_real_kind(12)), PARAMETER:: melt_outside_g = 0.7d0 - - REAL(kind=selected_real_kind(12)):: cback, x, eta, f_d - -! hm added parameter - REAL R1,t_0,dumlams,dumlamr,dumlamg,dumn0s,dumn0r,dumn0g,ocms,obms,ocmg,obmg - - integer n - - R1 = 1.E-12 - t_0 = 273.15 - -!+---+ - - do k = kts, kte - dBZ(k) = -35.0 - enddo - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - if (qr1d(k) .gt. R1) then - rr(k) = qr1d(k)*rho(k) - L_qr(k) = .true. - else - rr(k) = R1 - L_qr(k) = .false. - endif - if (qs1d(k) .gt. R1) then - rs(k) = qs1d(k)*rho(k) - L_qs(k) = .true. - else - rs(k) = R1 - L_qs(k) = .false. - endif - if (qg1d(k) .gt. R1) then - rg(k) = qg1d(k)*rho(k) - L_qg(k) = .true. - else - rg(k) = R1 - L_qg(k) = .false. - endif - -! hm add number concentration - if (nr1d(k) .gt. R1) then - rnr(k) = nr1d(k)*rho(k) - else - rnr(k) = R1 - endif - if (ns1d(k) .gt. R1) then - rns(k) = ns1d(k)*rho(k) - else - rns(k) = R1 - endif - if (ng1d(k) .gt. R1) then - rng(k) = ng1d(k)*rho(k) - else - rng(k) = R1 - endif - - enddo - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope, and useful moments for snow. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - -! compute moments for snow - -! calculate slope and intercept parameter - - dumLAMS = (CONS1*rns(K)/rs(K))**(1./DS) - dumN0S = rns(K)*dumLAMS/rho(k) - -! CHECK FOR SLOPE to make sure min/max bounds are not exceeded - -! ADJUST VARS - - IF (dumLAMS.LT.LAMMINS) THEN - dumLAMS = LAMMINS - dumN0S = dumLAMS**4*rs(K)/CONS1 - ELSE IF (dumLAMS.GT.LAMMAXS) THEN - dumLAMS = LAMMAXS - dumN0S = dumLAMS**4*rs(k)/CONS1 - end if - - ilams(k)=1./dumlams - n0_s(k)=dumn0s - - enddo - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept, slope values for graupel. -!+---+-----------------------------------------------------------------+ - - do k = kte, kts, -1 - - -! calculate slope and intercept parameter - - dumLAMg = (CONS2*rng(K)/rg(K))**(1./Dg) - dumN0g = rng(K)*dumLAMg/rho(k) - -! CHECK FOR SLOPE to make sure min/max bounds are not exceeded - -! ADJUST VARS - - IF (dumLAMg.LT.LAMMINg) THEN - dumLAMg = LAMMINg - dumN0g = dumLAMg**4*rg(K)/CONS2 - ELSE IF (dumLAMg.GT.LAMMAXg) THEN - dumLAMg = LAMMAXg - dumN0g = dumLAMg**4*rg(k)/CONS2 - end if - - ilamg(k)=1./dumlamg - n0_g(k)=dumn0g - - enddo - -!+---+-----------------------------------------------------------------+ -!..Calculate y-intercept & slope values for rain. -!+---+-----------------------------------------------------------------+ - - do k = kte, kts, -1 - -! calculate slope and intercept parameter - - dumLAMr = (PI*RHOW*rnr(K)/rr(K))**(1./3.) - dumN0r = rnr(K)*dumLAMr/rho(k) - -! CHECK FOR SLOPE to make sure min/max bounds are not exceeded - -! ADJUST VARS - - IF (dumLAMr.LT.LAMMINr) THEN - dumLAMr = LAMMINr - dumN0r = dumLAMr**4*rr(K)/(PI*RHOW) - ELSE IF (dumLAMr.GT.LAMMAXr) THEN - dumLAMr = LAMMAXr - dumN0r = dumLAMr**4*rr(k)/(PI*RHOW) - end if - - ilamr(k)=1./dumlamr - n0_r(k)=dumn0r - - enddo - - melti = .false. - k_0 = kts - do k = kte-1, kts, -1 - if ( (temp(k).gt. T_0) .and. (rr(k).gt. 0.001e-3) & - .and. ((rs(k+1)+rg(k+1)).gt. 0.01e-3) ) then - k_0 = MAX(k+1, k_0) - melti=.true. - goto 195 - endif - enddo - 195 continue - -!+---+-----------------------------------------------------------------+ -!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) -!.. and non-water-coated snow and graupel when below freezing are -!.. simple. Integrations of m(D)*m(D)*N(D)*dD. -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - ze_rain(k) = 1.e-22 - ze_snow(k) = 1.e-22 - ze_graupel(k) = 1.e-22 - if (L_qr(k)) ze_rain(k) = N0_r(k)*720.*ilamr(k)**7 - - if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (pi*rhosn/6./900.)*(pi*rhosn/6./900.) & - * N0_s(k)*720.*ilams(k)**7 - if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (pi*rhog/6./900.)* (pi*rhog/6./900.) & - * N0_g(k)*720.*ilamg(k)**7 - enddo - -!+---+-----------------------------------------------------------------+ -!..Special case of melting ice (snow/graupel) particles. Assume the -!.. ice is surrounded by the liquid water. Fraction of meltwater is -!.. extremely simple based on amount found above the melting level. -!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting -!.. routines). -!+---+-----------------------------------------------------------------+ - - if (melti .and. k_0.ge.2) then - do k = k_0-1, 1, -1 - -!..Reflectivity contributed by melting snow - fmelt_s = DMIN1(1.0d0-rs(k)/rs(k_0), 1.0d0) - if (fmelt_s.gt.0.01d0 .and. fmelt_s.lt.0.99d0 .and. & - rs(k).gt.R1) then - eta = 0.d0 - obms = 1./ds - ocms = (1./(pi*rhosn/6.))**obms - do n = 1, nbs - x = pi*rhosn/6. * Dds(n)**3 - call rayleigh_soak_wetgraupel (x, DBLE(ocms), DBLE(obms), & - fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_s, matrixstring_s, & - inclusionstring_s, hoststring_s, & - hostmatrixstring_s, hostinclusionstring_s) - f_d = N0_s(k)* DEXP(-Dds(n)/ilams(k)) - eta = eta + f_d * CBACK * simpson(n) * dts(n) - - enddo - ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - -!..Reflectivity contributed by melting graupel - - fmelt_g = DMIN1(1.0d0-rg(k)/rg(k_0), 1.0d0) - if (fmelt_g.gt.0.01d0 .and. fmelt_g.lt.0.99d0 .and. & - rg(k).gt.R1) then - eta = 0.d0 - lamg = 1./ilamg(k) - obmg = 1./dg - ocmg = (1./(pi*rhog/6.))**obmg - do n = 1, nbg - x = pi*rhog/6. * Ddg(n)**3 - call rayleigh_soak_wetgraupel (x, DBLE(ocmg), DBLE(obmg), & - fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_g, matrixstring_g, & - inclusionstring_g, hoststring_g, & - hostmatrixstring_g, hostinclusionstring_g) - f_d = N0_g(k)* DEXP(-lamg*Ddg(n)) - eta = eta + f_d * CBACK * simpson(n) * dtg(n) - enddo - ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - enddo - endif - - do k = kte, kts, -1 - dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) - enddo - - - end subroutine calc_refl10cm -#ifdef CLUBB_CRM -!------------------------------------------------------------------------------- - SUBROUTINE POSITIVE_QV_ADJ( QV, QC, QR, QI, & - QS, QG, T_IN_K ) -! Description: -! The following was produced by UW-Milwaukee to prevent vapor water mixing -! ratio from becoming negative. This is necessary in the event that a -! process, e.g. depositional growth of ice, causes negative vapor. This -! appears to happen in some circumstances due to the code that will set -! vapor to saturation w.r.t to liquid when we have subgrid scale cloud -! fraction greater than our 1% threshold. - -! References: -! None -!------------------------------------------------------------------------------- - use crmx_constants_clubb, only: Lv, Ls, Cp ! Constant(s) - - IMPLICIT NONE - - ! Constant Parameters - ! The value of epsilon was picked based on how small a 4 bytes float we can - ! add to vapor without it being lost to catastophic round-off. For an 8 - ! byte float a smaller value might be used -dschanen 5 Oct 2009. - REAL, PARAMETER :: & - EPS = 1.E-12 ! Small value of vapor [kg/kg] - - ! Input/Output Variables - REAL, INTENT(INOUT) :: & - QV, & ! Vapor water mixing ratio [kg/kg] - QC, & ! Cloud water mixing ratio [kg/kg] - QR, & ! Rain water mixing ratio [kg/kg] - QI, & ! Ice water mixing ratio [kg/kg] - QS, & ! Snow water mixing ratio [kg/kg] - QG ! Graupel water mixing ratio [kg/kg] - - REAL, INTENT(INOUT) :: & - T_IN_K ! Absolute Temperature [K] - - ! Local Variables - REAL :: & - QT_COND_LIQ, & ! Total water in liquid phase [kg/kg] - QT_COND_ICE, & ! Total water in ice phase [kg/kg] - QT_TOTAL ! Total water ice + liquid [kg/kg] - - REAL :: & - DELTA_QV, DELTA_QT_COND_LIQ, DELTA_QT_COND_ICE, REDUCE_COEF - - ! ---- Begin Code ---- - - ! If vapor is greater than or equal to epsilon, then exit. - IF ( QV >= EPS ) RETURN - -! PRINT *, "BEFORE", QV, QC, QR, QI, QS, QG, T_IN_K - - ! Determine total water - QT_COND_LIQ = QC + QR - - QT_COND_ICE = 0.0 - ! Add ice if it is enabled - IF ( ILIQ == 0 ) THEN - QT_COND_ICE = QT_COND_ICE + QS + QI - END IF - - ! Add graupel if it is enabled - IF ( IGRAUP == 0 ) THEN - QT_COND_ICE = QT_COND_ICE + QG - END IF - - ! Total water mixing ratio = vapor + liquid + ice - QT_TOTAL = QV + QT_COND_LIQ + QT_COND_ICE - - ! If the total water available at this altitude is too small, - ! then we need to apply hole-filling globally instead. - IF ( QT_TOTAL < 2 * EPS ) RETURN - - ! Determine delta qv, the amount to change vapor water mixing ratio by. - DELTA_QV = EPS - QV - - ! Set QV to the minimum value - QV = EPS - - ! Reduce other variables according to the amount we've increased vapor by, - ! in order to conserve total water. - REDUCE_COEF = 1. - ( DELTA_QV / (QT_COND_LIQ + QT_COND_ICE) ) - - ! Compute total change in warm-phase variables - QC = QC * REDUCE_COEF - QR = QR * REDUCE_COEF - - DELTA_QT_COND_LIQ = QT_COND_LIQ - ( QC + QR ) - - ! Compute total change in ice-phase variables - - DELTA_QT_COND_ICE = 0.0 - IF ( ILIQ == 0 ) THEN - QI = QI * REDUCE_COEF - QS = QS * REDUCE_COEF - - IF ( IGRAUP /= 0 ) THEN - DELTA_QT_COND_ICE = QT_COND_ICE - ( QI + QS ) - END IF - END IF - - IF ( IGRAUP == 0 ) THEN - QG = QG * REDUCE_COEF - - DELTA_QT_COND_ICE = QT_COND_ICE - ( QI + QS + QG ) - END IF - - ! Adjust absolute temperature - T_IN_K = T_IN_K - ( Lv / Cp * ( DELTA_QT_COND_LIQ ) ) & - - ( Ls / Cp * ( DELTA_QT_COND_ICE ) ) - -! PRINT *, "AFTER", QV, QC, QR, QI, QS, QG, T_IN_K - RETURN - END SUBROUTINE POSITIVE_QV_ADJ -#endif /*CLUBB_CRM*/ - -END MODULE crmx_module_mp_GRAUPEL diff --git a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_cloud.F90 b/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_cloud.F90 deleted file mode 100644 index 749678c89c..0000000000 --- a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_cloud.F90 +++ /dev/null @@ -1,133 +0,0 @@ - -subroutine cloud - -! Condensation of cloud water/cloud ice. - -use crmx_vars -use crmx_microphysics -use crmx_micro_params -use crmx_params - -implicit none - -integer i,j,k, kb, kc -real dtabs, tabs1, an, bn, ap, bp, om, ag, omp -real fac1,fac2 -real fff,dfff,qsatt,dqsat -real lstarn,dlstarn,lstarp,dlstarp -integer niter - -an = 1./(tbgmax-tbgmin) -bn = tbgmin * an -ap = 1./(tprmax-tprmin) -bp = tprmin * ap -fac1 = fac_cond+(1+bp)*fac_fus -fac2 = fac_fus*ap -ag = 1./(tgrmax-tgrmin) - -!call t_startf ('cloud') - -do k = 1, nzm - do j = 1, ny - do i = 1, nx - - q(i,j,k)=max(0.,q(i,j,k)) - - -! Initail guess for temperature assuming no cloud water/ice: - - - tabs(i,j,k) = t(i,j,k)-gamaz(k) - tabs1=(tabs(i,j,k)+fac1*qp(i,j,k))/(1.+fac2*qp(i,j,k)) - -! Warm cloud: - - if(tabs1.ge.tbgmax) then - - tabs1=tabs(i,j,k)+fac_cond*qp(i,j,k) - qsatt = qsatw_crm(tabs1,pres(k)) - -! Ice cloud: - - elseif(tabs1.le.tbgmin) then - - tabs1=tabs(i,j,k)+fac_sub*qp(i,j,k) - qsatt = qsati_crm(tabs1,pres(k)) - -! Mixed-phase cloud: - - else - - om = an*tabs1-bn - qsatt = om*qsatw_crm(tabs1,pres(k))+(1.-om)*qsati_crm(tabs1,pres(k)) - - endif - - -! Test if condensation is possible: - - - if(q(i,j,k).gt.qsatt) then - - niter=0 - dtabs = 100. - do while(abs(dtabs).gt.0.01.and.niter.lt.10) - if(tabs1.ge.tbgmax) then - om=1. - lstarn=fac_cond - dlstarn=0. - qsatt=qsatw_crm(tabs1,pres(k)) - dqsat=dtqsatw_crm(tabs1,pres(k)) - else if(tabs1.le.tbgmin) then - om=0. - lstarn=fac_sub - dlstarn=0. - qsatt=qsati_crm(tabs1,pres(k)) - dqsat=dtqsati_crm(tabs1,pres(k)) - else - om=an*tabs1-bn - lstarn=fac_cond+(1.-om)*fac_fus - dlstarn=an*fac_fus - qsatt=om*qsatw_crm(tabs1,pres(k))+(1.-om)*qsati_crm(tabs1,pres(k)) - dqsat=om*dtqsatw_crm(tabs1,pres(k))+(1.-om)*dtqsati_crm(tabs1,pres(k)) - endif - if(tabs1.ge.tprmax) then - omp=1. - lstarp=fac_cond - dlstarp=0. - else if(tabs1.le.tprmin) then - omp=0. - lstarp=fac_sub - dlstarp=0. - else - omp=ap*tabs1-bp - lstarp=fac_cond+(1.-omp)*fac_fus - dlstarp=ap*fac_fus - endif - fff = tabs(i,j,k)-tabs1+lstarn*(q(i,j,k)-qsatt)+lstarp*qp(i,j,k) - dfff=dlstarn*(q(i,j,k)-qsatt)+dlstarp*qp(i,j,k)-lstarn*dqsat-1. - dtabs=-fff/dfff - niter=niter+1 - tabs1=tabs1+dtabs - end do - - qsatt = qsatt + dqsat * dtabs - qn(i,j,k) = max(0.,q(i,j,k)-qsatt) - - else - - qn(i,j,k) = 0. - - endif - - tabs(i,j,k) = tabs1 - qp(i,j,k) = max(0.,qp(i,j,k)) ! just in case - - end do - end do -end do - -!call t_stopf ('cloud') - -end subroutine cloud - diff --git a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_micro_params.F90 b/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_micro_params.F90 deleted file mode 100644 index 9e8a22c8db..0000000000 --- a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_micro_params.F90 +++ /dev/null @@ -1,88 +0,0 @@ -module crmx_micro_params - -use crmx_grid, only: nzm - -implicit none - -! Microphysics stuff: - -! Densities of hydrometeors - -real, parameter :: rhor = 1000. ! Density of water, kg/m3 -real, parameter :: rhos = 100. ! Density of snow, kg/m3 -real, parameter :: rhog = 400. ! Density of graupel, kg/m3 -!real, parameter :: rhog = 917. ! hail - Lin 1983 - -! Temperatures limits for various hydrometeors - -real, parameter :: tbgmin = 253.16 ! Minimum temperature for cloud water., K -real, parameter :: tbgmax = 273.16 ! Maximum temperature for cloud ice, K -real, parameter :: tprmin = 268.16 ! Minimum temperature for rain, K -real, parameter :: tprmax = 283.16 ! Maximum temperature for snow+graupel, K -real, parameter :: tgrmin = 223.16 ! Minimum temperature for snow, K -real, parameter :: tgrmax = 283.16 ! Maximum temperature for graupel, K - -! Terminal velocity coefficients - -real, parameter :: a_rain = 842. ! Coeff.for rain term vel -real, parameter :: b_rain = 0.8 ! Fall speed exponent for rain -real, parameter :: a_snow = 4.84 ! Coeff.for snow term vel -real, parameter :: b_snow = 0.25 ! Fall speed exponent for snow -!real, parameter :: a_grau = 40.7! Krueger (1994) ! Coef. for graupel term vel -real, parameter :: a_grau = 94.5 ! Lin (1983) (rhog=400) -!real, parameter :: a_grau = 127.94! Lin (1983) (rhog=917) -real, parameter :: b_grau = 0.5 ! Fall speed exponent for graupel - -! Autoconversion -#ifdef CLUBB_CRM /*microphysical tuning for CLUBB*/ -real, parameter :: qcw0 = 0.6e-3 ! Threshold for water autoconversion, g/g -real, parameter :: qci0 = 1.e-4 ! Threshold for ice autoconversion, g/g -real, parameter :: alphaelq = 10.e-3 ! autoconversion of cloud water rate coef -real, parameter :: betaelq = 6.0e-3 ! autoconversion of cloud ice rate coef -#else -real, parameter :: qcw0 = 1.e-3 ! Threshold for water autoconversion, g/g -real, parameter :: qci0 = 1.e-4 ! Threshold for ice autoconversion, g/g -real, parameter :: alphaelq = 1.e-3 ! autoconversion of cloud water rate coef -real, parameter :: betaelq = 1.e-3 ! autoconversion of cloud ice rate coef -#endif /*CLUBB_CRM*/ - -! Accretion - -real, parameter :: erccoef = 1.0 ! Rain/Cloud water collection efficiency -real, parameter :: esccoef = 1.0 ! Snow/Cloud water collection efficiency -real, parameter :: esicoef = 0.1 ! Snow/cloud ice collection efficiency -real, parameter :: egccoef = 1.0 ! Graupel/Cloud water collection efficiency -real, parameter :: egicoef = 0.1 ! Graupel/Cloud ice collection efficiency - -! Interseption parameters for exponential size spectra - -real, parameter :: nzeror = 8.e6 ! Intercept coeff. for rain -real, parameter :: nzeros = 3.e6 ! Intersept coeff. for snow -real, parameter :: nzerog = 4.e6 ! Intersept coeff. for graupel -!real, parameter :: nzerog = 4.e4 ! hail - Lin 1993 - -real, parameter :: qp_threshold = 1.e-8 ! minimal rain/snow water content - - -! Misc. microphysics variables - -real*4 gam3 ! Gamma function of 3 -real*4 gams1 ! Gamma function of (3 + b_snow) -real*4 gams2 ! Gamma function of (5 + b_snow)/2 -real*4 gams3 ! Gamma function of (4 + b_snow) -real*4 gamg1 ! Gamma function of (3 + b_grau) -real*4 gamg2 ! Gamma function of (5 + b_grau)/2 -real*4 gamg3 ! Gamma function of (4 + b_grau) -real*4 gamr1 ! Gamma function of (3 + b_rain) -real*4 gamr2 ! Gamma function of (5 + b_rain)/2 -real*4 gamr3 ! Gamma function of (4 + b_rain) - -real accrsc(nzm),accrsi(nzm),accrrc(nzm),coefice(nzm) -real accrgc(nzm),accrgi(nzm) -real evaps1(nzm),evaps2(nzm),evapr1(nzm),evapr2(nzm) -real evapg1(nzm),evapg2(nzm) - -real a_bg, a_pr, a_gr - - -end module crmx_micro_params diff --git a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_microphysics.F90 b/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_microphysics.F90 deleted file mode 100644 index 779712df70..0000000000 --- a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_microphysics.F90 +++ /dev/null @@ -1,463 +0,0 @@ -module crmx_microphysics - -! module for original SAM bulk microphysics -! Marat Khairoutdinov, 2006 - -use crmx_grid, only: nx,ny,nzm,nz, dimx1_s,dimx2_s,dimy1_s,dimy2_s ! subdomain grid information -use crmx_params, only: doprecip, docloud, doclubb -use crmx_micro_params -implicit none - -!---------------------------------------------------------------------- -!!! required definitions: - -integer, parameter :: nmicro_fields = 2 ! total number of prognostic water vars - -!!! microphysics prognostic variables are storred in this array: - -real micro_field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm, nmicro_fields) - -integer, parameter :: flag_wmass(nmicro_fields) = (/1,1/) -integer, parameter :: index_water_vapor = 1 ! index for variable that has water vapor -integer, parameter :: index_cloud_ice = 1 ! index for cloud ice (sedimentation) -integer, parameter :: flag_precip(nmicro_fields) = (/0,1/) - -! both variables correspond to mass, not number -integer, parameter :: flag_number(nmicro_fields) = (/0,0/) - -! SAM1MOM 3D microphysical fields are output by default. -integer, parameter :: flag_micro3Dout(nmicro_fields) = (/0,0/) - -real fluxbmk (nx, ny, 1:nmicro_fields) ! surface flux of tracers -real fluxtmk (nx, ny, 1:nmicro_fields) ! top boundary flux of tracers - -!!! these arrays are needed for output statistics: - -real mkwle(nz,1:nmicro_fields) ! resolved vertical flux -real mkwsb(nz,1:nmicro_fields) ! SGS vertical flux -real mkadv(nz,1:nmicro_fields) ! tendency due to vertical advection -real mklsadv(nz,1:nmicro_fields) ! tendency due to large-scale vertical advection -real mkdiff(nz,1:nmicro_fields) ! tendency due to vertical diffusion -real mstor(nz,1:nmicro_fields) ! storage terms of microphysical variables - -!====================================================================== -! UW ADDITIONS - -!bloss: arrays with names/units for microphysical outputs in statistics. -character*3, dimension(nmicro_fields) :: mkname -character*80, dimension(nmicro_fields) :: mklongname -character*10, dimension(nmicro_fields) :: mkunits -real, dimension(nmicro_fields) :: mkoutputscale - -! END UW ADDITIONS -!====================================================================== - -!------------------------------------------------------------------ -! Optional (internal) definitions) - -! make aliases for prognostic variables: -! note that the aliases should be local to microphysics - -real q(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! total nonprecipitating water -real qp(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! total precipitating water -equivalence (q(dimx1_s,dimy1_s,1),micro_field(dimx1_s,dimy1_s,1,1)) -equivalence (qp(dimx1_s,dimy1_s,1),micro_field(dimx1_s,dimy1_s,1,2)) - -real qn(nx,ny,nzm) ! cloud condensate (liquid + ice) - -real qpsrc(nz) ! source of precipitation microphysical processes -real qpevp(nz) ! sink of precipitating water due to evaporation - -real vrain, vsnow, vgrau, crain, csnow, cgrau ! precomputed coefs for precip terminal velocity - -CONTAINS - -! required microphysics subroutines and function: -!---------------------------------------------------------------------- -!!! Read microphysics options from prm file - -subroutine micro_setparm() - ! no user-definable options in SAM1MOM microphysics. -end subroutine micro_setparm - -!---------------------------------------------------------------------- -!!! Initialize microphysics: - - -subroutine micro_init() - -#ifdef CLUBB_CRM - use crmx_params, only: doclubb, doclubbnoninter ! dschanen UWM 21 May 2008 - use crmx_params, only: nclubb -#endif - use crmx_grid, only: nrestart - use crmx_vars, only: q0 - use crmx_params, only: dosmoke - integer k, n -#ifdef CLUBB_CRM -! if ( nclubb /= 1 ) then -! write(0,*) "The namelist parameter nclubb is not equal to 1,", & -! " but SAM single moment microphysics is enabled." -! write(0,*) "This will create unrealistic results in subsaturated grid boxes. ", & -! "Exiting..." -! call task_abort() -! end if -#endif - - a_bg = 1./(tbgmax-tbgmin) - a_pr = 1./(tprmax-tprmin) - a_gr = 1./(tgrmax-tgrmin) - -! if(doprecip) call precip_init() - - if(nrestart.eq.0) then - -#ifndef CRM - micro_field = 0. - do k=1,nzm - q(:,:,k) = q0(k) - end do - qn = 0. -#endif - - fluxbmk = 0. - fluxtmk = 0. - -#ifdef CLUBB_CRM - if ( docloud .or. doclubb ) then -#else - if(docloud) then -#endif -#ifndef CRM - call cloud() -#endif - call micro_diagnose() - end if - if(dosmoke) then - call micro_diagnose() - end if - - end if - - mkwle = 0. - mkwsb = 0. - mkadv = 0. - mkdiff = 0. - mklsadv = 0. - mstor = 0. - - qpsrc = 0. - qpevp = 0. - - mkname(1) = 'QT' - mklongname(1) = 'TOTAL WATER (VAPOR + CONDENSATE)' - mkunits(1) = 'g/kg' - mkoutputscale(1) = 1.e3 - - mkname(2) = 'QP' - mklongname(2) = 'PRECIPITATING WATER' - mkunits(2) = 'g/kg' - mkoutputscale(2) = 1.e3 - -! set mstor to be the inital microphysical mixing ratios - do n=1, nmicro_fields - do k=1, nzm - mstor(k, n) = SUM(micro_field(1:nx,1:ny,k,n)) - end do - end do - -end subroutine micro_init - -!---------------------------------------------------------------------- -!!! fill-in surface and top boundary fluxes: -! -subroutine micro_flux() - - use crmx_vars, only: fluxbq, fluxtq - -#ifdef CLUBB_CRM - ! Added by dschanen UWM - use crmx_params, only: doclubb, doclubb_sfc_fluxes, docam_sfc_fluxes - if ( doclubb .and. (doclubb_sfc_fluxes .or. docam_sfc_fluxes) ) then - ! Add this in later - fluxbmk(:,:,index_water_vapor) = 0.0 - else - fluxbmk(:,:,index_water_vapor) = fluxbq(:,:) - end if -#else - fluxbmk(:,:,index_water_vapor) = fluxbq(:,:) -#endif /*CLUBB_CRM*/ - fluxtmk(:,:,index_water_vapor) = fluxtq(:,:) - -end subroutine micro_flux - -!---------------------------------------------------------------------- -!!! compute local microphysics processes (bayond advection and SGS diffusion): -! -subroutine micro_proc() - - use crmx_grid, only: nstep,dt,icycle - use crmx_params, only: dosmoke -#ifdef CLUBB_CRM - use crmx_params, only: doclubb, doclubbnoninter ! dschanen UWM 21 May 2008 - use crmx_clubbvars, only: cloud_frac - use crmx_vars, only: CF3D - use crmx_grid, only: nzm -#endif - - ! Update bulk coefficient - if(doprecip.and.icycle.eq.1) call precip_init() - - if(docloud) then - call cloud() - if(doprecip) call precip_proc() - call micro_diagnose() - end if - if(dosmoke) then - call micro_diagnose() - end if -#ifdef CLUBB_CRM - if ( doclubb ) then ! -dschanen UWM 21 May 2008 - CF3D(:,:, 1:nzm) = cloud_frac(:,:,2:nzm+1) ! CF3D is used in precip_proc_clubb, - ! so it is set here first +++mhwang -! if(doprecip) call precip_proc() - if(doprecip) call precip_proc_clubb() - call micro_diagnose() - end if -#endif /*CLUBB_CRM*/ - -end subroutine micro_proc - -!---------------------------------------------------------------------- -!!! Diagnose arrays nessesary for dynamical core and statistics: -! -subroutine micro_diagnose() - - use crmx_vars - - real omn, omp - integer i,j,k - - do k=1,nzm - do j=1,ny - do i=1,nx - qv(i,j,k) = q(i,j,k) - qn(i,j,k) - omn = max(0.,min(1.,(tabs(i,j,k)-tbgmin)*a_bg)) - qcl(i,j,k) = qn(i,j,k)*omn - qci(i,j,k) = qn(i,j,k)*(1.-omn) - omp = max(0.,min(1.,(tabs(i,j,k)-tprmin)*a_pr)) - qpl(i,j,k) = qp(i,j,k)*omp - qpi(i,j,k) = qp(i,j,k)*(1.-omp) - end do - end do - end do - - - -end subroutine micro_diagnose - -#ifdef CLUBB_CRM -!--------------------------------------------------------------------- -subroutine micro_update() - -! Description: -! This subroutine essentially does what micro_proc does but does not -! call any microphysics subroutines. We need this so that CLUBB gets a -! properly updated value of ice fed in. -! -! dschanen UWM 7 Jul 2008 -!--------------------------------------------------------------------- - -! call cloud() -! call micro_diagnose() - - call micro_diagnose_clubb() - -end subroutine micro_update - -!--------------------------------------------------------------------- -subroutine micro_adjust( new_qv, new_qc ) -! Description: -! Adjust vapor and liquid water. -! Microphysical variables are stored separately in -! SAM's dynamics + CLUBB ( e.g. qv, qcl, qci) and -! SAM's microphysics. (e.g. q and qn). -! This subroutine stores values of qv, qcl updated by CLUBB -! in the single-moment microphysical variables q and qn. -! -! dschanen UWM 20 May 2008 -!--------------------------------------------------------------------- - - use crmx_vars, only: qci - - implicit none - - real, dimension(nx,ny,nzm), intent(in) :: & - new_qv, & ! Water vapor mixing ratio that has been adjusted by CLUBB [kg/kg] - new_qc ! Cloud water mixing ratio that has been adjusted by CLUBB [kg/kg]. - ! For the single moment microphysics, it is liquid + ice - - q(1:nx,1:ny,1:nzm) = new_qv + new_qc ! Vapor + Liquid + Ice - qn(1:nx,1:ny,1:nzm) = new_qc ! Liquid + Ice - - return -end subroutine micro_adjust - -subroutine micro_diagnose_clubb() - - use crmx_vars - use crmx_constants_clubb, only: fstderr, zero_threshold - use crmx_error_code, only: clubb_at_least_debug_level ! Procedur - - real omn, omp - integer i,j,k - - do k=1,nzm - do j=1,ny - do i=1,nx -! For CLUBB, water vapor and liquid water is used -! so set qcl to qn while qci to zero. This also allows us to call CLUBB -! every nclubb th time step (see sgs_proc in sgs.F90) - - qv(i,j,k) = q(i,j,k) - qn(i,j,k) - ! Apply local hole-filling to vapor by converting liquid to vapor. Moist - ! static energy should be conserved, so updating temperature is not - ! needed here. -dschanen 31 August 2011 - if ( qv(i,j,k) < zero_threshold ) then - qn(i,j,k) = qn(i,j,k) + qv(i,j,k) - qv(i,j,k) = zero_threshold - if ( qn(i,j,k) < zero_threshold ) then - if ( clubb_at_least_debug_level( 1 ) ) then - write(fstderr,*) "Total water at", "i =", i, "j =", j, "k =", k, "is negative.", & - "Applying non-conservative hard clipping." - end if - qn(i,j,k) = zero_threshold - end if ! cloud_liq < 0 - end if ! qv < 0 - - qcl(i,j,k) = qn(i,j,k) - qci(i,j,k) = 0.0 - omp = max(0.,min(1.,(tabs(i,j,k)-tprmin)*a_pr)) - qpl(i,j,k) = qp(i,j,k)*omp - qpi(i,j,k) = qp(i,j,k)*(1.-omp) - end do - end do - end do - -end subroutine micro_diagnose_clubb - -#endif /*CLUBB_CRM*/ -!---------------------------------------------------------------------- -!!! function to compute terminal velocity for precipitating variables: -! In this particular case there is only one precipitating variable. - -real function term_vel_qp(i,j,k,ind) - - use crmx_vars - integer, intent(in) :: i,j,k,ind - real wmax, omp, omg, qrr, qss, qgg - - term_vel_qp = 0. - if(qp(i,j,k).gt.qp_threshold) then - omp = max(0.,min(1.,(tabs(i,j,k)-tprmin)*a_pr)) - if(omp.eq.1.) then - term_vel_qp = vrain*(rho(k)*qp(i,j,k))**crain - elseif(omp.eq.0.) then - omg = max(0.,min(1.,(tabs(i,j,k)-tgrmin)*a_gr)) - qgg=omg*qp(i,j,k) - qss=qp(i,j,k)-qgg - term_vel_qp = (omg*vgrau*(rho(k)*qgg)**cgrau & - +(1.-omg)*vsnow*(rho(k)*qss)**csnow) - else - omg = max(0.,min(1.,(tabs(i,j,k)-tgrmin)*a_gr)) - qrr=omp*qp(i,j,k) - qss=qp(i,j,k)-qrr - qgg=omg*qss - qss=qss-qgg - term_vel_qp = (omp*vrain*(rho(k)*qrr)**crain & - +(1.-omp)*(omg*vgrau*(rho(k)*qgg)**cgrau & - +(1.-omg)*vsnow*(rho(k)*qss)**csnow)) - endif - end if -end function term_vel_qp - -!---------------------------------------------------------------------- -!!! compute sedimentation -! -subroutine micro_precip_fall() - - use crmx_vars - use crmx_params, only : pi - - real omega(nx,ny,nzm) - integer ind - integer i,j,k - - crain = b_rain / 4. - csnow = b_snow / 4. - cgrau = b_grau / 4. - vrain = a_rain * gamr3 / 6. / (pi * rhor * nzeror) ** crain - vsnow = a_snow * gams3 / 6. / (pi * rhos * nzeros) ** csnow - vgrau = a_grau * gamg3 / 6. / (pi * rhog * nzerog) ** cgrau - - do k=1,nzm - do j=1,ny - do i=1,nx - omega(i,j,k) = max(0.,min(1.,(tabs(i,j,k)-tprmin)*a_pr)) - end do - end do - end do - - call precip_fall(qp, term_vel_qp, 2, omega, ind) - - -end subroutine micro_precip_fall - -!---------------------------------------------------------------------- -! called when stepout() called - -subroutine micro_print() -end subroutine micro_print - -!----------------------------------------------------------------------- -! Supply function that computes total water in a domain: -! -real(kind=selected_real_kind(12)) function total_water() - - use crmx_vars, only : nstep,nprint,adz,dz,rho - real(kind=selected_real_kind(12)) tmp - integer i,j,k,m - - total_water = 0. - do m=1,nmicro_fields - if(flag_wmass(m).eq.1) then - do k=1,nzm - tmp = 0. - do j=1,ny - do i=1,nx - tmp = tmp + micro_field(i,j,k,m) - end do - end do - total_water = total_water + tmp*adz(k)*dz*rho(k) - end do - end if - end do - -end function total_water - -! ------------------------------------------------------------------------------- -! dummy effective radius functions: - -function Get_reffc() ! liquid water - real, pointer, dimension(:,:,:) :: Get_reffc -end function Get_reffc - -function Get_reffi() ! ice - real, pointer, dimension(:,:,:) :: Get_reffi -end function Get_reffi - - -end module crmx_microphysics - - - diff --git a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_precip_init.F90 b/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_precip_init.F90 deleted file mode 100644 index 04dd336d45..0000000000 --- a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_precip_init.F90 +++ /dev/null @@ -1,117 +0,0 @@ - -subroutine precip_init - -! Initialize precipitation related stuff - -use crmx_vars -use crmx_microphysics -use crmx_micro_params -use crmx_params - -implicit none - -real pratio, coef1, coef2,estw,esti,rrr1,rrr2 -real*4 gammafff -external gammafff -integer k - -gam3 = 3. -gamr1 = 3.+b_rain -gamr2 = (5.+b_rain)/2. -gamr3 = 4.+b_rain -gams1 = 3.+b_snow -gams2 = (5.+b_snow)/2. -gams3 = 4.+b_snow -gamg1 = 3.+b_grau -gamg2 = (5.+b_grau)/2. -gamg3 = 4.+b_grau -gam3 = gammafff(gam3) -gamr1 = gammafff(gamr1) -gamr2 = gammafff(gamr2) -gamr3 = gammafff(gamr3) -gams1 = gammafff(gams1) -gams2 = gammafff(gams2) -gams3 = gammafff(gams3) -gamg1 = gammafff(gamg1) -gamg2 = gammafff(gamg2) -gamg3 = gammafff(gamg3) -!if(masterproc) then -! print*,'gam3=',gam3 -! print*,'gamr1,gamr2,gamr3:',gamr1,gamr2,gamr3 -! print*,'gams1,gams2,gams3:',gams1,gams2,gams3 -! print*,'gamg1,gamg2,gamg3:',gamg1,gamg2,gamg3 -!endif -if(nint(gam3).ne.2) then - if(masterproc)print*,'cannot compute gamma-function in precip_init. Exiting...' - call task_abort -end if - -do k=1,nzm - -! pratio = (1000. / pres(k)) ** 0.4 - pratio = sqrt(1.29 / rho(k)) - - rrr1=393./(tabs0(k)+120.)*(tabs0(k)/273.)**1.5 - rrr2=(tabs0(k)/273.)**1.94*(1000./pres(k)) - - estw = 100.*esatw_crm(tabs0(k)) - esti = 100.*esati_crm(tabs0(k)) - -! accretion by snow: - - coef1 = 0.25 * pi * nzeros * a_snow * gams1 * pratio/ & - (pi * rhos * nzeros/rho(k) ) ** ((3+b_snow)/4.) - coef2 = exp(0.025*(tabs0(k) - 273.15)) - accrsi(k) = coef1 * coef2 * esicoef - accrsc(k) = coef1 * esccoef - coefice(k) = coef2 - -! evaporation of snow: - - coef1 =(lsub/(tabs0(k)*rv)-1.)*lsub/(therco*rrr1*tabs0(k)) - coef2 = rv*tabs0(k)/(diffelq*rrr2*esti) - evaps1(k) = 0.65*4.*nzeros/sqrt(pi*rhos*nzeros)/(coef1+coef2)/sqrt(rho(k)) - evaps2(k) = 0.49*4.*nzeros*gams2*sqrt(a_snow/(muelq*rrr1))/ & - (pi*rhos*nzeros)**((5+b_snow)/8.) / (coef1+coef2) & - * rho(k)**((1+b_snow)/8.)*sqrt(pratio) - -! accretion by graupel: - - coef1 = 0.25*pi*nzerog*a_grau*gamg1*pratio/& - (pi*rhog*nzerog/rho(k))**((3+b_grau)/4.) - coef2 = exp(0.025*(tabs0(k) - 273.15)) - accrgi(k) = coef1 * coef2 * egicoef - accrgc(k) = coef1 * egccoef - -! evaporation of graupel: - - coef1 =(lsub/(tabs0(k)*rv)-1.)*lsub/(therco*rrr1*tabs0(k)) - coef2 = rv*tabs0(k)/(diffelq*rrr2*esti) - evapg1(k) = 0.65*4.*nzerog/sqrt(pi*rhog*nzerog)/(coef1+coef2)/sqrt(rho(k)) - evapg2(k) = 0.49*4.*nzerog*gamg2*sqrt(a_grau/(muelq*rrr1))/ & - (pi * rhog * nzerog)**((5+b_grau)/8.) / (coef1+coef2) & - * rho(k)**((1+b_grau)/8.)*sqrt(pratio) - - -! accretion by rain: - - accrrc(k)= 0.25 * pi * nzeror * a_rain * gamr1 * pratio/ & - (pi * rhor * nzeror / rho(k)) ** ((3+b_rain)/4.)* erccoef - -! evaporation of rain: - - coef1 =(lcond/(tabs0(k)*rv)-1.)*lcond/(therco*rrr1*tabs0(k)) - coef2 = rv*tabs0(k)/(diffelq * rrr2 * estw) - evapr1(k) = 0.78 * 2. * pi * nzeror / & - sqrt(pi * rhor * nzeror) / (coef1+coef2) / sqrt(rho(k)) - evapr2(k) = 0.31 * 2. * pi * nzeror * gamr2 * & - 0.89 * sqrt(a_rain/(muelq*rrr1))/ & - (pi * rhor * nzeror)**((5+b_rain)/8.) / (coef1+coef2) & - * rho(k)**((1+b_rain)/8.)*sqrt(pratio) - -end do - - -end subroutine precip_init - - diff --git a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_precip_proc.F90 b/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_precip_proc.F90 deleted file mode 100644 index 78b750ca89..0000000000 --- a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_precip_proc.F90 +++ /dev/null @@ -1,136 +0,0 @@ - -subroutine precip_proc - -use crmx_vars -use crmx_microphysics -use crmx_micro_params -use crmx_params - -implicit none - -integer i,j,k -real autor, autos, accrr, accris, accrcs, accrig, accrcg -real dq, omn, omp, omg, qsatt -real pows1, pows2, powg1, powg2, powr1, powr2, tmp -real qii, qcc, qrr, qss, qgg - -powr1 = (3 + b_rain) / 4. -powr2 = (5 + b_rain) / 8. -pows1 = (3 + b_snow) / 4. -pows2 = (5 + b_snow) / 8. -powg1 = (3 + b_grau) / 4. -powg2 = (5 + b_grau) / 8. - -!call t_startf ('precip_proc') - -do k=1,nzm - qpsrc(k)=0. - qpevp(k)=0. - do j=1,ny - do i=1,nx - -!------- Autoconversion/accretion - - if(qn(i,j,k)+qp(i,j,k).gt.0.) then - - - omn = max(0.,min(1.,(tabs(i,j,k)-tbgmin)*a_bg)) - omp = max(0.,min(1.,(tabs(i,j,k)-tprmin)*a_pr)) - omg = max(0.,min(1.,(tabs(i,j,k)-tgrmin)*a_gr)) - - if(qn(i,j,k).gt.0.) then - - qcc = qn(i,j,k) * omn - qii = qn(i,j,k) * (1.-omn) - - if(qcc .gt. qcw0) then - autor = alphaelq - else - autor = 0. - endif - - if(qii .gt. qci0) then - autos = betaelq*coefice(k) - else - autos = 0. - endif - - accrr = 0. - if(omp.gt.0.001) then - qrr = qp(i,j,k) * omp - accrr = accrrc(k) * qrr ** powr1 - end if - accrcs = 0. - accris = 0. - if(omp.lt.0.999.and.omg.lt.0.999) then - qss = qp(i,j,k) * (1.-omp)*(1.-omg) - tmp = qss ** pows1 - accrcs = accrsc(k) * tmp - accris = accrsi(k) * tmp - end if - accrcg = 0. - accrig = 0. - if(omp.lt.0.999.and.omg.gt.0.001) then - qgg = qp(i,j,k) * (1.-omp)*omg - tmp = qgg ** powg1 - accrcg = accrgc(k) * tmp - accrig = accrgi(k) * tmp - endif - qcc = (qcc+dtn*autor*qcw0)/(1.+dtn*(accrr+accrcs+accrcg+autor)) - qii = (qii+dtn*autos*qci0)/(1.+dtn*(accris+accrig+autos)) - dq = dtn *(accrr*qcc + autor*(qcc-qcw0)+ & - (accris+accrig)*qii + (accrcs+accrcg)*qcc + autos*(qii-qci0)) - dq = min(dq,qn(i,j,k)) - qp(i,j,k) = qp(i,j,k) + dq - q(i,j,k) = q(i,j,k) - dq - qn(i,j,k) = qn(i,j,k) - dq - qpsrc(k) = qpsrc(k) + dq - - elseif(qp(i,j,k).gt.qp_threshold.and.qn(i,j,k).eq.0.) then - - qsatt = 0. - if(omn.gt.0.001) qsatt = qsatt + omn*qsatw_crm(tabs(i,j,k),pres(k)) - if(omn.lt.0.999) qsatt = qsatt + (1.-omn)*qsati_crm(tabs(i,j,k),pres(k)) - dq = 0. - if(omp.gt.0.001) then - qrr = qp(i,j,k) * omp - dq = dq + evapr1(k)*sqrt(qrr) + evapr2(k)*qrr**powr2 - end if - if(omp.lt.0.999.and.omg.lt.0.999) then - qss = qp(i,j,k) * (1.-omp)*(1.-omg) - dq = dq + evaps1(k)*sqrt(qss) + evaps2(k)*qss**pows2 - end if - if(omp.lt.0.999.and.omg.gt.0.001) then - qgg = qp(i,j,k) * (1.-omp)*omg - dq = dq + evapg1(k)*sqrt(qgg) + evapg2(k)*qgg**powg2 - end if - dq = dq * dtn * (q(i,j,k) /qsatt-1.) - dq = max(-0.5*qp(i,j,k),dq) - qp(i,j,k) = qp(i,j,k) + dq - q(i,j,k) = q(i,j,k) - dq - qpevp(k) = qpevp(k) + dq - - else - - q(i,j,k) = q(i,j,k) + qp(i,j,k) - qpevp(k) = qpevp(k) - qp(i,j,k) - qp(i,j,k) = 0. - - endif - - endif - - dq = qp(i,j,k) - qp(i,j,k)=max(0.,qp(i,j,k)) - q(i,j,k) = q(i,j,k) + (dq-qp(i,j,k)) - - end do - enddo -enddo - - - -!call t_stopf ('precip_proc') - -end subroutine precip_proc - diff --git a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_precip_proc_clubb.F90 b/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_precip_proc_clubb.F90 deleted file mode 100644 index 5a90a032ff..0000000000 --- a/src/physics/spcam/crm/MICRO_SAM1MOM/crmx_precip_proc_clubb.F90 +++ /dev/null @@ -1,202 +0,0 @@ -#define CLDFRAC -#ifdef CLDFRAC -subroutine precip_proc_clubb - -#ifdef CLUBB_CRM -use crmx_vars -use crmx_microphysics -use crmx_micro_params -use crmx_params -use crmx_vars, only: CF3D - -implicit none - -integer i,j,k -real autor, autos, accrr, accris, accrcs, accrig, accrcg -real dq, omn, omp, omg, qsatt -real pows1, pows2, powg1, powg2, powr1, powr2, tmp -real qii, qcc, qrr, qss, qgg - -real cld3d(nx, ny, nzm), cldmax(nx, ny, nzm) -real cld3d_temp(nx, ny, nzm) -real cloud_frac_thresh -real qclr -real dqpsrc, dqpevp - -powr1 = (3 + b_rain) / 4. -powr2 = (5 + b_rain) / 8. -pows1 = (3 + b_snow) / 4. -pows2 = (5 + b_snow) / 8. -powg1 = (3 + b_grau) / 4. -powg2 = (5 + b_grau) / 8. - -!call t_startf ('precip_proc_clubb') - -! Get cloud fraction of non-precipitating condensate -! and precipitating condensate -cloud_frac_thresh = 0.005 -do j=1, ny - do i=1, nx - do k=nzm, 1, -1 - cld3d(i, j, k) = CF3D(i,j,k) - cld3d_temp(i, j, k) = min(0.999, max(CF3D(i,j,k), cloud_frac_thresh)) - end do - cldmax(i,j,nzm)=cld3d_temp(i,j,nzm) - - do k=nzm-1, 1, -1 - ! if precipitating condensate is smaller than threshold, set cldmax - ! to cloud fraction at current level - if(qp(i, j, k+1).ge.qp_threshold) then - cldmax(i,j,k) = max(cldmax(i,j,k+1), cld3d_temp(i,j,k)) - else - cldmax(i,j,k) = cld3d_temp(i,j,k) - end if - -! if(cld3d(i,j,k).le.cloud_frac_thresh .and. qp(i,j,k).gt.qp_threshold) then -! if(cldmax(i,j,k).lt.0.1) then -! cldmax(i,j,k) = 0.50 -! end if -! end if - end do -! test: assume precipitating hydrometer fill the whole grid box -! cldmax(i,j,:) = 0.999 - - end do -end do - - -do k=1,nzm - qpsrc(k)=0. - qpevp(k)=0. - do j=1,ny - do i=1,nx - dqpsrc = 0.0 - dqpevp = 0.0 - -!------- Autoconversion/accretion - - if(qn(i,j,k)+qp(i,j,k).gt.0.) then - - - omn = max(0.,min(1.,(tabs(i,j,k)-tbgmin)*a_bg)) - omp = max(0.,min(1.,(tabs(i,j,k)-tprmin)*a_pr)) - omg = max(0.,min(1.,(tabs(i,j,k)-tgrmin)*a_gr)) - -! if(qn(i,j,k).gt.0.) then - if(cld3d(i,j,k).gt.0.) then ! the generation of precipitating condensate - - qcc = qn(i,j,k) * omn /cld3d_temp(i,j,k) - qii = qn(i,j,k) * (1.-omn)/cld3d_temp(i,j,k) - - if(qcc .gt. qcw0) then - autor = alphaelq - else - autor = 0. - endif - - if(qii .gt. qci0) then - autos = betaelq*coefice(k) - else - autos = 0. - endif - - accrr = 0. - if(omp.gt.0.001) then - qrr = qp(i,j,k) * omp / cldmax(i,j,k) - accrr = accrrc(k) * qrr ** powr1 - end if - accrcs = 0. - accris = 0. - if(omp.lt.0.999.and.omg.lt.0.999) then - qss = qp(i,j,k) * (1.-omp)*(1.-omg) / cldmax(i,j,k) - tmp = qss ** pows1 - accrcs = accrsc(k) * tmp - accris = accrsi(k) * tmp - end if - accrcg = 0. - accrig = 0. - if(omp.lt.0.999.and.omg.gt.0.001) then - qgg = qp(i,j,k) * (1.-omp)*omg / cldmax(i,j,k) - tmp = qgg ** powg1 - accrcg = accrgc(k) * tmp - accrig = accrgi(k) * tmp - endif - qcc = (qcc+dtn*autor*qcw0)/(1.+dtn*(accrr+accrcs+accrcg+autor)) - qii = (qii+dtn*autos*qci0)/(1.+dtn*(accris+accrig+autos)) - dq = dtn *(accrr*qcc + autor*(qcc-qcw0)+ & - (accris+accrig)*qii + (accrcs+accrcg)*qcc + autos*(qii-qci0)) - - dq = dq * cld3d(i,j,k) ! convert fro the in-cloud value to grid-mean value - - dq = min(dq,qn(i,j,k)) -! qp(i,j,k) = qp(i,j,k) + dq -! q(i,j,k) = q(i,j,k) - dq -! qn(i,j,k) = qn(i,j,k) - dq - dqpsrc = dq - qpsrc(k) = qpsrc(k) + dq - - end if - - !elseif(qp(i,j,k).gt.qp_threshold.and.qn(i,j,k).eq.0.) then - ! Evaporation is only allowed when cldmax exceeds cld3d_temp -! if(qp(i,j,k).gt.qp_threshold.and.cldmax(i,j,k).gt.cld3d_temp(i,j,k)) then - if(qp(i,j,k).gt.qp_threshold.and.qn(i,j,k).eq.0.) then - - qsatt = 0. - if(omn.gt.0.001) qsatt = qsatt + omn*qsatw_crm(tabs(i,j,k),pres(k)) - if(omn.lt.0.999) qsatt = qsatt + (1.-omn)*qsati_crm(tabs(i,j,k),pres(k)) - dq = 0. - if(omp.gt.0.001) then - qrr = qp(i,j,k) * omp /cldmax(i,j,k) - dq = dq + evapr1(k)*sqrt(qrr) + evapr2(k)*qrr**powr2 - end if - if(omp.lt.0.999.and.omg.lt.0.999) then - qss = qp(i,j,k) * (1.-omp)*(1.-omg) / cldmax(i,j,k) - dq = dq + evaps1(k)*sqrt(qss) + evaps2(k)*qss**pows2 - end if - if(omp.lt.0.999.and.omg.gt.0.001) then - qgg = qp(i,j,k) * (1.-omp)*omg /cldmax(i,j,k) - dq = dq + evapg1(k)*sqrt(qgg) + evapg2(k)*qgg**powg2 - end if - -! dq = dq * dtn * (q(i,j,k) /qsatt-1.) - qclr = max(0., (q(i,j,k)-qn(i,j,k)-qsatt * cld3d(i,j,k)))/max(0.001, (1-cld3d(i,j,k))) - qclr = min(qclr, qsatt) - dq = dq * dtn * (qclr/qsatt-1.) - dq = dq * (cldmax(i,j,k) - cld3d_temp(i,j,k)) ! convert this to the grid-mean value - - dq = max(-0.5*qp(i,j,k),dq) -! qp(i,j,k) = qp(i,j,k) + dq -! q(i,j,k) = q(i,j,k) - dq - dqpevp = dq - qpevp(k) = qpevp(k) + dq - - end if - - if(qp(i,j,k).le.qp_threshold .and. cld3d(i,j,k).le.0) then -! q(i,j,k) = q(i,j,k) + qp(i,j,k) - dqpevp = dqpevp - qp(i,j,k) - qpevp(k) = qpevp(k) - qp(i,j,k) -! qp(i,j,k) = 0. - endif - - endif - - qp(i,j,k) = qp(i,j,k) + dqpsrc + dqpevp - q(i,j,k) = q(i,j,k) - dqpsrc - dqpevp - qn(i,j,k) = qn(i,j,k) - dqpsrc - - dq = qp(i,j,k) - qp(i,j,k)=max(0.,qp(i,j,k)) - q(i,j,k) = q(i,j,k) + (dq-qp(i,j,k)) - - end do - enddo -enddo - -!call t_stopf ('precip_proc_clubb') - -#endif /*CLUBB_CRM*/ -end subroutine precip_proc_clubb -#endif - diff --git a/src/physics/spcam/crm/Readme_codes_merging_sam6.8.2_sam6.10.4.txt b/src/physics/spcam/crm/Readme_codes_merging_sam6.8.2_sam6.10.4.txt deleted file mode 100644 index 6703aea205..0000000000 --- a/src/physics/spcam/crm/Readme_codes_merging_sam6.8.2_sam6.10.4.txt +++ /dev/null @@ -1,141 +0,0 @@ - -Here we merge CRM in SPCAM5 (https://svn-ccsm-models.cgd.ucar.edu/cam1/branches/spcam1_5_00_cam5_2_09_pnnl) -from the version of sam6.8.2 (sam_clubb trunk revision r763) to sam6.10.4 (the pnnl branch of sam_clubb revision tag r1130: - http://carson.math.uwm.edu/repos/sam_repos/branches/sam_clubb_r1061_pnnl) - -steps to do this: -1. compare sam_clubb r763 with the pnnl branch of sam_CLUBB r1130 -2. compare sam_clubb r763 with crm in SPCAM5 -3. compare sam_clubb r1130 with crm in SPCAM5 - -copy r763, r1130 to the src directory (models/atm/cam/src/physics/) - -July 1st, 2013: -advect_mom.F90: no change from spcam5_2_09 -advect_all_scalars.F90: not in r763, so copy it directly from r1130. DONE -./ADV_MPDATA/advect_scalar.F90: remove statistical part - /advect_scalar2D.F90: no change from r1130 - /advect_scalar3D.F90: no change from r1130 - /advection.F90: no change from r1130 -./ADV_UM5/advect_scalar.F90: remove statistical part - /advect_scalar2D.F90: no change from r1130 - /advect_scalar3D.F90: no change from r1130 -The above three files listed under ./crm are removed. - -boudaries.F90: copy "use grid, only: dompi" from r1130. So now boudaries.F90 - are identifical for spcam5_2_09 and r1130. -buoyancy.F90: add betu, betd part from r1130 - -clubb_sgs.F90: Incorporate changes from r1130 - -clubbvars.F90: incorporate changes from r1130 to spcam5_2_09 -clubb_silhs_vars.F90: directly copy it from r1130. This is not enabled in MMF. - -comparess3D.F90: the same as spcam5_2_09. No change. -coriolis.F90: update dvdt formula from r1130. - -crm_module.F90: DONE -crmsurface.F90: the same as spcam5_2_09. surface.F90 in r763 and r1130 are - different, but these differences are not relevant to SPCAM. -crmtracers.F90: the same as spcam5_2_09. No change from r763 to r1130. -damping.F90: No change. Note: the damping of t and micro_filed is removed from - r1130. Need to check with Marat to see whether we should incoroprate - this change to SPCAM5 as well. -diagnose.F90: incorporate changes from r763 to r1130 to spcam5_2_09. - -create two new subdirectories: SGS_TKE; SGS_CLUBBkvhkvm for subgrid treatment -./SGS_TKE/diffuse_mom.F90: the same as that in spcam5_2_09 -./SGS_TKE/diffuse_mom2D.F90: the same as r1130. No clubb-related codes, as - CLUBB-related code is added in a separate directory (SGS_CLUBBkvhkvm) -./SGS_TKE/diffuse_mom3d.F90: the same as r1130. No clubb-related codes, as - CLUBB-related code is added in a separate directory (SGS_CLUBBkvhkvm) -./SGS_TKE/diffuse_scalar.F90: the same as spcam5_2_09 (except tkh from sgs) -./SGS_TKE/diffuse_scalar2D.F90: the same as r1130; -./SGS_TKE/diffuse_scalar3D.F90: the same as r1130; -./SGS_TKE/shear_prod2D.F90: no change from r1130 or spcam5_2_09 -./SGS_TKE/shear_prod3D.F90: no change from r1130 or spcam5_2_09 -./SGS_TKE/tke_full.F90: adopted the one from r1130, but add changes from - spcam5_2_09 in terms of *_crm subroutine. In r763, tke is only updated - if .not.doscalar when dosmagor is true, but in r1130, no such - restriction. -./SGS_TKE/sgs.F90: - i) sgs_setparm: comment out reading namelist - ii) no change in sgs_init. This is now called in crm_module.F90, after - micro_init, and grdf_x, grdf_y, grdf_z are calcluated in - sgs_init. These were calcluated in crm_module.F90 in SPCAM5. - iii) sgs_statistics: this may need to be removed - -./SGS_CLUBBkvhkvm/sgs.F90: add docam_sfc_fluxes flag -./SGS_CLUBBkvhkvm/tke_full.F90: the same as the one from ./SGS_TKE/ -./SGS_CLUBBkvhkvm/diffuse_mom.F90: remove statistics -./SGS_CLUBBkvhkvm/diffuse_mom2D.F90: add docam_sfc_fluxes -./SGS_CLUBBkvhkvm/diffuse_mom2D_xy.F90: remove CLUBB-related. -./SGS_CLUBBkvhkvm/diffuse_mom2D_z.F90: add docam_sfc_fluxes -./SGS_CLUBBkvhkvm/diffuse_mom3D.F90: add docam_sfc_fluxes -./SGS_CLUBBkvhkvm/diffuse_mom3D_xy.F90: remove clubb-related -./SGS_CLUBBkvhkvm/diffuse_mom3D_z.F90: add docam_sfc_fluxes -./SGS_CLUBBkvhkvm/diffuse_scalar.F90: incorporate changes from spcam5_2_09 -./SGS_CLUBBkvhkvm/diffuse_scalar_xy.F90: incorporate changes from spcam5_2_09 -./SGS_CLUBBkvhkvm/diffuse_scalar_z.F90: incorporate chagnes from spcam5_2_09 -./SGS_CLUBBkvhkvm/fluxes_scalar_z.F90: incorporate changes from spcam5_2_09 - -domain.F90: no change from spcam5_2_09 -ftt.F: no change from spcam5_2_09 -forcing.F90: no change from spcam5_2_09 -gammaff.c: no change from spcam5_2_09 (seems not included in r1130 or r763) -grid.F90: Identifical to the one from r1130. There are large difference - between r1130 and r763. Need to double check whether there is any - potential issues. -ice_fall.F90: no change from spcam5_2_09 -init.F90: add qtostor to the one from spcam5_2_09 -kurant.F90: adopt one from r1130 -params.F90: adopt one from r1130, but add CRM-related codes. This is quite - different from r763 and spcam5_2_09. Need to double check to see - whether there is any poential issues -periodic.F90: adopt the one from r1130, and change CLUBB to CLUBB_CRM -precip_fall.F90: No change from spcam5_2_09 -press_grad.F90: the same as spcam5_2_09, but adopte changes from r763 to - r1130 ( a fix by P. Bloss). -press_rhs.F90: the same as the one from r1130 -pressure.F90: the same as the one from spcam5_2_09, but add "use params, only: - dowallx, dowally, docolumn". Probably need to check with Marat to see - whether we need update this. Pressure-related subroutines have littles - change from r763 to r1130. -random.F90: no changes from either spcam5_2_09 or r1130 -sat.F90: the same as spcam5_2_09 (quite different from r1130. But no change - from r763 to r1130). - -NO SETDATA.F90 in spcam5, but sgs_init is called in setdata. - so sgs_inti is called in crm_module.F90 - -setparm.F90: adopt from r1130, and add MMF-related from spcam5_2_09 - Things to note: sgs_setparm; forz and fcor are not caclcualted here in - r1130 any more (they are calculated in setgrid.F), but this is still - kept here. -setperturb.F90: Tke is now treated by calling setperturb_sgs. Otherwise, it is - the same as spcam5_2_09. - -stat_clubb.F90: Copy it from r1130. NO CHANGE YET. NEED TO BE CHANGED - -stepout.F90: No change from spcam5_2_09. It is not used in spcam5. so we may - remove it in the future. -task_init.F90: No change from spcam5_2_09 -task_util_NOMPI.F90: No change from spacm5_2_09 -tke_full.F90: deleted, as this has been added into ./SGS_TKE/ -utils.F90: Incorporate changes from r1130. -vars.F90: Incorporate changes from r1130. fcory(ny) is changed to fcory(0:ny). So the calculation of fcory in -crm_module is changed as well. - -./MICRO_SAM1MOM/cloud.F90: the same as spcam5_2_09 -./MICRO_SAM1MOM/micro_params.F90: the same as spcam5_2_09 -./MICRO_SAM1MOM/microphysics.F90: adopt changes from r1130. - s_ar is removed from micro_precip_fall -./MICRO_SAM1MOM/precip_init.F90: the same as spcam5_2_09 -./MICRO_SAM1MOM/precip_proc.F90: the same as spcam5_2_09 -./MICRO_SAM1MOM/precip_proc_clubb.F90: adopt from r1130 -./MICRO_M2005/microphysics.F90: incorporates changes from r1130 -./MICRO_M2005/module_mp_graupel.F90: incorporate change from r1130. Those - changes are quite minor, except a scaling factor is applied to contact - freezing nucleaiton rate and homogeneous freezing of cloud droplets. - -./CLUBB/: create a new CLUBB directory for the latest CLUBB used in MMF diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_clubb_sgs.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_clubb_sgs.F90 deleted file mode 100644 index 5e76947cfb..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_clubb_sgs.F90 +++ /dev/null @@ -1,2366 +0,0 @@ -!------------------------------------------------------------------------------- -! $Id: clubb_sgs.F90 1103 2013-05-14 18:35:02Z minghuai.wang@pnl.gov $ -module crmx_clubb_sgs -#ifdef CLUBB_CRM -! Description: -! Contains function and subroutines for interfacing with the UW Milwaukee -! Single-Column Model and also the CLUBB-SILHS subcolumn generator. - -! References: -! See DOC/CLUBB/clubb_doc/CLUBBeqns.pdf in this directory. -!------------------------------------------------------------------------------- - - use crmx_clubb_core, only: & - setup_clubb_core, advance_clubb_core, & - cleanup_clubb_core - - use crmx_clubb_precision, only: & - time_precision, & ! Constant(s) - core_rknd - - use crmx_domain, only: & - nsubdomains_x, & - nsubdomains_y - - use crmx_clubbvars, only: l_stats_samgrid - - implicit none - - private - - public :: clubb_sgs_setup, advance_clubb_sgs, clubb_sgs_cleanup, & - apply_clubb_sgs_tndcy, apply_clubb_sgs_tndcy_scalars, apply_clubb_sgs_tndcy_mom, t2thetal - - public :: total_energy - - logical, private :: lstats_clubb - - integer, dimension(nsubdomains_x*nsubdomains_y), private :: & - sample_nodes, x_samp, y_samp - - integer, private :: x_samp_node, y_samp_node - -#ifdef CLUBB_LH - integer, private, save :: LH_iter = 0 -#endif /* CLUBB_LH */ - contains -!------------------------------------------------------------------------------- - subroutine clubb_sgs_setup( dt_clubb, latitude, longitude, z, rho, zi, rhow, tv0, tke ) - -! Description: -! Initialize UWM CLUBB. - -! References: -! None -!------------------------------------------------------------------------------- - - ! From the CLUBB directory - use crmx_error_code, only: & - clubb_no_error, set_clubb_debug_level ! Subroutines - - use crmx_parameter_indices, only: & - nparams ! Constant - - use crmx_constants_clubb, only: & - em_min, w_tol_sqd, rt_tol, thl_tol, zero_threshold, & ! Constants - fstderr, fstdout - - use crmx_grid_class, only: & - zm2zt, zt2zm, & ! Functions - gr ! Derived type - - ! These are only needed if we're using a passive scalar - use crmx_array_index, only: & - iisclr_rt, iisclr_thl, iisclr_CO2, & ! [kg/kg]/[K]/[1e6 mol/mol] - iiedsclr_rt, iiedsclr_thl, iiedsclr_CO2 ! " " - - use crmx_parameters_tunable, only: & - read_parameters ! Subroutine - - use crmx_stats_subs, only: & - stats_init ! Subroutine - - use crmx_stat_clubb, only: stats_init_clubb - - use crmx_model_flags, only: & - l_use_boussinesq, & ! Variables - l_tke_aniso - - ! From the SAM directory - use crmx_grid, only: rank, nx, ny, nz, nzm, dx, dy, time, case, caseid, & - nrestart, dimx1_s, dimx2_s, dimy1_s, dimy2_s, ntracers ! Variable(s) - - use crmx_params, only: lcond, cp ! Constants - - use crmx_params, only: doclubb_sfc_fluxes ! Variable(s) -#ifdef CLUBB_LH - use crmx_microphysics, only: & - mkname, nmicro_fields ! Variable(s) - - use crmx_array_index, only: & - iirrainm, iiNrm, iirsnowm, iiricem, iirgraupelm, & ! Variables - iiNcm, iiNsnowm, iiNim, iiNgraupelm - - use latin_hypercube_arrays, only: & - d_variables, & ! Variable - setup_corr_varnce_array ! Procedure - - use crmx_parameters_microphys, only: & - l_lh_vert_overlap, & ! Variable(s) - l_fix_s_t_correlations, & - l_lh_cloud_weighted_sampling, & - LH_microphys_type, & - LH_microphys_disabled, & - LH_microphys_non_interactive, & - LH_microphys_calls, & - LH_seed, & - LH_sequence_length - - use crmx_parameters_microphys, only: & - rrp2_on_rrm2_cloud, & ! Variable(s) - Nrp2_on_Nrm2_cloud, & - Ncp2_on_Ncm2_cloud, & - rrp2_on_rrm2_below, & - Nrp2_on_Nrm2_below, & - Ncp2_on_Ncm2_below - - use crmx_parameters_microphys, only: & - rsnowp2_on_rsnowm2_cloud, & ! Variables - Nsnowp2_on_Nsnowm2_cloud, & - ricep2_on_ricem2_cloud, & - Nicep2_on_Nicem2_cloud, & - rsnowp2_on_rsnowm2_below, & - Nsnowp2_on_Nsnowm2_below, & - ricep2_on_ricem2_below, & - Nicep2_on_Nicem2_below -#else - use crmx_parameters_microphys, only: LH_microphys_type, LH_microphys_disabled -#endif /*CLUBB_LH */ - - use crmx_clubbvars, only: & - upwp, &! u'w'. [m^2/s^2] - vpwp, &! u'w'. [m^2/s^2] - up2, &! u'^2 [m^2/s^2] - vp2, &! v'^2 [m^2/s^2] - wprtp, &! w' r_t'. [(m kg)/(s kg)] - wpthlp, &! w' th_l'. [(m K)/s] - wprcp, &! w' r_c' [(kg/kg) m/s] - wp2, &! w'^2. [m^2/s^2] - rtp2, &! r_t'^2. [(kg/kg)^2] - thlp2, &! th_l'^2. [K^2] - rtpthlp,&! r_t' th_l'. [(kg K)/kg] - wp3 ! w'^3. [m^3/s^3] - - use crmx_clubbvars, only: & - tracer_tndcy, & ! Time tendency of the SAM set of tracers - t_tndcy, & ! CLUBB contribution to moist static energy [K/s] - qc_tndcy, & ! CLUBB contribution to liquid water [kg/kg/s] - qv_tndcy, & ! CLUBB contribution to vapor water [kg/kg/s] - u_tndcy, & ! CLUBB contribution to x-wind [m/s^2] - v_tndcy ! CLUBB contribution to y-wind [m/s^2] - - use crmx_clubbvars, only: & - sclrp2, & ! Passive scalar variance. [{units vary}^2] - sclrpthlp, & ! Passive scalar covariance. [{units vary}^2] - sclrprtp, & ! Passive scalar covariance. [{units vary}^2] - wpsclrp ! w'sclr' [units vary m/s] - - use crmx_clubbvars, only: & - rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] - rho_ds_zt, & ! Dry, static density on thermodynamic levels [kg/m^3] - invrs_rho_ds_zm, & ! Inv. dry, static density on momentum levels [m^3/kg] - invrs_rho_ds_zt, & ! Inv. dry, static density on thermo. levels [m^3/kg] - thv_ds_zm, & ! Dry, base-state theta_v on momentum levels [K] - thv_ds_zt ! Dry, base-state theta_v on thermo. levels [K] - - use crmx_clubbvars, only: & - sclr_tol, & ! Tolerance on high-order scalars - edsclr_dim, & ! Number of eddy-diffusivity scalars - sclr_dim ! Numer of high-order scalars - - use crmx_clubbvars, only: & - tndcy_precision ! Precision of CLUBB's contribution to the tendencies of mean variables - -#ifdef CLUBB_LH - use crmx_clubb_silhs_vars, only: & - LH_rt, & - LH_t, & - X_nl_all_levs, & - LH_sample_point_weights, & - X_mixt_comp_all_levs, & - micro_field_prior, & - LH_micro_field_sum_tndcy, & - LH_micro_field_avg_tndcy - - use crmx_mt95, only: & - genrand_init, & - genrand_intg -#endif - -#ifdef CRM - use crmx_clubbvars, only: lrestart_clubb -#endif - - implicit none - - ! Constant parameters - logical, parameter :: & - l_uv_nudge = .false., & ! Use u/v nudging (not used) - l_implemented = .true. ! Implemented in a host model (always true) - - integer, parameter :: & - grid_type = 2, & ! The 2 option specifies stretched thermodynamic levels - iunit = 50 ! Fortran I/O unit - - character(len=6), parameter :: & - saturation_equation = "flatau" ! Flatau polynomial approximation for SVP - -#ifdef CLUBB_LH - character(len=*), parameter :: & - input_file_cloud = "/silhs_corr_matrix_cloud.in", & - input_file_below = "/silhs_corr_matrix_below.in" - - logical, parameter :: & - doicemicro = .true. -#endif - real(kind=core_rknd), parameter :: & - theta0 = 300._core_rknd, &! Reference temperature [K] - ts_nudge = 86400._time_precision ! Time scale for u/v nudging (not used) [s] - - ! Input Variables - real(kind=time_precision), intent(in) :: & - dt_clubb ! SAM-CLUBB subcycled model timestep [s] - - real, dimension(nx, ny), intent(in) :: & - latitude, & ! Latitudes for SAM's dynamical core [degrees_N] - longitude ! Longitudes for SAM's dynamical core [degrees_E] - - real, dimension(nzm), intent(in) :: & - z, & ! Thermodynamic/Scalar grid in SAM [m] - rho ! Thermodynamic/Scalar density in SAM [kg/m^3] - - real, dimension(nz), intent(in) :: & - zi, & ! Momentum/Vertical Velocity grid in SAM [m] - rhow ! Momentum/Vertical Velocity density in SAM [kg/m^3] - - real, dimension(nzm), intent(in) :: & - tv0 ! Virtual potential temperature from SAM [K] - - real, dimension(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm), intent(in) :: & - tke ! SGS TKE [m^2/s] - - ! Local Variables - real(kind=core_rknd), dimension(nparams) :: & - clubb_params ! These adjustable CLUBB parameters (C1, C2 ...) - - ! 1D variables with ghost points at the lowest level - real(kind=core_rknd), dimension(nz) :: & - zt, & ! Thermodynamic grid [m] - zm, & ! Momentum grid [m] - em ! Turbulent kinetic energy [-] - - logical :: l_stats ! Stats enabled (T/F) - - logical :: l_output_rad_files ! stats enabled for radiative fields (T/F) - - real(kind=time_precision) :: & - stats_tsamp, & ! Sampling interval for a single column of CLUBB data [s] - stats_tout ! Output interval for a single column of CLUBB data [s] - - character(len=10) :: stats_fmt ! Format of stats output (netCDF/GrADS) - character(len=250) :: fname_prefix ! Prefix for stats filename - - ! Horizontal grid spacings (i.e., dx and dy), used for computing Lscale_max - real(kind=core_rknd) :: host_dx, host_dy ! [m] - - real(kind=core_rknd), dimension(1) :: & - rlat, rlon ! Latitude and Longitude for stats [degrees] - - integer :: & - err_code, & ! Code for when CLUBB fails - i, j, ig, jg, & ! Loop indices - ilen ! Length of a string - - integer :: hydromet_dim - logical :: l_host_applies_sfc_fluxes ! Whether the host model applies the surface fluxes -#ifdef CLUBB_LH - integer :: indx -#endif - - namelist /stats_setting/ l_stats_samgrid, l_stats, l_output_rad_files, & - stats_fmt, stats_tsamp, stats_tout, & - sample_nodes, x_samp, y_samp - -#ifdef CLUBB_LH - namelist /clubb_silhs/ LH_microphys_type, LH_microphys_calls, & - LH_sequence_length, LH_seed, l_lh_vert_overlap, l_fix_s_t_correlations, & - l_lh_cloud_weighted_sampling, rrp2_on_rrm2_cloud, & - rrp2_on_rrm2_below, Nrp2_on_Nrm2_cloud, & - Nrp2_on_Nrm2_below, Ncp2_on_Ncm2_cloud, Ncp2_on_Ncm2_below, & - rsnowp2_on_rsnowm2_cloud, Nsnowp2_on_Nsnowm2_cloud, & - ricep2_on_ricem2_cloud, Nicep2_on_Nicem2_cloud, & - rsnowp2_on_rsnowm2_below, Nsnowp2_on_Nsnowm2_below, & - ricep2_on_ricem2_below, Nicep2_on_Nicem2_below -#endif -!------------------------------------------------------------------------------- -! SAM uses an Arakawa C type grid for the 3D quantities. The UWM SCM has an -! additional `ghost' point on the lowest pressure/thermodynamic level. -! i.e. -! -! SAM vert. vel. grid UWM SCM moment. grid -! -! Dimension Elevation Dimension Elevation -! . . . (nz ) . . zi(nz ) . . . (gr%nz ) . . gr%zm(gr%nz ) . . . -! . . . (nz-1) . . zi(nz-1) . . . (gr%nz-1) . . gr%zm(gr%nz-1) . . . -! | | | | -! . . . (1 ) . . zi(1 ) . . . (1 ) . . gr%zm(1 ) . . . -! -! In SAM the lowest grid point on the vertical velocity levels (or `interface' -! levels) is always 0 meters. The UWM SCM supports an arbitrary starting -! point for the momentum grid, but this code assumes 0 meters. -! -! SAM pressure grid UWM SCM thermo. grid -! -! Dimension Elevation Dimension Elevation -! . . . (nz-1) . . z(nz-1) . . . (gr%nz ) . . gr%zt(gr%nz ) . . . -! . . . (nz-2) . . z(nz-2) . . . (gr%nz-1) . . gr%zt(gr%nz-1) . . . -! | | | | -! . . . (1 ) . . z(1 ) . . . (2 ) . . gr%zt(2 ) . . . -! / / / N/A / / N/A / / / (1 ) / / gr%zt(1 ) / / / -! -! Note that the lowest SCM point is below ground. -!------------------------------------------------------------------------------- - - !----- Begin Code ----- - - ! Set the ghost point to be the distance between the first interface level, - ! which is always zero, and the first pressure level. - zt(1) = real( -z(1), kind=core_rknd ) ! [m] - ! All other pressure levels are determined by the host model - zt(2:nz) = real( z(1:nzm), kind=core_rknd ) ! [m] - - zm = real( zi, kind=core_rknd ) - - ! Set the SCM parameters (C2, etc. ) based on default values - !call read_parameters( -99, "", clubb_params ) - - ! Set the SCM parameters (C2, etc. ) based on a namelist -#ifdef CRM - ! Set the SCM parameters (C2, etc. ) based on default values - call read_parameters( -99, "", clubb_params ) -#else - ! Set the SCM parameters (C2, etc. ) based on a namelist - call read_parameters( iunit, "CLUBB_PARAMETERS/tunable_parameters.in", clubb_params ) -#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( 0 ) - - host_dx = real( dx, kind=core_rknd ) - host_dy = real( dy, kind=core_rknd ) - - ! These are for emulating total water or thetal for testing purposes - iisclr_rt = -1 - iisclr_thl = -1 - iisclr_CO2 = -1 - - iiedsclr_rt = -1 - iiedsclr_thl = -1 - iiedsclr_CO2 = -1 - - ! Sanity check - if ( sclr_dim > 0 .and. edsclr_dim > 0 ) then - write(fstderr,*) "Only one scalar scheme can be enabled at one time" - call task_abort() - end if - - ! This is the tolerance on total water in the CLUBB SCM - ! Other tracers will need this value set according to their order of - ! magnitude and the units they are in. Keep in mind that the variable - ! sclrp2 will be clipped to a minimum value of sclr_tol^2 - sclr_tol(1:sclr_dim) = 1.e-8_core_rknd ! total water is in kg/kg - - ! Determine whether clubb is applying the surface flux or the host model - ! from the namelist variable doclubb_sfc_fluxes - l_host_applies_sfc_fluxes = .not. doclubb_sfc_fluxes - -#ifdef CLUBB_LH - hydromet_dim = nmicro_fields + 2 -#else - hydromet_dim = 0 ! The hydromet array in SAM-CLUBB is currently 0 elements -#endif - - call setup_clubb_core & - ( nz, 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, zm(2), zm(1), zm(nz), & ! In - zm(1:nz), zt(1:nz), & ! In - host_dx, host_dy, zm(1), & ! In - err_code ) - - if ( err_code /= CLUBB_no_error ) then - write(fstderr,*) "Initialization of CLUBB failed" - call task_abort() - end if - - l_stats_samgrid = .false. - l_output_rad_files = .false. - -#ifndef CRM - open(unit=iunit, file="clubb_stats_sam") - read(unit=iunit, nml=stats_setting) - write(0, *) 'l_stats_samgrid', l_stats_samgrid - close(unit=iunit) -#endif /*CRM*/ - - if(.not.l_stats_samgrid) then ! output clubb statistics from clubb side - ! Initialize stats_setting - l_stats = .false. - stats_fmt = "grads" - stats_tsamp = 60._time_precision - stats_tout = 60._time_precision - sample_nodes(:) = -1 ! Which nodes are outputting a column - x_samp(:) = -1 ! Which x point for the nth node - y_samp(:) = -1 ! Which y point for the nth node - -#ifndef CRM - ! Figure out which node and points we're sampling - open(unit=iunit, file="clubb_stats") - read(unit=iunit, nml=stats_setting) - close(unit=iunit) -#endif /*CRM*/ - - if ( is_a_sample_node( rank ) .and. l_stats ) then - - ! Determine and save the local x and y to write to be written to disk - call get_sample_points( rank, x_samp_node, y_samp_node ) - - ! Figure out the position on the global grid - call task_rank_to_index( rank, ig, jg ) - - ! The filename follows the following format: - ! case_caseid_x_y_ - ! e.g. (variables in single quotes) - ! 'BOMEX'_'64x64x75_scm_LES'_x000'1'_y00'10'_'zt' - fname_prefix = trim( case )//"_"//trim( caseid ) - ilen = len( trim( fname_prefix ) ) - fname_prefix = trim( fname_prefix )//"_x0000_y0000" - write(unit=fname_prefix(ilen+3:ilen+6),fmt='(i4.4)') ig+x_samp_node - write(unit=fname_prefix(ilen+9:ilen+12),fmt='(i4.4)') jg+y_samp_node - rlat = real( latitude(x_samp_node,y_samp_node), kind=core_rknd ) - rlon = real( longitude(x_samp_node,y_samp_node), kind=core_rknd ) - - ! Use a bogus date, since SAM does not track the year, and it would require - ! some work to convert the `day' variable to MMDD format - call stats_init( iunit, fname_prefix, "./OUT_STAT/", l_stats, & - stats_fmt, stats_tsamp, stats_tout, "clubb_stats", & - nz, zt, zm, nz, zt, nz, zm, 1, 4, 1900, & - rlat, rlon, & - time, dt_clubb ) - - ! If CLUBB stats are on for this node, toggle a flag in this module - write(fstdout,*) "CLUBB stats enabled" - lstats_clubb = .true. - else - lstats_clubb = .false. - x_samp_node = -1 - y_samp_node = -1 - end if - end if ! .not. l_stats_samgrid - -#ifdef CLUBB_LH - ! Default values for namelist parameters - LH_microphys_type = LH_microphys_non_interactive - LH_microphys_calls = 2 - LH_sequence_length = 1 - LH_seed = 5489_genrand_intg - l_lh_vert_overlap = .true. - l_fix_s_t_correlations = .true. - l_lh_cloud_weighted_sampling = .true. - - ! Variances / Corrlations here are those used with the RICO case - rrp2_on_rrm2_cloud = 0.766 - rrp2_on_rrm2_below = rrp2_on_rrm2_cloud - Nrp2_on_Nrm2_cloud = 0.429 - Nrp2_on_Nrm2_below = Nrp2_on_Nrm2_cloud - Ncp2_on_Ncm2_cloud = 0.003 - Ncp2_on_Ncm2_below = Ncp2_on_Ncm2_cloud - - ! Made up values for the variance of ice/snow, since we currently lack data - ! for this. - rsnowp2_on_rsnowm2_cloud = 0.766 - Nsnowp2_on_Nsnowm2_cloud = 0.429 - ricep2_on_ricem2_cloud = 1.0 - Nicep2_on_Nicem2_cloud = 1.0 - - rsnowp2_on_rsnowm2_below = 0.766 - Nsnowp2_on_Nsnowm2_below = 0.429 - ricep2_on_ricem2_below = 1.0 - Nicep2_on_Nicem2_below = 1.0 - - ! Read the namelist from the prm file - open(unit=iunit, file=trim( case )//"/prm") - read(unit=iunit, nml=clubb_silhs) - close(unit=iunit) - - if ( LH_microphys_type /= LH_microphys_disabled ) then - iiNcm = -1 ! Initialize to no Nc prediction - - ! Determine total number of sample variates other than t, rt, and w. - do indx = 1, nmicro_fields - select case ( trim( mkname(indx) ) ) - case ( 'QR', 'QP' ) - iirrainm = indx - - case ( 'QI' ) - iiricem = indx - - case ( 'QS' ) - iirsnowm = indx - - case ( 'QG' ) - ! This is not currently sampled, but we need the index to copy the - ! mean from saved microphysics field - iirgraupelm = indx - - case ( 'CONP', 'NR' ) - iiNrm = indx - - case ( 'NI' ) - iiNim = indx - - case ( 'NS' ) - iiNsnowm = indx - - case ( 'NG' ) - ! See note above for QG. - iiNgraupelm = indx - - case ( 'CONC', 'NC' ) - iiNcm = indx - - end select - end do ! 1..n_micro_fields - ! This is for when Ncm not predicted but we would like to output the fixed value - if ( iiNcm == -1 ) then - iiNcm = indx + 1 - end if - - ! Determine d_variables and other LH indices by reading in the correlation - ! files and from indexes determined above - call setup_corr_varnce_array( iirrainm, iiNrm, iiricem, iiNim, iirsnowm, iiNsnowm, & ! In - doicemicro, & ! In - trim( case )//input_file_cloud, & ! In - trim( case )//input_file_below, iunit ) ! In - - ! Allocate based on LH_microphys_calls and d_variables - allocate( LH_rt(nx,ny,nzm,LH_microphys_calls), LH_t(nx,ny,nzm,LH_microphys_calls), & - X_nl_all_levs(nx,ny,nzm,LH_microphys_calls,d_variables), & - X_mixt_comp_all_levs(nx,ny,nzm,LH_microphys_calls), & - LH_sample_point_weights(nx,ny,LH_microphys_calls), & - micro_field_prior(nx,ny,nzm,nmicro_fields), & - LH_micro_field_sum_tndcy(nx,ny,nzm,nmicro_fields), & - LH_micro_field_avg_tndcy(nx,ny,nzm,nmicro_fields) ) - - end if ! LH_microphys_type /= disabled -#else - LH_microphys_type = LH_microphys_disabled ! LH_microphys_type is needed even when LH is - ! not enabled in stats_subs.F90 (stats_finalize) - ! +++mhwang 2013-01 -#endif /*CLUBB_LH*/ - - if(l_stats_samgrid) then ! output clubb statistics in SAM - l_stats = .true. - stats_tsamp = dt_clubb - stats_tout = dt_clubb - call stats_init_clubb(l_stats, l_output_rad_files, stats_tsamp, & - stats_tout, nz, nz, nz, time, dt_clubb) - end if - -#ifdef CRM -!+++mhwang, 2012-02-06 (Minghuai.Wang@pnnl.gov) -! rho_ds_zm, rho_ds_zt, thv_ds_zt, thv_ds_zm, invrs_rho_ds_zm, invrs_rho_ds_zt are needed -! to be copied from those from the GCM at the beginning of each GCM time step. - if (lrestart_clubb) then - ! Set variables for the use of the anelastic equation set in CLUBB. - ! Set the value of dry, static, base-state density. - rho_ds_zm(:) = rhow(:) - rho_ds_zt(2:nz) = rho(1:nzm) - rho_ds_zt(1) = LIN_EXT( rho_ds_zt(3), rho_ds_zt(2), gr%zt(3), gr%zt(2), gr%zt(1) ) - ! Set the value of dry, base-state theta_v. - thv_ds_zt(2:nz) = tv0(1:nzm) - thv_ds_zt(1) = tv0(1) - thv_ds_zm(:) = zt2zm( thv_ds_zt ) - - ! Set the value of inverse dry, static, base-state density based on the - ! value of dry, static, base-state density. - invrs_rho_ds_zm(:) = 1.0 / rho_ds_zm(:) - invrs_rho_ds_zt(:) = 1.0 / rho_ds_zt(:) - end if -#endif /*CRM*/ - - ! If this is restart run, just return at this point and do not re-initialize - ! any variables as we would a run starting from the beginning. - -#ifndef CRM - if ( nrestart /= 0 ) return -#else - if (lrestart_clubb ) return -#endif - -#ifdef CLUBB_LH - call genrand_init( put=LH_seed ) -#endif - - if ( sclr_dim > 0 ) then - sclrp2 = 0._core_rknd - sclrprtp = 0._core_rknd - sclrpthlp = 0._core_rknd - wpsclrp = 0._core_rknd - end if - - ! Initialize CLUBB's tendencies to 0 - t_tndcy = 0._tndcy_precision - qc_tndcy = 0._tndcy_precision - qv_tndcy = 0._tndcy_precision - u_tndcy = 0._tndcy_precision - v_tndcy = 0._tndcy_precision - - if ( ntracers > 0 ) then - tracer_tndcy = 0._tndcy_precision - end if - - ! SAM's dynamical core is anelastic, so l_use_boussineq should probably be - ! set to false generally, as it is by default in the CLUBB SCM. - if ( l_use_boussinesq ) then - rho_ds_zm(:) = 1._core_rknd - rho_ds_zt(:) = 1._core_rknd - ! Set the value of dry, base-state theta_v. - thv_ds_zm(:) = theta0 - thv_ds_zt(:) = theta0 - else - ! Set variables for the use of the anelastic equation set in CLUBB. - ! Set the value of dry, static, base-state density. - rho_ds_zm(:) = real( rhow(:), kind=core_rknd ) - rho_ds_zt(2:nz) = real( rho(1:nzm), kind=core_rknd ) - rho_ds_zt(1) = LIN_EXT( rho_ds_zt(3), rho_ds_zt(2), gr%zt(3), gr%zt(2), gr%zt(1) ) - ! Set the value of dry, base-state theta_v. - thv_ds_zt(2:nz) = real( tv0(1:nzm), kind=core_rknd ) - thv_ds_zt(1) = real( tv0(1), kind=core_rknd ) - thv_ds_zm(:) = zt2zm( thv_ds_zt ) - end if - ! Set the value of inverse dry, static, base-state density based on the - ! value of dry, static, base-state density. - invrs_rho_ds_zm(:) = 1.0_core_rknd / rho_ds_zm(:) - invrs_rho_ds_zt(:) = 1.0_core_rknd / rho_ds_zt(:) - - ! Determine the initial value of some variables as in WRF-CLUBB - - wprtp(:,:,:) = 0._core_rknd ! w'rt' - wpthlp(:,:,:) = 0._core_rknd ! w'thl' - wprcp(:,:,:) = 0._core_rknd ! w'rc' - wp3(:,:,:) = 0._core_rknd ! w'^3 - wp2(:,:,:) = w_tol_sqd ! w'^2 - up2(:,:,:) = w_tol_sqd ! u'^2 - vp2(:,:,:) = w_tol_sqd ! v'^2 - rtp2(:,:,:) = rt_tol**2 ! rt'^2 - thlp2(:,:,:) = thl_tol**2 ! thl'^2 - rtpthlp(:,:,:) = 0._core_rknd ! rt'thl' - upwp(:,:,:) = 0._core_rknd ! u'w' - vpwp(:,:,:) = 0._core_rknd ! v'w' - - do i=1, nx, 1 - do j=1, ny, 1 - - ! Extrapolate intial SGS TKE and use it to compute wp2 - ! This value is going to depend on initial noise and whether - ! Smagorinksy diffusion is enabled - em(2:nz) = real( tke(i,j,1:nzm), kind=core_rknd ) - em(1) = LIN_EXT( em(3), em(2), gr%zt(3), gr%zt(2), gr%zt(1) ) - em(1:nz) = max( zt2zm( em(1:nz) ), em_min ) - -! em(:) = 1.0 ! Use this value for comparing DYCOMS II RF02 to the CLUBB SCM. - - !!!! Initialize w'^2 based on initial SGS TKE !!!! - - if ( l_tke_aniso ) then - - ! SGS TKE: em = (1/2) * ( w'^2 + u'^2 + v'^2 ) - ! Evenly divide SGS TKE into its component - ! contributions (w'^2, u'^2, and v'^2). - - wp2(i,j,1:nz) = (2._core_rknd/3._core_rknd) * em(1:nz) - up2(i,j,1:nz) = (2._core_rknd/3._core_rknd) * em(1:nz) - vp2(i,j,1:nz) = (2._core_rknd/3._core_rknd) * em(1:nz) - - else - - ! Assume isotropy for initialization of wp2 - ! SGS TKE: em = (3/2) * w'^2 - - wp2(i,j,1:nz) = (2._core_rknd/3._core_rknd) * em(1:nz) - - end if - - end do ! j=1..ny - end do ! i=1..nx - - return - end subroutine clubb_sgs_setup - -!------------------------------------------------------------------------------- - subroutine advance_clubb_sgs( dt_clubb, time_initial, time_current, & - rho, rhow, wsub, u, v, w, qpl, qci, qpi, & - t, qv, qcl ) - -! Description: -! Advance Cloud Layers Unified By Binormals 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. -!------------------------------------------------------------------------------- - - ! From SAM - use crmx_grid, only: & - nx, ny, nxp1, nyp1, nz, nzm,&! Local grid dimensions - nx_gl, ny_gl, &! Global grid dimensions - dimx1_s, dimx2_s, dimy1_s, dimy2_s,& ! Scalars dimensions - dimx1_u, dimx2_u, dimy1_u, dimy2_u,& ! U wind dimensions - dimx1_v, dimx2_v, dimy1_v, dimy2_v,& ! V wind dimensions - dimx1_w, dimx2_w, dimy1_w, dimy2_w,& ! W wind dimensions - YES3D, rank, pres, dompi, & - ntracers - - use crmx_params, only: cp, lfus, lsub, & - ug, vg ! ug and vg are scalars, not arrays - - use crmx_params, only: doclubb ! Variable(s) - - use crmx_params, only: latitude0, longitude0 - - use crmx_vars, only: & - fcory, fluxbt, fluxbq, fluxbu, fluxbv, gamaz, prespot ! Variables - - use crmx_microphysics, only: nmicro_fields - - use crmx_clubbvars, only: & - upwp, &! u'w'. [m^2/s^2] - vpwp, &! u'w'. [m^2/s^2] - up2, &! u'^2 [m^2/s^2] - vp2, &! v'^2 [m^2/s^2] - wprtp, &! w' r_t'. [(m kg)/(s kg)] - wpthlp, &! w' th_l'. [(m K)/s] - wprcp, &! w' r_c'. [(kg/kg) m/s] - wp2, &! w'^2. [m^2/s^2] - rtp2, &! r_t'^2. [(kg/kg)^2] - thlp2, &! th_l'^2. [K^2] - rtpthlp, &! r_t' th_l'. [(kg K)/kg] - rcm, &! Cloud water [kg/kg] - cloud_frac, &! Cloud Fraction. [-] - rcm_in_layer,&! rcm in cloud layer [kg/kg] - cloud_cover, &! Cloud Cover [-] - wp3, &! w'^3. [m^3/s^3] - um, &! x-wind [m/s] - vm ! y-wind [m/s] - - use crmx_clubbvars, only: & - khzm, &! eddy diffusivity on momentum grids [m^2/s] - khzt, &! eddy diffusivity on thermo grids [m^2/s] - qclvarg, &! cloud water variance [kg^2/kg^2] - relvarg, &! relative cloud water variance - accre_enhang ! accretion enhancement - - - - use crmx_clubbvars, only: & - sclrp2, & ! Passive scalar variance. [{units vary}^2] - sclrpthlp, & ! Passive scalar covariance. [{units vary}^2] - sclrprtp, & ! Passive scalar covariance. [{units vary}^2] - wpsclrp ! w'sclr' [units vary m/s] - - use crmx_clubbvars, only: & - u_tndcy,& ! CLUBB contribution to the x wind - v_tndcy,& ! CLUBB contribution to the y wind - qv_tndcy,& ! CLUBB contribution to vapor water mixing ratio - qc_tndcy,& ! CLUBB contribution to liquid water mixing ratio - t_tndcy ! CLUBB contribution to moist static energy - - use crmx_clubbvars, only: & - tracer_tndcy ! CLUBB contribution to a set of tracers - - use crmx_clubbvars, only: & - rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] - rho_ds_zt, & ! Dry, static density on thermodynamic levels [kg/m^3] - invrs_rho_ds_zm, & ! Inv. dry, static density on momentum levels [m^3/kg] - invrs_rho_ds_zt, & ! Inv. dry, static density on thermo. levels [m^3/kg] - thv_ds_zm, & ! Dry, base-state theta_v on momentum levels [K] - thv_ds_zt ! Dry, base-state theta_v on thermo. levels [K] - - use crmx_clubbvars, only: & - sclr_dim, & ! Constant(s) - edsclr_dim - - use crmx_clubbvars, only: & - tndcy_precision ! Constant(s) - -#ifndef CRM - use tracers, only: & -#else - use crmx_crmtracers, only: & -#endif - fluxbtr, & - tracer - - ! From CLUBB - use crmx_error_code, only: & - clubb_no_error, & ! Constant - clubb_at_least_debug_level ! Function - - use crmx_grid_class, only: & - zm2zt, zt2zm, & ! Functions - gr ! Derived type - - use crmx_stats_variables, only: & - l_stats, l_stats_samp ! Logicals - - use crmx_stats_subs, only: & - stats_begin_timestep, stats_end_timestep ! Subroutines - - use crmx_stat_clubb, only: stats_end_timestep_clubb - - use crmx_pdf_parameter_module, only: & - pdf_parameter ! Derived type - - use crmx_constants_clubb, only: & - fstderr ! Constant - -#ifdef CLUBB_LH - use crmx_parameters_microphys, only: & - l_lh_vert_overlap, & ! Variable(s) - LH_microphys_type, & - LH_microphys_disabled, & - LH_microphys_non_interactive, & - LH_microphys_calls, & - LH_sequence_length - - use crmx_variables_diagnostic_module, only: & - Lscale ! Variable(s) - - use crmx_fill_holes, only: & - vertical_avg ! Procedure(s) - - use crmx_parameters_model, only: & - hydromet_dim ! Variable(s) - - use crmx_array_index, only: & - iirrainm, iiNrm, iirsnowm, iiricem, & ! Variables - iiNcm, iiNsnowm, iiNim, iiNgraupelm, iirgraupelm - - use latin_hypercube_arrays, only: & - xp2_on_xm2_array_cloud, & ! Variable(s) - xp2_on_xm2_array_below, & - corr_array_cloud, & - corr_array_below, & - d_variables - - use crmx_corr_matrix_module, only: & - iiLH_s_mellor, iiLH_w, & - iiLH_rrain, iiLH_rsnow, iiLH_rice, & - iiLH_Nr, iiLH_Nsnow, iiLH_Ni, iiLH_Nc - - use latin_hypercube_driver_module, only: & - LH_subcolumn_generator, & ! Procedure(s) - stats_accumulate_LH - - use crmx_stats_subs, only: & - stats_accumulate_hydromet - - use crmx_stat_clubb, only: stats_end_timestep_clubb - - use crmx_microphysics, only: & - conc, micro_field, nmicro_fields ! Variable(s) - - use crmx_clubb_silhs_vars, only: & - LH_rt, & ! Variable(s) - LH_t, & - X_nl_all_levs, & - LH_sample_point_weights, & - X_mixt_comp_all_levs -#endif /*CLUBB_LH*/ - - implicit none - - ! Parameters - logical, parameter :: & - l_implemented = .true., & ! CLUBB is implemented in a host model, so this is true - l_advect = .false. ! Whether to advect around the high-order moments - - real(kind=core_rknd), parameter, dimension(nz) :: & - zero = 0.0_core_rknd ! Field of zeros - - ! Input - real(kind=time_precision), intent(in) :: & - dt_clubb ! Timestep size for CLUBB [s] - - real(kind=time_precision), intent(in) :: & - time_initial, time_current ! Initial and current time [s] - - real, intent(in), dimension(nzm) :: & - rho ! Air density [kg/m^3] - - real, intent(in), dimension(nz) :: & - wsub,&! Imposed vertical velocity [m/s] - rhow ! Density on vert velocity grid [kg/m^3] - - real, intent(in), dimension(dimx1_u:dimx2_u,dimy1_u:dimy2_u,nzm) :: & - u ! u wind [m/s] - - real, intent(in), dimension(dimx1_v:dimx2_v,dimy1_v:dimy2_v,nzm) :: & - v ! v wind [m/s] - - real, intent(in), dimension(dimx1_w:dimx2_w, dimy1_w:dimy2_w, nz ) :: & - w ! Vertical wind [m/s] - - real, intent(in), dimension(nx,ny,nzm) :: & - qpl,& ! Liquid water mixing ratio (precipitation) [kg/kg] - qci,& ! Cloud ice water mixing ratio [kg/kg] - qpi ! Snow + graupel mixing ratio (precip) [kg/kg] - - real, intent(in), dimension(dimx1_s:dimx2_s,dimy1_s:dimy2_s,nzm) :: & - t ! Moist static energy [K] - - real, intent(in), dimension(nx,ny,nzm) :: & - qv, & ! Water vapor mixing ratio [kg/kg] - qcl ! Liquid water mixing ratio (condensate) [kg/kg] - - ! Local Variables - real(kind=core_rknd) :: & - 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] - - real(kind=core_rknd), dimension(nz) :: & - thlm, &! Liquid water potential temperature (theta_l) [K] - rtm, &! Total water mixing ratio [kg/kg] - p_in_Pa, &! Pressure [Pa] - rho_zt, &! Density on pressure levels [kg/m^3] - rho_zm, &! Density on momentum levels [kg/m^3] - exner, &! Exner function [-] - wm_zm, &! Imposed subs. + perturbation w on vertical vel. levels [m/s] - wm_zt, &! Imposed subs. + perturbation w on pressure levels [m/s] - rfrzm ! Total ice-phase water mixing ratios [kg/kg] - - real, dimension(nz) :: & - dum ! Dummy array for advection - - real(kind=core_rknd), allocatable, dimension(:,:) :: & - sclrm, & ! Array for high order passive scalars - sclrm_forcing, & ! Large-scale forcing array for passive scalars - edsclrm, & ! Array for eddy passive scalars - edsclrm_forcing ! Large-scale forcing array for eddy passive scalars - - real(kind=core_rknd), allocatable, dimension(:) :: & - wpedsclrp_sfc, & ! Array for passive scalar surface flux - wpsclrp_sfc ! Array for high order scalar surface flux - - ! Thermo grid versions of variables on the momentum grid - real, dimension(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nz) :: & - wp2_zt, rtp2_zt, thlp2_zt, rtpthlp_zt, & - wprtp_zt, wpthlp_zt, up2_zt, vp2_zt, & - um_r4, vm_r4, um_old, vm_old ! wind arrays - - real(kind=tndcy_precision), dimension(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nz) :: & - um_change, vm_change ! Change in u/v [m/s^2] - - type(pdf_parameter), allocatable, dimension(:) :: & - pdf_params ! PDF parameters [units vary] - -#ifdef CLUBB_LH - real(kind=core_rknd), dimension(nz,hydromet_dim) :: & - hydromet ! Collection of all microphysics fields [units vary] - - real(kind=core_rknd), dimension(nzm) :: & - Lscale_vert_avg - - real(kind=core_rknd), dimension(nzm,LH_microphys_calls) :: & - LH_thl -#endif /* CLUBB_LH */ - - real(kind=core_rknd), dimension(nz) :: & - ice_supersat_frac, & - radf - - real(kind=core_rknd), dimension(nz) :: & - khzttemp, khzmtemp - - real(kind=core_rknd), dimension(nz) :: qclvartemp - - integer :: err_code - - ! Array indices - integer :: i, j, k, ig, jg, ip1, jp1, jm1, indx - -#ifdef CLUBB_LH - integer :: km1, kp1 -#endif -!------------------------------------------------------------------------------- - - !----- Begin Code ----- - -#ifndef CRM - call t_startf('advance_clubb') ! For timing -#endif - - ! Initialize err_code to CLUBB_no_error. In the event of the singular - ! matrix, etc. the variable will be set to the appropriate error code - ! within advance_clubb_core - err_code = CLUBB_no_error - - ! Feed nothing into radf (set it to zero) - radf(1:nz) = 0.0_core_rknd - - ! Density is in correct units - rho_zt(2:nz) = real( rho(1:nzm), kind=core_rknd ) - rho_zt(1) = LIN_EXT( rho_zt(3), rho_zt(2), gr%zt(3), gr%zt(2), gr%zt(1) ) - - rho_zm(1:nz) = real( rhow(1:nz), kind=core_rknd ) - - ! Compute and extrapolate Exner function - exner(2:nz) = 1.0_core_rknd / real( prespot(1:nzm), kind=core_rknd ) - exner(1) = 1.0_core_rknd / LIN_EXT( exner(3), exner(2), gr%zt(3), gr%zt(2), gr%zt(1) ) - - ! Allocate passive scalar arrays - allocate( wpsclrp_sfc(sclr_dim), sclrm(nz,sclr_dim), & - sclrm_forcing(nz,sclr_dim) ) - allocate( wpedsclrp_sfc(edsclr_dim), edsclrm(nz,edsclr_dim), & - edsclrm_forcing(nz,edsclr_dim) ) - - ! Allocate variables for the PDF closure scheme - allocate( pdf_params(1:nz) ) - - um_r4 = 0.0 - vm_r4 = 0.0 - do i = 1, nx, 1 - do j = 1, ny, 1 - - ip1 = min( nxp1, i+1 ) ! This is redundant, but we include it for safety - jp1 = min( nyp1, j+1 ) ! This prevents an array out of bounds error - ! for dvdt in a 2D simulation - - ! Average u-wind (east-west wind) to scalar points. - um_r4(i,j,2:nz) = 0.5 * ( u(i,j,1:nzm) + u(ip1,j,1:nzm) ) + ug -! um_r4(i,j,2:nz) = u(i,j,1:nzm) + ug - - um_r4(i,j,1) = um_r4(i,j,2) - - ! Average v-wind (north-south wind) to scalar points. - vm_r4(i,j,2:nz) = 0.5 * ( v(i,j,1:nzm) + v(i,jp1,1:nzm) ) + vg -! vm_r4(i,j,2:nz) = v(i,j,1:nzm) + vg - - vm_r4(i,j,1) = vm_r4(i,j,2) - end do - end do - - ! Adjust the ghost points to allow for interpolation back on to - ! the u & v grid points -#ifndef CRM - if ( dompi ) then - call task_exchange( um_r4(:,:,2:nz), dimx1_s, dimx2_s, dimy1_s, dimy2_s, & - nzm, 3,3,3,3, ntracers+nmicro_fields+19) - call task_exchange( vm_r4(:,:,2:nz), dimx1_s, dimx2_s, dimy1_s, dimy2_s, & - nzm, 3,3,3,3, ntracers+nmicro_fields+20) - else -#endif /*CRM*/ - call bound_exchange( um_r4(:,:,2:nz), dimx1_s, dimx2_s, dimy1_s, dimy2_s, & - nzm, 3,3,3,3, ntracers+nmicro_fields+19) - call bound_exchange( vm_r4(:,:,2:nz), dimx1_s, dimx2_s, dimy1_s, dimy2_s, & - nzm, 3,3,3,3, ntracers+nmicro_fields+20) -#ifndef CRM - end if -#endif /*CRM*/ - ! Lower Boundary condition on u/v - um_r4(:,:,1) = um_r4(:,:,2) - vm_r4(:,:,1) = vm_r4(:,:,2) - - ! Preserve value of u and v to calculate total change from CLUBB - um_old = um_r4 - vm_old = vm_r4 - - ! Copy the SAM precision values into CLUBB precision arrays - um = real( um_r4, kind=core_rknd ) - vm = real( vm_r4, kind=core_rknd ) - - do i=1, nx, 1 - - do j=1, ny, 1 - - if(.not.l_stats_samgrid) then ! clubb statistics output from clubb - ! Sample from a single column - if ( is_a_sample_node( rank ) .and. i == x_samp_node .and. j == y_samp_node & - .and. lstats_clubb ) then - !+++mhwang remove dt_clubb, as with dt_clubb, CLUBB crashed because - ! the number of samples may not be equal to stats_tout/stats_tsamp - ! in stats_end_timestep in stats_subs.F90 - !---mhwang 2013-02 - ! call stats_begin_timestep( time_current-time_initial+dt_clubb ) - call stats_begin_timestep( time_current-time_initial) - else - l_stats_samp = .false. - end if - else ! clubb statistics output from sam - call stats_begin_timestep( time_current-time_initial) - end if - - ! The 2-D flux arrays are already in the correct units - wprtp_sfc = real( fluxbq(i,j), kind=core_rknd ) ! [m kg/kg s] - wpthlp_sfc = real( fluxbt(i,j), kind=core_rknd ) ! [m K/s] -! Vince Larson set sfc momentum flux constant, as a temporary band-aid. -! 25 Feb 2008. - ! These are set for the purposes of computing sfc_var, but this value is - ! not applied to the value of u and v in SAM. - upwp_sfc = real( fluxbu(i,j), kind=core_rknd ) - vpwp_sfc = real( fluxbv(i,j), kind=core_rknd ) -! End of Vince Larson's change - - ! Set the surface flux of the two scalar types to the tracer flux at the - ! bottom of the domain, and set edsclrm to the tracer - do indx = 1, edsclr_dim, 1 - wpedsclrp_sfc(indx) = real( fluxbtr(i,j,indx), kind=core_rknd ) - edsclrm(2:nz,indx) = real( tracer(i,j,1:nzm,indx), kind=core_rknd ) - edsclrm(1,indx) = real( LIN_EXT( edsclrm(3,indx), edsclrm(2,indx), & - gr%zt(3), gr%zt(2), gr%zt(1) ), kind=core_rknd ) - - edsclrm_forcing(1:nz,indx) = 0.0_core_rknd - end do - - do indx = 1, sclr_dim, 1 - wpsclrp_sfc(indx) = real( fluxbtr(i,j,indx), kind=core_rknd ) - sclrm(2:nz,indx) = real( tracer(i,j,1:nzm,indx), kind=core_rknd ) - sclrm(1,indx) = LIN_EXT( sclrm(3,indx), sclrm(2,indx), & - gr%zt(3), gr%zt(2), gr%zt(1) ) - sclrm_forcing(1:nz,indx) = 0.0_core_rknd - end do - - - ! Check for negative values of water vapor being fed from SAM into CLUBB - if ( clubb_at_least_debug_level( 2 ) ) then - do k=1,nzm - if ( qv(i,j,k) < 0. ) then - write(fstderr,*) 'SAM has fed into CLUBB negative rv at grid point i,j,k =', & - i, j, k - end if - end do - - ! Check for negative values of cloud water being fed from SAM into CLUBB - do k=1,nzm - if ( qcl(i,j,k) < 0. ) then - write(fstderr,*) 'SAM has fed into CLUBB negative qcl at grid point i,j.k =', & - i, j, k - end if - end do - end if ! clubb_at_least_debug_level( 2 ) - - ! Total water. Since the SCM does not account for ice, we sum only the - ! non-precipitating liquid and vapor - - ! Total water is the sum of non-precipitating liquid + vapor - rtm(2:nz) = real( qv(i,j,1:nzm) + qcl(i,j,1:nzm), kind=core_rknd ) - rtm(1) = rtm(2) - - ! Cloud water is total non-precipitating liquid - rcm(i,j,2:nz) = real( qcl(i,j,1:nzm), kind=core_rknd ) - rcm(i,j,1) = 0.0_core_rknd ! No below ground cloud water - - ! Note: t is moist static energy, which is not quite the same as liquid - ! potential temperature. - thlm(2:nz) = t2thetal( t(i,j,1:nzm), gamaz(1:nzm), & - qcl(i,j,1:nzm), qpl(i,j,1:nzm), & - qci(i,j,1:nzm), qpi(i,j,1:nzm), & - prespot(1:nzm) ) - thlm(1) = thlm(2) - - ! The w variable requires no extrapolation - - ! Vince Larson added option for l_advect = .true. . 13 Mar 2008. - ! SAM's subroutine 'subsidence' imposes wsub on t, q, u, and v. - ! SAM advects all means using u, v, w. - ! When implemented in a host model, CLUBB imposes wm_zm/wm_zt on higher-order - ! moments but not means. - ! (l_advect=.true.) advects all higher-order moments using u, v, w. - if ( l_advect ) then - wm_zt(1) = 0._core_rknd - wm_zt(2:nz) = real( wsub(1:nzm), kind=core_rknd ) ! Use this if l_advect = .true. - wm_zm = zt2zm( wm_zt ) - else ! l_advect = .false. - ! Higher-order moments are advected vertically but not horizontally. - ! In principle, this could lead to undesirable accumulation. - wm_zt(1) = 0._core_rknd ! Set ghost point to 0. - wm_zt(2:nz) = real( wsub(1:nzm), kind=core_rknd ) ! wsub is on the t-levels - wm_zm(1:nz) = zt2zm( wm_zt ) ! Interpolate imposed subsidence to m-levels - - ! Resolved vertical velocity is on the momentum levels - wm_zm(1:nz) = wm_zm(1:nz) + real( w(i,j,1:nz), kind=core_rknd ) - ! Interpolate resolved w to t-levels - wm_zt(1:nz) = wm_zt + zm2zt( real( w(i,j,1:nz), kind=core_rknd ) ) - end if - ! End Vince Larson's commenting - - ! Add in pressure perturbation, extrapolate, & convert from mb to Pa. - ! Vince Larson of UWM removed perturbation pressure to avoid - ! negative pressure at domain top in ARM9707. 22 Dec 2007. - ! pr(2:nz) = 100. * ( pres(1:nzm) + p(i,j,1:nzm) ) - ! pr(1) = 100. * LIN_EXT( pres(2)+p(i,j,2), pres(1)+p(i,j,1), & - ! gr%zt(3), gr%zt(2), gr%zt(1) ) - P_in_Pa(2:nz) = 100._core_rknd * real( pres(1:nzm), kind=core_rknd ) - P_in_Pa(1) = LIN_EXT( P_in_Pa(3), P_in_Pa(2), & - gr%zt(3), gr%zt(2), gr%zt(1) ) - - ! End Vince Larson's change. - - ! Sum all forms of ice - rfrzm(2:nz) = real( qpi(i,j,1:nzm) + qci(i,j,1:nzm), kind=core_rknd ) - rfrzm(1) = 0._core_rknd - - ! Call the single column model, CLUBB - call advance_clubb_core & - ( l_implemented, dt_clubb, real( fcory(j), kind=core_rknd ), gr%zm(1), & ! In - zero(:), zero(:), zero(:), zero(:), & ! In - sclrm_forcing, edsclrm_forcing, zero(:), & ! In - zero(:), zero(:), zero(:), & ! In - zero(:), wm_zm(:), wm_zt(:), & ! In - wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! In - wpsclrp_sfc, wpedsclrp_sfc, & ! In - P_in_Pa(:), rho_zm(:), rho_zt(:), exner(:), & ! In - rho_ds_zm(:), rho_ds_zt(:), invrs_rho_ds_zm(:), & ! In - invrs_rho_ds_zt(:), thv_ds_zm(:), thv_ds_zt(:), & ! In - rfrzm(:), radf, & ! In - um(i,j,:), vm(i,j,:), upwp(i,j,:), vpwp(i,j,:), up2(i,j,:), vp2(i,j,:), & ! In/out - thlm(:), rtm(:), wprtp(i,j,:), wpthlp(i,j,:), & ! In/out - wp2(i,j,:), wp3(i,j,:), rtp2(i,j,:), thlp2(i,j,:), rtpthlp(i,j,:), & ! In/out - sclrm, sclrp2(i,j,:,:), sclrprtp(i,j,:,:), sclrpthlp(i,j,:,:), & ! In/out - wpsclrp(i,j,:,:), edsclrm, err_code, & ! In/out - rcm(i,j,:), wprcp(i,j,:), cloud_frac(i,j,:), ice_supersat_frac, & ! Out - rcm_in_layer(i,j,:), cloud_cover(i,j,:), khzmtemp(:), khzttemp(:), qclvartemp(:), pdf_params ) ! Out - khzt(i,j,1:nzm) = real(khzttemp(2:nz)) - khzm(i,j,1:nzm) = real(khzmtemp(1:nz-1)) - qclvarg(i,j,1:nzm) = real(qclvartemp(2:nz)) - -! diagnose the relative variance of in-cloud water -! The relative variance of in-cloud water follows Guo et al., 2013, J. Climate -! Note this formula is different from what is used in CAM5_CLUBB (Bogenschutz et al., 2013, J. Climate) -! the accretion enhancment follows CAM5_CLUBB -! - do k=1, nzm - relvarg(i,j,k) = 8.0 - accre_enhang(i,j,k) = 1.0 - if(rcm(i,j,k+1).gt.0. .and. qclvartemp(k+1).gt.0) then - relvarg(i,j,k) = real(cloud_frac(i,j,k+1)*qclvartemp(k+1) - (1.-cloud_frac(i,j,k+1))*rcm(i,j,k+1)**2) - if(relvarg(i,j,k).gt. (1.0e-3*(rcm(i,j,k+1)**2)) ) then - relvarg(i,j,k) = real(rcm(i,j,k+1)**2)/relvarg(i,j,k) - else - relvarg(i,j,k) = 1000. - end if - relvarg(i,j,k) = min(1.0, max(0.1, relvarg(i,j,k))) - end if - accre_enhang(i,j,k) = 1.+0.65*(1.0/real(relvarg(i,j,k))) - end do - -#ifdef CLUBB_LH - if ( LH_microphys_type /= LH_microphys_disabled ) then - hydromet = 0._core_rknd - hydromet(2:nz,iiNcm) = real( conc(i,j,1:nzm), kind=core_rknd ) - - if ( iirrainm > 0 ) hydromet(2:nz,iirrainm) = micro_field(i,j,:,iirrainm) - if ( iiNrm > 0 ) hydromet(2:nz,iiNrm) = micro_field(i,j,:,iiNrm) - - if ( iirsnowm > 0 ) hydromet(2:nz,iirsnowm) = micro_field(i,j,:,iirsnowm) - if ( iiNsnowm > 0 ) hydromet(2:nz,iiNsnowm) = micro_field(i,j,:,iiNsnowm) - - if ( iiricem > 0 ) hydromet(2:nz,iiricem) = micro_field(i,j,:,iiricem) - if ( iiNim > 0 ) hydromet(2:nz,iiNim) = micro_field(i,j,:,iiNim) - - ! Note: graupel is not a part of X_nl_all_levs. These lines are - ! strictly for the purpose of outputting graupel from a single column - if ( iirgraupelm > 0 ) hydromet(2:nz,iirgraupelm) = micro_field(i,j,:,iirgraupelm) - if ( iiNgraupelm > 0 ) hydromet(2:nz,iiNgraupelm) = micro_field(i,j,:,iiNgraupelm) - - if ( l_lh_vert_overlap ) then - ! Determine 3pt vertically averaged Lscale - do k = 1, nzm, 1 - kp1 = min( k+1, nz ) - km1 = max( k-1, 1 ) - Lscale_vert_avg(k) = vertical_avg & - ( (kp1-km1+1), rho_ds_zt(km1:kp1), & - Lscale(km1:kp1), gr%invrs_dzt(km1:kp1) ) - end do - else - ! If vertical overlap is disabled, this calculation won't be needed - Lscale_vert_avg = -999. - end if - - call LH_subcolumn_generator & - ( LH_iter, d_variables, LH_microphys_calls, LH_sequence_length, nzm, & ! In - thlm(2:nz), pdf_params(2:nz), wm_zt(2:nz), gr%dzt(2:nz), rcm(i,j,2:nz), & ! In - hydromet(2:nz,iiNcm), rtm(2:nz)-rcm(i,j,2:nz), & ! In - hydromet(2:nz,:), xp2_on_xm2_array_cloud, xp2_on_xm2_array_below, & ! In - corr_array_cloud, corr_array_below, Lscale_vert_avg, & ! In - X_nl_all_levs(i,j,:,:,:), X_mixt_comp_all_levs(i,j,:,:), & ! Out - LH_rt(i,j,:,:), LH_thl, LH_sample_point_weights(i,j,:) )! Out - - ! Convert the thetal sample points into moist static energy sample points - LH_t(i,j,:,:) = convert_thl_to_t_LH( LH_thl, gamaz, prespot, X_nl_all_levs(i,j,:,:,:) ) - - ! Increment the iteration count for the purpose of knowing whether to repeat - LH_iter = LH_iter + 1 - - if(.not.l_stats_samgrid) then - if ( is_a_sample_node( rank ) .and. i == x_samp_node .and. j == y_samp_node ) then - call stats_accumulate_hydromet( hydromet, rho_ds_zt ) ! In - end if - else - ! will this be corret???+++mhwang - call stats_accumulate_hydromet( hydromet, rho_ds_zt ) - end if - end if -#endif - if(.not.l_stats_samgrid) then ! clubb stastics output in clubb - ! Sample stats from a single column - if ( is_a_sample_node( rank ) .and. i == x_samp_node .and. j == y_samp_node ) then - call stats_end_timestep( ) - end if - else ! clubb stastics output in sam - call stats_end_timestep_clubb(i, j) - end if - - ! Check if a critical error has occured within the CLUBB model - if ( err_code /= clubb_no_error ) then - call task_rank_to_index( rank, ig, jg ) - write(fstderr,*) "Task #:", rank, err_code - write(fstderr,*) "Single-column model failed at: ", "nx=", i, ";", "ny=", j, ";" - write(fstderr,*) "x global=", i+ig, ";", "y global=", j+jg, ";" - write(fstderr,*) "longitude=", longitude0, "latitude=", latitude0 - call task_abort( ) - end if - - ! If we're not doing a doclubbnoninter run, then we feed the results back - ! into the 3D SAM model arrays. Here we compute the total tendency to - ! allow for subcycling and save compute time. - if ( doclubb ) then - - ! Check for negative values of water vapor - if ( clubb_at_least_debug_level( 2 ) ) then - do k=1,nz - if ( ( rtm(k) - rcm(i,j,k) ) < 0._core_rknd ) then - write(fstderr,*) 'CLUBB has produced negative rvm at grid level k=', k - end if - end do - end if ! clubb_at_least_debug_level( 2 ) - - ! Re-compute vapor for total water and liquid from CLUBB - !qv(i,j,1:nzm) = rtm(2:nz) - rcm(i,j,2:nz) - qv_tndcy(i,j,1:nzm) = & - ( rtm(2:nz) - rcm(i,j,2:nz) - real( qv(i,j,1:nzm), kind=core_rknd ) ) / dt_clubb - - if ( clubb_at_least_debug_level( 2 ) ) then - ! Check for negative values of cloud water - do k=1,nz - if ( rcm(i,j,k) < 0._core_rknd ) then - write(fstderr,*) 'CLUBB has produced negative rcm at grid level k=', k - end if - end do - end if ! clubb_at_least_debug_level( 2 ) - - ! Re-compute qcl based on new rcm - !qcl(i,j,1:nzm) = rcm(i,j,2:nz) - ! Compute tendency of total water due to CLUBB - qc_tndcy(i,j,1:nzm) = ( rcm(i,j,2:nz) - real( qcl(i,j,1:nzm), kind=core_rknd ) ) & - / dt_clubb - - ! Compute moist static energy based on new thetal -! t(i,j,1:nzm) = thetal2t( thlm(2:nz), gamaz(1:nzm), & -! qcl(i,j,1:nzm), qpl(i,j,1:nzm), & -! qci(i,j,1:nzm), qpi(i,j,1:nzm), & -! prespot(1:nzm) ) - - ! Compute tendency of moist static energy due to CLUBB - ! Note that this formula assumes qci/qpl/qpi won't change rapidly in - ! the time between successive clubb calls in order to avoid calling - ! thetal2t on at every SAM timestep -dschanen 27 Oct 08 - t_tndcy(i,j,1:nzm) = & - ( thetal2t( thlm(2:nz), gamaz(1:nzm), rcm(i,j,2:nz), & - qpl(i,j,1:nzm), qci(i,j,1:nzm), qpi(i,j,1:nzm), prespot(1:nzm) ) & - - real( t(i,j,1:nzm), kind=core_rknd ) ) / dt_clubb - - do indx = 1, edsclr_dim - tracer_tndcy(i,j,1:nzm,indx) = & - ( edsclrm(2:nz,indx) - real( tracer(i,j,1:nzm,indx), kind=core_rknd ) ) & - / dt_clubb - end do - - do indx = 1, sclr_dim - tracer_tndcy(i,j,1:nzm,indx) = & - ( sclrm(2:nz,indx) - real( tracer(i,j,1:nzm,indx), kind=core_rknd ) ) / dt_clubb - end do - - end if ! doclubb - - end do ! j - - end do ! i - - ! De-allocate temporary arrays. This is just in case the compiler isn't - ! 100% Fortran 95 compliant and doesn't de-allocate this memory when it - ! leaves the scope of advance_clubb_sgs - deallocate( wpsclrp_sfc, sclrm ) - deallocate( wpedsclrp_sfc, edsclrm ) - deallocate( pdf_params ) - - ! Copy back the value from the CLUBB precision um and vm - um_r4 = real( um ) - vm_r4 = real( vm ) - - if ( doclubb ) then - - ! Adjust the ghost points to allow for interpolation back onto the u & v grid -#ifndef CRM - if ( dompi ) then - call task_exchange( um_r4(:,:,2:nz), dimx1_s, dimx2_s, dimy1_s, dimy2_s, & - nzm, 3,3,3,3, ntracers+nmicro_fields+19) - call task_exchange( vm_r4(:,:,2:nz), dimx1_s, dimx2_s, dimy1_s, dimy2_s, & - nzm, 3,3,3,3, ntracers+nmicro_fields+20) - else -#endif /*CRM*/ - call bound_exchange( um_r4(:,:,2:nz), dimx1_s, dimx2_s, dimy1_s, dimy2_s, & - nzm, 3,3,3,3, ntracers+nmicro_fields+19) - call bound_exchange( vm_r4(:,:,2:nz), dimx1_s, dimx2_s, dimy1_s, dimy2_s, & - nzm, 3,3,3,3, ntracers+nmicro_fields+20) -#ifndef CRM - end if -#endif - - ! Compute the total change in u due to the CLUBB part of the code - um_change = real( um_r4 - um_old, kind=tndcy_precision ) / dt_clubb - vm_change = real( vm_r4 - vm_old, kind=tndcy_precision ) / dt_clubb - - ! Average the contributions of CLUBB to the wind back on to the u and v grid - ! This has shown to make the model unstable at fine horizontal resolution. - ! To interpolate across subdomain boundaries requires that we - ! transfer information using MPI (via task_exchange). - do i=1, nx, 1 - do j=1, ny, 1 - jm1 = max( dimy1_s, j-1 ) ! For the 2D case vm wind - - ! The horiztontal grid in SAM is always evenly spaced, so we just use - ! 0.5 *( x(n-1)+x(n) ) to interpolate back to the u,v point on the Arakawa C grid - u_tndcy(i,j,1:nzm) = & - 0.4_tndcy_precision * & ! This is a made up coefficient to reduce numerical instability - 0.5_tndcy_precision * & - real( um_change(i,j,2:nz) + um_change(i-1,j,2:nz), kind=tndcy_precision ) - v_tndcy(i,j,1:nzm) = & - 0.4_tndcy_precision * & ! This is a made up coefficient to reduce numerical instability - 0.5_tndcy_precision * & - real( vm_change(i,j,2:nz) + vm_change(i,jm1,2:nz), kind=tndcy_precision ) - - end do ! j - - end do ! i - - end if ! doclubb - - -! Vince Larson attempted to advect higher-order moments horizontally. -! 26 Feb 2008. - -! Horizontal advection of higher-order moments. - -! The following method has the drawback of requiring two interpolations, -! which unnecesarily smooths the fields in the vertical. -! In preparation for advection, interpolate to thermodynamic (scalar) vertical gridpoints. -! (wp3 is already on the thermodynamic gridpoints.) - - -!print*, 'Before advection, wp2(nx,ny,:) =', wp2(nx,ny,:) -! For now we default to not doing this, because the interpolation seems to cause -! and artificial rise in fields such as moisture at a coarse model resolution. -! -dschanen 29 Apr 2008 - if ( l_advect ) then - - do i=1, nx, 1 - do j=1, ny, 1 - - wp2_zt(i,j,:) = real( zm2zt( wp2(i,j,:) ) ) - up2_zt(i,j,:) = real( zm2zt( up2(i,j,:) ) ) - vp2_zt(i,j,:) = real( zm2zt( vp2(i,j,:) ) ) - rtp2_zt(i,j,:) = real( zm2zt( rtp2(i,j,:) ) ) - thlp2_zt(i,j,:) = real( zm2zt( thlp2(i,j,:) ) ) - rtpthlp_zt(i,j,:) = real( zm2zt( rtpthlp(i,j,:) ) ) - wprtp_zt(i,j,:) = real( zm2zt( wprtp(i,j,:) ) ) - wpthlp_zt(i,j,:) = real( zm2zt( wpthlp(i,j,:) ) ) - - end do ! j - end do ! i - -#ifndef CRM - if ( dompi ) then - - call task_exchange( wp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+10 ) - call task_exchange( rtp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+11 ) - call task_exchange( thlp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+12 ) - call task_exchange( rtpthlp_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+13 ) - call task_exchange( wprtp_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+14 ) - call task_exchange( wpthlp_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+15 ) - call task_exchange( wp3(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+16 ) - call task_exchange( up2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+17 ) - call task_exchange( vp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+18 ) - else -#endif /*CRM*/ - - call bound_exchange( wp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+10 ) - call bound_exchange( rtp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+11 ) - call bound_exchange( thlp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+12 ) - call bound_exchange( rtpthlp_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+13 ) - call bound_exchange( wprtp_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+14 ) - call bound_exchange( wpthlp_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+15 ) - call bound_exchange( wp3(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+16 ) - call bound_exchange( up2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+17 ) - call bound_exchange( vp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dimx1_s, dimx2_s, dimy1_s, dimy2_s, nzm, 3,3,3,3, & - ntracers+nmicro_fields+18 ) - -#ifndef CRM - end if -#endif - - ! Now call the standard SAM advection subroutine for scalars - call advect_scalar( wp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dum(1:nz), dum(1:nz), dum(1:nzm), & - dum(1:nzm), dum(1:nzm), .false. ) - - call advect_scalar( wp3(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dum(1:nz), dum(1:nz), dum(1:nzm), & - dum(1:nzm), dum(1:nzm), .false. ) - - call advect_scalar( rtp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dum(1:nz), dum(1:nz), dum(1:nzm), & - dum(1:nzm), dum(1:nzm), .false. ) - - call advect_scalar( thlp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dum(1:nz), dum(1:nz), dum(1:nzm), & - dum(1:nzm), dum(1:nzm), .false. ) - - call advect_scalar( rtpthlp_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dum(1:nz), dum(1:nz), dum(1:nzm), & - dum(1:nzm), dum(1:nzm), .false. ) - - call advect_scalar( wprtp_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dum(1:nz), dum(1:nz), dum(1:nzm), & - dum(1:nzm), dum(1:nzm), .false. ) - - call advect_scalar( wpthlp_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dum(1:nz), dum(1:nz), dum(1:nzm), & - dum(1:nzm), dum(1:nzm), .false. ) - - call advect_scalar( up2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dum(1:nz), dum(1:nz), dum(1:nzm), & - dum(1:nzm), dum(1:nzm), .false. ) - - call advect_scalar( vp2_zt(dimx1_s:dimx2_s,dimy1_s:dimy2_s,2:nz), & - dum(1:nz), dum(1:nz), dum(1:nzm), & - dum(1:nzm), dum(1:nzm), .false. ) - -!print*, 'After advect, wp2_zt(dimx2_s,dimy2_s,:) =', wp2_zt(dimx2_s,dimy2_s,:) -! -!do i=dimx1_s, dimx2_s, 1 -! do j=dimy1_s, dimy2_s, 1 -! if ( any ( rtp2_zt(i,j,:) < 0.0 ) ) then -! print*, 'After advect, rtp2_zt at ', i, j, " = ", rtp2_zt(i,j,:) -! end if -! end do ! i -!end do ! j -! Now interpolate back to momentum gridpoints. -! (wp3 is already on the thermodynamic gridpoints.) -! do i=dimx1_s, dimx2_s, 1 -! do j=dimy1_s, dimy2_s, 1 - do i=1, nx, 1 - do j=1, ny, 1 - - wp2(i,j,:) = zt2zm( real( wp2_zt(i,j,:), kind=core_rknd ) ) - up2(i,j,:) = zt2zm( real( up2_zt(i,j,:), kind=core_rknd ) ) - vp2(i,j,:) = zt2zm( real( vp2_zt(i,j,:), kind=core_rknd ) ) - rtp2(i,j,:) = zt2zm( real( rtp2_zt(i,j,:), kind=core_rknd ) ) - thlp2(i,j,:) = zt2zm( real( thlp2_zt(i,j,:), kind=core_rknd ) ) - rtpthlp(i,j,:) = zt2zm( real( rtpthlp_zt(i,j,:), kind=core_rknd ) ) - wprtp(i,j,:) = zt2zm( real( wprtp_zt(i,j,:), kind=core_rknd ) ) - wpthlp(i,j,:) = zt2zm( real( wpthlp_zt(i,j,:), kind=core_rknd ) ) - - end do ! j - end do ! i - - ! Clip variances where the top point is negative - where ( wp2(:,:,nz) < 0._core_rknd ) wp2(:,:,nz) = 0._core_rknd - where ( up2(:,:,nz) < 0._core_rknd ) up2(:,:,nz) = 0._core_rknd - where ( vp2(:,:,nz) < 0._core_rknd ) vp2(:,:,nz) = 0._core_rknd - where ( rtp2(:,:,nz) < 0._core_rknd ) rtp2(:,:,nz) = 0._core_rknd - where ( thlp2(:,:,nz) < 0._core_rknd ) thlp2(:,:,nz) = 0._core_rknd - - ! Clip variances where the bottom point is negative - where ( wp2(:,:,1) < 0._core_rknd ) wp2(:,:,1) = 0._core_rknd - where ( up2(:,:,1) < 0._core_rknd ) up2(:,:,1) = 0._core_rknd - where ( vp2(:,:,1) < 0._core_rknd ) vp2(:,:,1) = 0._core_rknd - where ( rtp2(:,:,1) < 0._core_rknd ) rtp2(:,:,1) = 0._core_rknd - where ( thlp2(:,:,1) < 0._core_rknd ) thlp2(:,:,1) = 0._core_rknd - - -!do i=1, nx, 1 -! do j=1, ny, 1 -! if ( any ( rtp2(i,j,:) < 0.0 ) ) then -! print*, 'After interp, rtp2 at ', i, j, " = ", rtp2(i,j,:) -! end if -! end do ! i -!end do ! j -! -!print*, 'After interp back, wp2(nx,ny,:) =', wp2(nx,ny,:) -!! End of Vince Larson's changes. - end if ! ladvect - -#ifndef CRM - call t_stopf('advance_clubb') ! For timing -#endif - - return - end subroutine advance_clubb_sgs - -!------------------------------------------------------------------------------- - subroutine apply_clubb_sgs_tndcy( dt, t, qv, qcl, dudt, dvdt ) - - use crmx_grid, only: & - nx, nxp1, ny, nyp1, dimx1_s, dimx2_s, dimy1_s, dimy2_s, nz, nzm, na, & - rank - - use crmx_domain, only: & - ntracers - -#ifndef CRM - use tracers, only: & -#else - use crmx_crmtracers, only: & -#endif - tracer - - use crmx_clubbvars, only: & - u_tndcy, & ! CLUBB contribution to the x wind - v_tndcy, & ! CLUBB contribution to the y wind - t_tndcy, & ! CLUBB contribution to moist static energy - qc_tndcy,& ! CLUBB contribution to liquid water mixing ratio - qv_tndcy ! CLUBB contribution to vapor water mixing ratio - - use crmx_clubbvars, only: & - tracer_tndcy - - use crmx_clubbvars, only: & - sclr_dim, & ! Constant(s) - edsclr_dim - - use crmx_clubbvars, only: & - rho_ds_zt, & ! Variable(s) - rho_ds_zm - - use crmx_error_code, only: clubb_at_least_debug_level - - use crmx_fill_holes, only: fill_holes_driver - - implicit none - - intrinsic :: any - - ! In variables - real(kind=time_precision), intent(in) :: & - dt ! Timestep [s] - - ! In/Out variables - real, intent(inout), dimension(dimx1_s:dimx2_s,dimy1_s:dimy2_s,nzm) :: & - t ! Moist static energy [K] - - real, intent(inout), dimension(nx,ny,nzm) :: & - qv, & ! Water vapor mixing ratio [kg/kg] - qcl ! Liquid water mixing ratio (condensate) [kg/kg] - - real, intent(inout), dimension(nxp1,ny,nzm,3) :: & - dudt ! u wind tendency [m/s^2] - - real, intent(inout), dimension(nx,nyp1,nzm,3) :: & - dvdt ! v wind tendency [m/s^2] - - ! Local Variables - real(kind=core_rknd), dimension(nz) :: tmpqv, tmpqcl - - real(kind=core_rknd) :: threshold ! Threshold on clipping [units vary] - - integer :: i, j, ig, jg - - ! --- Begin Code --- - -#ifndef CRM - call t_startf('apply_clubb_sgs_tndcy') ! For timing -#endif - - ! Since dudt/dvdt are already time tendencies, we just add the contribution - ! to the existing SAM contribution - dudt(1:nx,1:ny,1:nzm,na) = dudt(1:nx,1:ny,1:nzm,na) + real( u_tndcy(1:nx,1:ny,1:nzm) ) - dvdt(1:nx,1:ny,1:nzm,na) = dvdt(1:nx,1:ny,1:nzm,na) + real( v_tndcy(1:nx,1:ny,1:nzm) ) - - tmpqv = 0.0_core_rknd - tmpqcl = 0.0_core_rknd - - ! Add clubb tendency to qv, qc, t, and tracers - do i = 1, nx, 1 - do j = 1, ny, 1 - - t(i,j,1:nzm) = t(i,j,1:nzm) + real( dt*t_tndcy(i,j,1:nzm) ) - - tmpqv(2:nz) = real( qv(i,j,1:nzm), kind=core_rknd ) + dt*qv_tndcy(i,j,1:nzm) - tmpqcl(2:nz) = real( qcl(i,j,1:nzm), kind=core_rknd ) + dt*qc_tndcy(i,j,1:nzm) - - if ( edsclr_dim > 0 .or. sclr_dim > 0 ) then - tracer(i,j,1:nzm,1:ntracers) = tracer(i,j,1:nzm,1:ntracers) & - + real( dt*tracer_tndcy(i,j,1:nzm,1:ntracers) ) - end if - - ! Apply hole-filling scheme to qv as needed - threshold = 0._core_rknd - if ( any( tmpqv(2:nz) < threshold ) ) then - - ! CLUBB's tendency in this column will produce a negative vapor water, - ! so we apply hole-filling - if ( clubb_at_least_debug_level( 1 ) ) then - call task_rank_to_index( rank, ig, jg ) - write(0,*) "Task #:", rank - write(0,*) "Applying hole-filling scheme to vapor water mixing ratio at:", & - "nx=", i, ";", "ny=", j, ";" - write(0,*) "x global=", i+ig, ";", "y global=", j+jg, ";" - end if - - call fill_holes_driver( 2, threshold, "zt", rho_ds_zt, rho_ds_zm, tmpqv ) - - end if - - ! Update qv - qv(i,j,1:nzm) = real( tmpqv(2:nz) ) - - threshold = 0._core_rknd - ! Apply hole-filling scheme to qcl as needed - if ( any( tmpqcl(2:nz) < threshold ) ) then - - ! CLUBB's tendency in this column will produce a negative cloud water, - ! so we apply hole-filling - if ( clubb_at_least_debug_level( 1 ) ) then - call task_rank_to_index( rank, ig, jg ) - write(0,*) "Task #:", rank - write(0,*) "Applying hole-filling scheme to cloud water mixing ratio at:", & - "nx=", i, ";", "ny=", j, ";" - write(0,*) "x global=", i+ig, ";", "y global=", j+jg, ";" - end if - - call fill_holes_driver( 2, threshold, "zt", rho_ds_zt, rho_ds_zm, tmpqcl ) - - end if - - ! Update qcl - qcl(i,j,1:nzm) = real( tmpqcl(2:nz) ) - - end do ! j = 1, ny - end do ! i = 1, nx - -#ifndef CRM - call t_stopf('apply_clubb_sgs_tndcy') ! For timing -#endif - - return - end subroutine apply_clubb_sgs_tndcy - -!------------------------------------------------------------------------------- - subroutine apply_clubb_sgs_tndcy_mom( dudt, dvdt ) - - use crmx_grid, only: & - nx, nxp1, ny, nyp1, dimx1_s, dimx2_s, dimy1_s, dimy2_s, nz, nzm, na, & - rank - - use crmx_clubbvars, only: & - u_tndcy, & ! CLUBB contribution to the x wind - v_tndcy ! CLUBB contribution to the y wind - - implicit none - - intrinsic :: any - - ! In variables - real, intent(inout), dimension(nxp1,ny,nzm,3) :: & - dudt ! u wind tendency [m/s^2] - - real, intent(inout), dimension(nx,nyp1,nzm,3) :: & - dvdt ! v wind tendency [m/s^2] - - ! --- Begin Code --- - -#ifndef CRM - call t_startf('apply_clubb_sgs_tndcy_mom') ! For timing -#endif - - ! Since dudt/dvdt are already time tendencies, we just add the contribution - ! to the existing SAM contribution - dudt(1:nx,1:ny,1:nzm,na) = dudt(1:nx,1:ny,1:nzm,na) + real( u_tndcy(1:nx,1:ny,1:nzm) ) - dvdt(1:nx,1:ny,1:nzm,na) = dvdt(1:nx,1:ny,1:nzm,na) + real( v_tndcy(1:nx,1:ny,1:nzm) ) - -#ifndef CRM - call t_stopf('apply_clubb_sgs_tndcy_mom') ! For timing -#endif - - return - end subroutine apply_clubb_sgs_tndcy_mom - -!------------------------------------------------------------------------------- - subroutine apply_clubb_sgs_tndcy_scalars( dt, t, qv, qcl) - - use crmx_grid, only: & - nx, nxp1, ny, nyp1, dimx1_s, dimx2_s, dimy1_s, dimy2_s, nz, nzm, na, & - rank, adz, dz - - use crmx_params, only: doclubb_sfc_fluxes - - use crmx_vars, only: rho - - use crmx_domain, only: & - ntracers - -#ifndef CRM - use tracers, only: & -#else - use crmx_crmtracers, only: & -#endif - tracer - - use crmx_clubbvars, only: & - t_tndcy, & ! CLUBB contribution to moist static energy - qc_tndcy,& ! CLUBB contribution to liquid water mixing ratio - qv_tndcy ! CLUBB contribution to vapor water mixing ratio - - use crmx_clubbvars, only: & - tracer_tndcy - - use crmx_clubbvars, only: & - sclr_dim, & ! Constant(s) - edsclr_dim - - use crmx_clubbvars, only: & - rho_ds_zt, & ! Variable(s) - rho_ds_zm - - use crmx_error_code, only: clubb_at_least_debug_level - - use crmx_fill_holes, only: fill_holes_driver - - implicit none - - intrinsic :: any - - ! In variables - real(kind=time_precision), intent(in) :: & - dt ! Timestep [s] - - ! In/Out variables - real, intent(inout), dimension(dimx1_s:dimx2_s,dimy1_s:dimy2_s,nzm) :: & - t ! Moist static energy [K] - - real, intent(inout), dimension(nx,ny,nzm) :: & - qv, & ! Water vapor mixing ratio [kg/kg] - qcl ! Liquid water mixing ratio (condensate) [kg/kg] - - ! Local Variables - real(kind=core_rknd), dimension(nz) :: tmpqv, tmpqcl - - real(kind=core_rknd) :: threshold ! Threshold on clipping [units vary] - - real(kind=core_rknd), dimension(2) :: t_total - - real(kind=core_rknd) :: dt_total - - integer :: i, j, ig, jg, k - - ! --- Begin Code --- - -#ifndef CRM - call t_startf('apply_clubb_sgs_tndcy_scalar') ! For timing -#endif - - tmpqv = 0.0_core_rknd - tmpqcl = 0.0_core_rknd - - ! Add clubb tendency to qv, qc, t, and tracers - do i = 1, nx, 1 - do j = 1, ny, 1 - -! add energy conservation check and fix for CLUBB -! Minghuai Wang, 2012-06 - t_total = 0.0_core_rknd - dt_total = 0.0_core_rknd - t_total(1) = real(sum(t(i,j,1:nzm)*rho(1:nzm)*adz(1:nzm)*dz), kind=core_rknd) - do k=1, nzm -! t_total(1) = t_total(1) +real(t(i,j,k)*rho(k)*adz(k)*dz, kind=core_rknd) - t(i,j,k) = t(i,j,k) + real( dt*t_tndcy(i,j,k) ) -! t_total(2) = t_total(2) +real(t(i,j,k)*rho(k)*adz(k)*dz, kind=core_rknd) -! dt_total = dt_total + real( dt*t_tndcy(i,j,k)*adz(k)*dz, kind=core_rknd) - end do - t_total(2) = real(sum(t(i,j,1:nzm)*rho(1:nzm)*adz(1:nzm)*dz), kind=core_rknd) - dt_total = real(sum(dt*t_tndcy(i,j,1:nzm)*rho(1:nzm)*adz(1:nzm)*dz), kind=core_rknd) - if(abs(t_total(2)-t_total(1))/t_total(1).gt.1.0e-6) then -! write(0, *) 'energy conervation issue in clubb', i,j, & -! abs(t_total(2)-t_total(1))/t_total(1), t_total(1), dt_total - end if - if(.not.doclubb_sfc_fluxes) then - t(i,j,1:nzm) = t(i,j,1:nzm) * real(t_total(1)/t_total(2)) - else - write(0, *) 'need add surface fluxes in energy conservation fix' - stop - end if - - tmpqv(2:nz) = real( qv(i,j,1:nzm), kind=core_rknd ) + dt*qv_tndcy(i,j,1:nzm) - tmpqcl(2:nz) = real( qcl(i,j,1:nzm), kind=core_rknd ) + dt*qc_tndcy(i,j,1:nzm) - - if ( edsclr_dim > 0 .or. sclr_dim > 0 ) then - tracer(i,j,1:nzm,1:ntracers) = tracer(i,j,1:nzm,1:ntracers) & - + real( dt*tracer_tndcy(i,j,1:nzm,1:ntracers) ) - end if - - ! Apply hole-filling scheme to qv as needed - threshold = 0._core_rknd - if ( any( tmpqv(2:nz) < threshold ) ) then - - ! CLUBB's tendency in this column will produce a negative vapor water, - ! so we apply hole-filling - if ( clubb_at_least_debug_level( 1 ) ) then - call task_rank_to_index( rank, ig, jg ) - write(0,*) "Task #:", rank - write(0,*) "Applying hole-filling scheme to vapor water mixing ratio at:", & - "nx=", i, ";", "ny=", j, ";" - write(0,*) "x global=", i+ig, ";", "y global=", j+jg, ";" - end if - - call fill_holes_driver( 2, threshold, "zt", rho_ds_zt, rho_ds_zm, tmpqv ) - - end if - - ! Update qv - qv(i,j,1:nzm) = real( tmpqv(2:nz) ) - - threshold = 0._core_rknd - ! Apply hole-filling scheme to qcl as needed - if ( any( tmpqcl(2:nz) < threshold ) ) then - - ! CLUBB's tendency in this column will produce a negative cloud water, - ! so we apply hole-filling - if ( clubb_at_least_debug_level( 1 ) ) then - call task_rank_to_index( rank, ig, jg ) - write(0,*) "Task #:", rank - write(0,*) "Applying hole-filling scheme to cloud water mixing ratio at:", & - "nx=", i, ";", "ny=", j, ";" - write(0,*) "x global=", i+ig, ";", "y global=", j+jg, ";" - end if - - call fill_holes_driver( 2, threshold, "zt", rho_ds_zt, rho_ds_zm, tmpqcl ) - - end if - - ! Update qcl - qcl(i,j,1:nzm) = real( tmpqcl(2:nz) ) - - end do ! j = 1, ny - end do ! i = 1, nx - -#ifndef CRM - call t_stopf('apply_clubb_sgs_tndcy_scalar') ! For timing -#endif - - return - end subroutine apply_clubb_sgs_tndcy_scalars - -!------------------------------------------------------------------------------- - subroutine clubb_sgs_cleanup( ) -! Description: -! De-allocate memory and exit. -!------------------------------------------------------------------------------- - use crmx_grid, only: rank - - use crmx_stats_subs, only: stats_finalize - - implicit none - - !----- Begin Code ----- - - call cleanup_clubb_core( .true. ) - - if(.not.l_stats_samgrid) then - if ( is_a_sample_node( rank ) ) then - call stats_finalize( ) - end if - else ! when l_stats_samgrid is .true, does not call stats_finalize - ! as some of variables are allocated yet in this case. - end if - - return - end subroutine clubb_sgs_cleanup - -!------------------------------------------------------------------------------- - elemental function t2thetal( t, gamaz, qcl, qpl, qci, qpi, prespot ) & - result( thl ) -! Description: -! Convert moist static energy into the liquid potential temperature -! used in CLUBB. -!------------------------------------------------------------------------------- - use crmx_params, only: & - fac_cond, & ! Variables - fac_sub - - implicit none - - ! Input variables - real, intent(in) :: & - t, & ! Moist static energy [K] - gamaz, & ! grav/Cp*z [m] - qcl, & ! Cloud water mixing ration [kg/kg] - qpl, & ! Rain water mixing ratio (liquid) [kg/kg] - qci, & ! Cloud water mixing ratio (ice) [kg/kg] - qpi, & ! Snow+Graupel mixing ratio [kg/kg] - prespot ! Exner^-1 [-] - - ! Result - real(kind=core_rknd) :: thl ! Liquid pot. temperature [K] - - real :: tabs ! Absolute temp. [K] - - !----- Begin Code ----- - - ! Compute absolute temperature from t - ! Formula comes from module diagnose. - tabs = t - gamaz + fac_cond * ( qcl + qpl ) + fac_sub * ( qci + qpi ) - - ! Compute thetal (don't include ice because CLUBB doesn't) - thl = real( prespot * ( tabs - fac_cond * qcl ), kind=core_rknd ) - - return - end function t2thetal - -!------------------------------------------------------------------------------- - elemental function thetal2t( thl, gamaz, qcl, qpl, qci, qpi, prespot ) & - result( t ) - -! Description: -! Convert liquid potential temperature into moist static energy. -! References: -! None -!------------------------------------------------------------------------------- - use crmx_params, only: & - fac_cond, & ! Variables - fac_sub - - implicit none - - ! Input Variables - real(kind=core_rknd), intent(in) :: & - thl, & ! Liquid potential temperature [K] - qcl ! Cloud water mixing ration [kg/kg] - - real, intent(in) :: & - gamaz, & ! grav/Cp*z [m] - qpl, & ! Rain water mixing ratio (liquid) [kg/kg] - qci, & ! Cloud water mixing ratio (ice) [kg/kg] - qpi, & ! Snow+Graupel mixing ratio [kg/kg] - prespot ! Exner^-1 [-] - - ! Result - real(kind=core_rknd) :: t ! Moist static energy [K] - - real(kind=core_rknd) :: & - tabs, & ! Absolute temp. [K] - theta ! Pot. temp. [K] - - !----- Begin Code ----- - - ! Compute absolute temperature from thl - ! Use fac_cond since CLUBB's thl does not account for ice - theta = thl + real( prespot * fac_cond, kind=core_rknd ) * qcl - tabs = theta / real( prespot, kind=core_rknd ) - ! Compute moist static energy - ! Formula comes from module diagnose - t = tabs + real( gamaz, kind=core_rknd ) & - - real( fac_cond, kind=core_rknd ) * ( qcl + real( qpl, kind=core_rknd ) ) & - - real( fac_sub * ( qci + qpi ), kind=core_rknd ) - - return - end function thetal2t - -!------------------------------------------------------------------------------- - FUNCTION LIN_EXT( var_high, var_low, height_high, height_low, height_ext ) - -! Author: Brian M. Griffin, UW Milwaukee - -! References: None - -! Description: -! This function computes a linear extension of the value of variable. -! Given two known values of a variable at two height values, the value -! of that variable at a height outside of those two height levels -! (rather than a height between those two height levels) is computed. -! -! Here is a diagram: -! -! -------------------------------- Height to be extended to; linear extension -! -! ################################ Height high, know variable value -! -! -! -! ################################ Height low, know variable value -! -! -! -! -------------------------------- Height to be extended to; linear extension -! -! -! FORMULA: -! -! variable(@ Height extension) = -! -! [ (variable(@ Height high) - variable(@ Height low)) / (Height high - Height low) ] -! * (Height extension - Height high) + variable(@ Height high) -!------------------------------------------------------------------------------- - - IMPLICIT NONE - - ! Input Variables - REAL(kind=core_rknd), INTENT(IN):: var_high - REAL(kind=core_rknd), INTENT(IN):: var_low - REAL(kind=core_rknd), INTENT(IN):: height_high - REAL(kind=core_rknd), INTENT(IN):: height_low - REAL(kind=core_rknd), INTENT(IN):: height_ext - - ! Output Variable - REAL(kind=core_rknd):: lin_ext - - !----- Begin Code ----- - - lin_ext = ( var_high - var_low ) / ( height_high - height_low ) & - * ( height_ext - height_high ) + var_high - - RETURN - END FUNCTION LIN_EXT - - !----------------------------------------------------------------------------- - logical function is_a_sample_node( rank ) - - ! Description: - ! Determine if we're output single-columns stats from this node. - ! References: - ! None - !----------------------------------------------------------------------------- - - implicit none - - ! External - intrinsic :: any, spread, size - - ! Input Variable - integer, intent(in) :: rank - - integer :: iter - - ! ---- Begin Code ---- - - ! Initialize - is_a_sample_node = .false. - - ! Determine if we're sampling a column of stats from this node - do iter = 1, size( sample_nodes ) - if ( sample_nodes(iter) == rank ) then - is_a_sample_node = .true. - exit - end if - end do - - return - end function is_a_sample_node - !----------------------------------------------------------------------------- - subroutine get_sample_points( rank, i, j ) - - ! Description: - ! Output the local x and y location to be output for this particular node. - ! - ! References: - ! None - !----------------------------------------------------------------------------- - - implicit none - - ! Input Variable - integer, intent(in) :: rank - - ! Output Variables - integer, intent(out) :: i, j - - integer :: iter - - ! ---- Begin Code ---- - - i = -1 - j = -1 - do iter = 1, size( sample_nodes ) - if ( sample_nodes(iter) == rank ) then - i = x_samp(iter); j = y_samp(iter) - exit - end if - end do - - return - end subroutine get_sample_points - -#ifdef CLUBB_LH - pure function convert_thl_to_t_LH( LH_thl, gamaz, prespot, X_nl_all_levs ) & - result( LH_t ) - - use crmx_grid, only: nzm - - use crmx_clubb_precision, only: & - dp, & - core_rknd - - use crmx_parameters_microphys, only: & - LH_microphys_calls - - use crmx_corr_matrix_module, only: & - iiLH_s_mellor, & - iiLH_rrain, & - iiLH_rsnow, & - iiLH_rice - - use latin_hypercube_arrays, only: & - d_variables - - implicit none - - ! Input Variables - real(kind=core_rknd), dimension(nzm,LH_microphys_calls), intent(in) :: & - LH_thl ! Sample of thetal [K] - - real, dimension(nzm), intent(in) :: & - gamaz, & ! grav/Cp*z [m] - prespot ! 1/exner [-] - - real(kind=dp), dimension(nzm,LH_microphys_calls,d_variables), intent(in) :: & - X_nl_all_levs ! All lognormal variates [units vary] - - ! Output Variables - real(kind=core_rknd), dimension(nzm,LH_microphys_calls) :: & - LH_t ! Latin hypercube samples of moist static energy [K] - - ! Local variables - real(kind=core_rknd), dimension(nzm,LH_microphys_calls) :: & - qcl ! Liquid water [kg/kg] - - real, dimension(nzm,LH_microphys_calls) :: & - qpl, qci, qpi ! Rain, ice, and snow mixing ratio [kg/kg] - - integer :: indx - - ! ---- Begin Code ---- - qcl = 0._core_rknd - qpl = 0._core_rknd - qci = 0._core_rknd - qpi = 0._core_rknd - - if ( iiLH_s_mellor > 0 ) qcl = max( X_nl_all_levs(:,:,iiLH_s_mellor), 0._dp ) - if ( iiLH_rrain > 0 ) qpl = X_nl_all_levs(:,:,iiLH_rrain) - if ( iiLH_rice > 0 ) qci = X_nl_all_levs(:,:,iiLH_rice) - - ! Note: this assumes no graupel samples - if ( iiLH_rsnow > 0 ) qci = X_nl_all_levs(:,:,iiLH_rsnow) - - forall ( indx=1:LH_microphys_calls ) - LH_t(:,indx) = thetal2t( LH_thl(:,indx), gamaz, qcl(:,indx), qpl(:,indx), & - qci(:,indx), qpi(:,indx), prespot ) - end forall - - return - end function convert_thl_to_t_LH -#endif /*CLUBB_LH*/ - -real(8) function total_energy(t) - - use crmx_grid, only: & - nx, nxp1, ny, nyp1, dimx1_s, dimx2_s, dimy1_s, dimy2_s, nz, nzm, na, & - adz, dz - use crmx_vars, only: rho - use crmx_params, only: cp - - implicit none - - real, intent(inout), dimension(dimx1_s:dimx2_s,dimy1_s:dimy2_s,nzm) :: & - t ! Moist static energy [K] - - real(8) tmp - integer i,j,k,m - - total_energy = 0. - do k=1,nzm - tmp = 0. - do j=1,ny - do i=1,nx - tmp = tmp + t(i,j,k) - end do - end do - total_energy = total_energy + tmp*adz(k)*dz*rho(k) * cp - end do - -end function total_energy - -#endif /*CLUBB_CRM*/ -end module crmx_clubb_sgs diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_clubb_silhs_vars.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_clubb_silhs_vars.F90 deleted file mode 100644 index e21de0e567..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_clubb_silhs_vars.F90 +++ /dev/null @@ -1,60 +0,0 @@ -module crmx_clubb_silhs_vars -#ifdef CLUBB_LH - - use crmx_grid, only: & - nx, & - ny,& - nz,& - nzm,& - dimx1_s,& - dimx2_s,& - dimy1_s,& - dimy2_s - - use crmx_microphysics, only: & - nmicro_fields - - use crmx_clubb_precision, only: & - core_rknd, & ! CLUBB core real kind - dp - - implicit none - - private ! Default scope - - ! Allocatable variables that can change in dimension at runtime - real(kind=core_rknd), public, allocatable, dimension(:,:,:,:) :: & - LH_rt, & ! Latin hypercube samples of total water [kg/kg] - LH_t ! Latin hypercube samples of moist static energy [K] - - real(kind=dp), public, allocatable, dimension(:,:,:,:,:) :: & - X_nl_all_levs ! Lognormally distributed hydrometeors [units vary] - - integer, public, allocatable, dimension(:,:,:,:) :: & - X_mixt_comp_all_levs ! Which mixture component the sample is in - - real(kind=core_rknd), public, allocatable, dimension(:,:,:) :: & - LH_sample_point_weights ! Weights for cloud weighted sampling - - ! Static variables - real(kind=core_rknd), public, dimension(nx,ny,nzm) :: & - LH_t_sum_tndcy, & ! Sum of all t LH tendencies [K/s] - LH_t_avg_tndcy, & ! Average of all t LH tendencies [K/s] - LH_qn_sum_tndcy, & ! Sum of all qn LH tendencies [kg/kg/s] - LH_qn_avg_tndcy ! Average of all qn LH tendencies [kg/kg/s] - - real, public, dimension(nx,ny,nzm) :: & - t_prior, & ! Saved value of t [K] - qn_prior ! Saved value of liquid water [kg/kg] - - real, public, dimension(nx,ny,nz) :: & - w_prior ! Saved value of w [m/s] - - real, public, allocatable, dimension(:,:,:,:) :: & - micro_field_prior ! Saved values of the micro_fields [units vary] - - real(kind=core_rknd), public, allocatable, dimension(:,:,:,:) :: & - LH_micro_field_sum_tndcy, & ! Sum of all micro_field tendencies [units vary/s] - LH_micro_field_avg_tndcy ! Average of all micro_field tendencies [units vary/s] -#endif /*CLUBB_LH*/ -end module crmx_clubb_silhs_vars diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_clubbvars.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_clubbvars.F90 deleted file mode 100644 index 2edefbb344..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_clubbvars.F90 +++ /dev/null @@ -1,115 +0,0 @@ -! $Id: clubbvars.F90 1103 2013-05-14 18:35:02Z minghuai.wang@pnl.gov $ -module crmx_clubbvars -#ifdef CLUBB_CRM -! Description: -! This module contains variables that exist in CLUBB but not in SAM - - use crmx_grid, only: & - ntracers, & - nx, & - ny,& - nz,& - nzm,& - dimx1_s,& - dimx2_s,& - dimy1_s,& - dimy2_s,& - nxp1,& - nyp1,& - YES3D - - use crmx_clubb_precision, only: & - core_rknd ! CLUBB core real kind - - implicit none - - private ! Default Scope - - intrinsic :: selected_real_kind, max - - ! Determines whether to use CLUBB's eddy scalar or high order scalar code on - ! a tracer in SAM - ! To enable the passive scalars, set enable_ to 1, - ! and the dimensions for edsclr or sclr will be 1*ntracers. - integer, private, parameter :: & - enable_eddy_scalars = 0, & - enable_high_order_scalars = 0 - - integer, public, parameter :: & - edsclr_dim = enable_eddy_scalars*ntracers, & ! Number of eddy scalars - sclr_dim = enable_high_order_scalars*ntracers ! Number of high order scalars - - integer, parameter, public :: & - tndcy_precision = selected_real_kind( p=12 ) - - real(kind = core_rknd), public, dimension(nx, ny, nz) :: & - upwp, &! u'w'. [m^2/s^2] - vpwp, &! u'w'. [m^2/s^2] - up2, &! u'^2 [m^2/s^2] - vp2, &! v'^2 [m^2/s^2] - wprtp, &! w' r_t'. [(m kg)/(s kg)] - wpthlp, &! w' th_l'. [(m K)/s] - wprcp, &! w' r_c'. [(kg/kg) m/s] - wp2, &! w'^2. [m^2/s^2] - rtp2, &! r_t'^2. [(kg/kg)^2] - thlp2, &! th_l'^2. [K^2] - rtpthlp, &! r_t' th_l'. [(kg K)/kg] - rcm, &! Cloud water [kg/kg] - cloud_frac, &! Cloud Fraction. [-] - rcm_in_layer,&! rcm in cloud layer [kg/kg] - cloud_cover ! Cloud cover [-] - - real, public, dimension(0:nxp1, 1-YES3D:nyp1, nzm) :: & - khzm, &! eddy diffusivity on momentum grids [m^2/s] - khzt, &! eddy diffusivity on thermo grids [m^2/s] - qclvarg, &! cloud water variance [kg^2/kg^2] - relvarg, &! relative cloud water variance - accre_enhang ! accretion enhancement - - - real(kind=core_rknd), public, dimension(nx, ny) :: & - rtm_spurious_source, & ! Spurious source of total water [kg/kg/s] - thlm_spurious_source ! Spurious source of liquid pot. temp. [K/s] - - ! w'^3 is requires additional ghost points on the x and y dimension, - ! for the purposes of horizontal advection. The variables um and vm - ! require them for the purposes of horizontal interpolation. - real(kind=core_rknd), public, dimension(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nz) :: & - wp3,& ! w'^3. [m^3/s^3] - um, & ! x-wind [m/s] - vm ! y-wind [m/s] - - real(tndcy_precision), public, dimension(nx, ny, nzm) :: & - t_tndcy, & ! CLUBB contribution to moist static energy [K/s] - qc_tndcy, & ! CLUBB contribution to liquid water [kg/kg/s] - qv_tndcy, & ! CLUBB contribution to vapor water [kg/kg/s] - u_tndcy, & ! CLUBB contribution to x-wind [m/s^2] - v_tndcy ! CLUBB contribution to y-wind [m/s^2] - - real(tndcy_precision), public, dimension(nx, ny, nzm, ntracers) :: & - tracer_tndcy ! CLUBB contribution to the tracers [{units vary}/s] - - real(kind=core_rknd), public, dimension(nx,ny,nz,sclr_dim) :: & - sclrp2, & ! Passive scalar variance. [{units vary}^2] - sclrpthlp, & ! Passive scalar covariance. [{units vary} K] - sclrprtp, & ! Passive scalar covariance. [{units vary} kg/kg] - wpsclrp ! w'sclr' [units vary m/s] - - real(kind=core_rknd), public, dimension(sclr_dim) :: & - sclr_tol ! Tolerance on passive scalar [units vary] - - real(kind=core_rknd), public, dimension(nz) :: & - rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] - rho_ds_zt, & ! Dry, static density on thermodynamic levels [kg/m^3] - invrs_rho_ds_zm, & ! Inv. dry, static density on momentum levels [m^3/kg] - invrs_rho_ds_zt, & ! Inv. dry, static density on thermo. levels [m^3/kg] - thv_ds_zm, & ! Dry, base-state theta_v on momentum levels [K] - thv_ds_zt ! Dry, base-state theta_v on thermo. levels [K] - - logical, public :: l_stats_samgrid ! Stats on sam grid enabled (T/F) - -#ifdef CRM - logical, public :: lrestart_clubb = .false. -#endif -#endif /*CLUBB_CRM*/ -end module crmx_clubbvars diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom.F90 deleted file mode 100644 index 3491c3c4bd..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom.F90 +++ /dev/null @@ -1,24 +0,0 @@ -subroutine diffuse_mom - -! Interface to the diffusion routines - -use crmx_vars -implicit none -integer i,j,k - -!call t_startf ('diffuse_mom') - -if(RUN3D) then -! call diffuse_mom3D() - call diffuse_mom3D_xy() - call diffuse_mom3D_z() -else -! call diffuse_mom2D() - call diffuse_mom2D_xy() - call diffuse_mom2D_z() -endif - -!call t_stopf ('diffuse_mom') - -end subroutine diffuse_mom - diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom2D.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom2D.F90 deleted file mode 100644 index 26de915ad7..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom2D.F90 +++ /dev/null @@ -1,128 +0,0 @@ - -subroutine diffuse_mom2D - -! momentum tendency due to SGS diffusion - -use crmx_vars -use crmx_sgs, only: tk, grdf_x, grdf_z -use crmx_params, only: docolumn -#ifdef CLUBB_CRM -use crmx_params, only: doclubb, doclubb_sfc_fluxes, docam_sfc_fluxes -#endif -implicit none - -real rdx2,rdz2,rdz,rdx25,rdz25,rdx21,rdx251 -real dxz,dzx - -integer i,j,k,ic,ib,kc,kcu -real tkx, tkz, rhoi, iadzw, iadz -real fu(0:nx,1,nz),fv(0:nx,1,nz),fw(0:nx,1,nz) - -rdx2=1./dx/dx -rdx25=0.25*rdx2 - -dxz=dx/dz - -j=1 - -if(.not.docolumn) then - - -do k=1,nzm - - kc=k+1 - kcu=min(kc,nzm) - dxz=dx/(dz*adzw(kc)) - rdx21=rdx2 * grdf_x(k) - rdx251=rdx25 * grdf_x(k) - - do i=0,nx - ic=i+1 - tkx=rdx21*tk(i,j,k) - fu(i,j,k)=-2.*tkx*(u(ic,j,k)-u(i,j,k)) - fv(i,j,k)=-tkx*(v(ic,j,k)-v(i,j,k)) - tkx=rdx251*(tk(i,j,k)+tk(ic,j,k)+tk(i,j,kcu)+tk(ic,j,kcu)) - fw(i,j,k)=-tkx*(w(ic,j,kc)-w(i,j,kc)+(u(ic,j,kcu)-u(ic,j,k))*dxz) - end do - do i=1,nx - ib=i-1 - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,k)-fu(ib,j,k)) - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,k)-fv(ib,j,k)) - dwdt(i,j,kc,na)=dwdt(i,j,kc,na)-(fw(i,j,k)-fw(ib,j,k)) - end do - -end do - -end if - -!------------------------- -rdz=1./dz -dzx=dz/dx - -do k=1,nzm-1 - kc=k+1 - uwsb(kc)=0. - vwsb(kc)=0. - iadz = 1./adz(k) - iadzw= 1./adzw(kc) - rdz2=rdz*rdz *grdf_z(k) - rdz25=0.25*rdz2 - do i=1,nx - ib=i-1 - tkz=rdz2*tk(i,j,k) - fw(i,j,kc)=-2.*tkz*(w(i,j,kc)-w(i,j,k))*rho(k)*iadz - tkz=rdz25*(tk(i,j,k)+tk(ib,j,k)+tk(i,j,kc)+tk(ib,j,kc)) - fu(i,j,kc)=-tkz*( (u(i,j,kc)-u(i,j,k))*iadzw + & - (w(i,j,kc)-w(ib,j,kc))*dzx)*rhow(kc) - fv(i,j,kc)=-tkz*(v(i,j,kc)-v(i,j,k))*iadzw*rhow(kc) - uwsb(kc)=uwsb(kc)+fu(i,j,kc) - vwsb(kc)=vwsb(kc)+fv(i,j,kc) - end do -end do - -uwsb(1) = 0. -vwsb(1) = 0. - -do i=1,nx - tkz=rdz2*grdf_z(nzm)*tk(i,j,nzm) - fw(i,j,nz)=-2.*tkz*(w(i,j,nz)-w(i,j,nzm))/adz(nzm)*rho(nzm) -#ifdef CLUBB_CRM - ! Add in the surface flux later -dschanen UWM 27 Aug 2008 - if ( doclubb .and. (doclubb_sfc_fluxes .or. docam_sfc_fluxes) ) then - fu(i,j,1) = 0.0 ! This is handled by CLUBB - fv(i,j,1) = 0.0 ! " " - else - fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1) - fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1) - end if -#else - fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1) - fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1) -#endif /*CLUBB_CRM*/ - fu(i,j,nz)=fluxtu(i,j) * rdz * rhow(nz) - fv(i,j,nz)=fluxtv(i,j) * rdz * rhow(nz) - uwsb(1) = uwsb(1) + fu(i,j,1) - vwsb(1) = vwsb(1) + fv(i,j,1) -end do - - -do k=1,nzm - kc=k+1 - rhoi = 1./(rho(k)*adz(k)) - do i=1,nx - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,kc)-fu(i,j,k))*rhoi - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,kc)-fv(i,j,k))*rhoi - end do -end do ! k - -do k=2,nzm - rhoi = 1./(rhow(k)*adzw(k)) - do i=1,nx - dwdt(i,j,k,na)=dwdt(i,j,k,na)-(fw(i,j,k+1)-fw(i,j,k))*rhoi - end do -end do ! k - - -end subroutine diffuse_mom2D - - diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom2D_xy.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom2D_xy.F90 deleted file mode 100644 index 5f4605d9e8..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom2D_xy.F90 +++ /dev/null @@ -1,57 +0,0 @@ - -subroutine diffuse_mom2D_xy - -! momentum tendency due to SGS diffusion - -use crmx_vars -use crmx_sgs, only: tk, grdf_x, grdf_z -use crmx_params, only: docolumn -implicit none - -real rdx2,rdz2,rdz,rdx25,rdz25,rdx21,rdx251 -real dxz,dzx - -integer i,j,k,ic,ib,kc,kcu -real tkx, tkz, rhoi, iadzw, iadz -real fu(0:nx,1,nz),fv(0:nx,1,nz),fw(0:nx,1,nz) - -rdx2=1./dx/dx -rdx25=0.25*rdx2 - -dxz=dx/dz - -j=1 - -if(.not.docolumn) then - - -do k=1,nzm - - kc=k+1 - kcu=min(kc,nzm) - dxz=dx/(dz*adzw(kc)) - rdx21=rdx2 * grdf_x(k) - rdx251=rdx25 * grdf_x(k) - - do i=0,nx - ic=i+1 - tkx=rdx21*tk(i,j,k) - fu(i,j,k)=-2.*tkx*(u(ic,j,k)-u(i,j,k)) - fv(i,j,k)=-tkx*(v(ic,j,k)-v(i,j,k)) - tkx=rdx251*(tk(i,j,k)+tk(ic,j,k)+tk(i,j,kcu)+tk(ic,j,kcu)) - fw(i,j,k)=-tkx*(w(ic,j,kc)-w(i,j,kc)+(u(ic,j,kcu)-u(ic,j,k))*dxz) - end do - do i=1,nx - ib=i-1 - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,k)-fu(ib,j,k)) - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,k)-fv(ib,j,k)) - dwdt(i,j,kc,na)=dwdt(i,j,kc,na)-(fw(i,j,k)-fw(ib,j,k)) - end do - -end do - -end if - -end subroutine diffuse_mom2D_xy - - diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom2D_z.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom2D_z.F90 deleted file mode 100644 index 06fe1169f0..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom2D_z.F90 +++ /dev/null @@ -1,125 +0,0 @@ - -subroutine diffuse_mom2D_z - -! momentum tendency due to SGS diffusion - -use crmx_vars -use crmx_sgs, only: tk, grdf_x, grdf_z -use crmx_params, only: docolumn -#ifdef CLUBB_CRM -use crmx_params, only: doclubb, doclubb_sfc_fluxes, docam_sfc_fluxes -use crmx_sgs, only: tk_clubb -#endif -implicit none - -real rdx2,rdz2,rdz,rdx25,rdz25,rdx21,rdx251 -real dxz,dzx - -integer i,j,k,ic,ib,kc,kcu -real tkx, tkz, rhoi, iadzw, iadz -real fu(0:nx,1,nz),fv(0:nx,1,nz),fw(0:nx,1,nz) -real tktemp(0:nxp1, 1-YES3D:nyp1, nzm) - - -#ifndef CLUBB_CRM -tktemp(:, :, :) = tk(:, :, :) -#else -if(doclubb) then -!tktemp(:, :, :) = 0.0 ! the vertical diffusion of moment has been done in CLUBB -!tktemp(:, :, :) = tk_clubb ! We need this for the vertical diffuseion of verttical velocity -! ! As dudt and dvdt are updated in clubb_sgs, dudt and dvdt are not updated here. -tktemp(:, :, :) = tk_clubb * 0.2 ! use 0.2 here, as 0.4 is found too large for - ! 1.9x2.5 MMF simulation, as the explicit time integration scheme - ! is used for moment in SAM and large diffusion term can cause - ! numerical instability +++mhwang - ! -!tktemp(:, :, :) = tk_clubb * 0.00 ! follow what is done in clubb_sgs. -!tktemp(:, :, :) = tk -else -tktemp(:, :, :) = tk(:, :, :) -endif -#endif - -rdx2=1./dx/dx -rdx25=0.25*rdx2 - -j=1 - -!------------------------- -rdz=1./dz -dzx=dz/dx - -do k=1,nzm-1 - kc=k+1 - uwsb(kc)=0. - vwsb(kc)=0. - iadz = 1./adz(k) - iadzw= 1./adzw(kc) - rdz2=rdz*rdz *grdf_z(k) - rdz25=0.25*rdz2 - do i=1,nx - ib=i-1 - tkz=rdz2*tktemp(i,j,k) - fw(i,j,kc)=-2.*tkz*(w(i,j,kc)-w(i,j,k))*rho(k)*iadz - tkz=rdz25*(tktemp(i,j,k)+tktemp(ib,j,k)+tktemp(i,j,kc)+tktemp(ib,j,kc)) - fu(i,j,kc)=-tkz*( (u(i,j,kc)-u(i,j,k))*iadzw + & - (w(i,j,kc)-w(ib,j,kc))*dzx)*rhow(kc) - fv(i,j,kc)=-tkz*(v(i,j,kc)-v(i,j,k))*iadzw*rhow(kc) - uwsb(kc)=uwsb(kc)+fu(i,j,kc) - vwsb(kc)=vwsb(kc)+fv(i,j,kc) - end do -end do - -uwsb(1) = 0. -vwsb(1) = 0. - -do i=1,nx - tkz=rdz2*grdf_z(nzm)*tktemp(i,j,nzm) - fw(i,j,nz)=-2.*tkz*(w(i,j,nz)-w(i,j,nzm))/adz(nzm)*rho(nzm) -#ifdef CLUBB_CRM - ! Add in the surface flux later -dschanen UWM 27 Aug 2008 - if ( doclubb .and. (doclubb_sfc_fluxes .or. docam_sfc_fluxes) ) then - fu(i,j,1) = 0.0 ! This is handled by CLUBB - fv(i,j,1) = 0.0 ! " " - else - fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1) - fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1) - end if -#else - fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1) - fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1) -#endif /*CLUBB_CRM*/ - fu(i,j,nz)=fluxtu(i,j) * rdz * rhow(nz) - fv(i,j,nz)=fluxtv(i,j) * rdz * rhow(nz) - uwsb(1) = uwsb(1) + fu(i,j,1) - vwsb(1) = vwsb(1) + fv(i,j,1) -end do - - -do k=1,nzm - kc=k+1 - rhoi = 1./(rho(k)*adz(k)) - do i=1,nx -#ifdef CLUBB_CRM -! if(.not. doclubb) then ! when doclubb is true, dudt and dvdt have been updated in clubb_sgs - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,kc)-fu(i,j,k))*rhoi - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,kc)-fv(i,j,k))*rhoi -! end if -#else - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,kc)-fu(i,j,k))*rhoi - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,kc)-fv(i,j,k))*rhoi -#endif - end do -end do ! k - -do k=2,nzm - rhoi = 1./(rhow(k)*adzw(k)) - do i=1,nx - dwdt(i,j,k,na)=dwdt(i,j,k,na)-(fw(i,j,k+1)-fw(i,j,k))*rhoi - end do -end do ! k - - -end subroutine diffuse_mom2D_z - - diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom3D.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom3D.F90 deleted file mode 100644 index d61d506bb5..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom3D.F90 +++ /dev/null @@ -1,164 +0,0 @@ - -subroutine diffuse_mom3D - -! momentum tendency due to SGS diffusion - -use crmx_vars -use crmx_sgs, only: tk, grdf_x, grdf_y, grdf_z -use crmx_params, only: docolumn -#ifdef CLUBB_CRM -use crmx_params, only: doclubb, doclubb_sfc_fluxes, docam_sfc_fluxes -#endif -implicit none - -real rdx2,rdy2,rdz2,rdz,rdx25,rdy25 -real rdx21,rdy21,rdx251,rdy251,rdz25 -real dxy,dxz,dyx,dyz,dzx,dzy - -integer i,j,k,ic,ib,jb,jc,kc,kcu -real tkx, tky, tkz, rhoi, iadzw, iadz -real fu(0:nx,0:ny,nz),fv(0:nx,0:ny,nz),fw(0:nx,0:ny,nz) - -rdx2=1./(dx*dx) -rdy2=1./(dy*dy) - -rdx25=0.25*rdx2 -rdy25=0.25*rdy2 - -dxy=dx/dy -dxz=dx/dz -dyx=dy/dx -dyz=dy/dz - - -do k=1,nzm - kc=k+1 - kcu=min(kc,nzm) - dxz=dx/(dz*adzw(kc)) - dyz=dy/(dz*adzw(kc)) - rdx21=rdx2 * grdf_x(k) - rdy21=rdy2 * grdf_y(k) - rdx251=rdx25 * grdf_x(k) - rdy251=rdy25 * grdf_y(k) - do j=1,ny - jb=j-1 - do i=0,nx - ic=i+1 - tkx=rdx21*tk(i,j,k) - fu(i,j,k)=-2.*tkx*(u(ic,j,k)-u(i,j,k)) - tkx=rdx251*(tk(i,j,k)+tk(i,jb,k)+tk(ic,j,k)+tk(ic,jb,k)) - fv(i,j,k)=-tkx*(v(ic,j,k)-v(i,j,k)+(u(ic,j,k)-u(ic,jb,k))*dxy) - tkx=rdx251*(tk(i,j,k)+tk(ic,j,k)+tk(i,j,kcu)+tk(ic,j,kcu)) - fw(i,j,k)=-tkx*(w(ic,j,kc)-w(i,j,kc)+(u(ic,j,kcu)-u(ic,j,k))*dxz) - end do - do i=1,nx - ib=i-1 - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,k)-fu(ib,j,k)) - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,k)-fv(ib,j,k)) - dwdt(i,j,kc,na)=dwdt(i,j,kc,na)-(fw(i,j,k)-fw(ib,j,k)) - end do - end do - - do j=0,ny - jc=j+1 - do i=1,nx - ib=i-1 - tky=rdy21*tk(i,j,k) - fv(i,j,k)=-2.*tky*(v(i,jc,k)-v(i,j,k)) - tky=rdy251*(tk(i,j,k)+tk(ib,j,k)+tk(i,jc,k)+tk(ib,jc,k)) - fu(i,j,k)=-tky*(u(i,jc,k)-u(i,j,k)+(v(i,jc,k)-v(ib,jc,k))*dyx) - tky=rdy251*(tk(i,j,k)+tk(i,jc,k)+tk(i,j,kcu)+tk(i,jc,kcu)) - fw(i,j,k)=-tky*(w(i,jc,kc)-w(i,j,kc)+(v(i,jc,kcu)-v(i,jc,k))*dyz) - end do - end do - do j=1,ny - jb=j-1 - do i=1,nx - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,k)-fu(i,jb,k)) - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,k)-fv(i,jb,k)) - dwdt(i,j,kc,na)=dwdt(i,j,kc,na)-(fw(i,j,k)-fw(i,jb,k)) - end do - end do - -end do - -!------------------------- -rdz=1./dz -dzx=dz/dx -dzy=dz/dy - -do k=1,nzm-1 - kc=k+1 - uwsb(kc)=0. - vwsb(kc)=0. - iadz = 1./adz(k) - iadzw= 1./adzw(kc) - rdz2 = rdz*rdz * grdf_z(k) - rdz25 = 0.25*rdz2 - do j=1,ny - jb=j-1 - do i=1,nx - ib=i-1 - tkz=rdz2*tk(i,j,k) - fw(i,j,kc)=-2.*tkz*(w(i,j,kc)-w(i,j,k))*rho(k)*iadz - tkz=rdz25*(tk(i,j,k)+tk(ib,j,k)+tk(i,j,kc)+tk(ib,j,kc)) - fu(i,j,kc)=-tkz*( (u(i,j,kc)-u(i,j,k))*iadzw + & - (w(i,j,kc)-w(ib,j,kc))*dzx)*rhow(kc) - tkz=rdz25*(tk(i,j,k)+tk(i,jb,k)+tk(i,j,kc)+tk(i,jb,kc)) - fv(i,j,kc)=-tkz*( (v(i,j,kc)-v(i,j,k))*iadzw + & - (w(i,j,kc)-w(i,jb,kc))*dzy)*rhow(kc) - uwsb(kc)=uwsb(kc)+fu(i,j,kc) - vwsb(kc)=vwsb(kc)+fv(i,j,kc) - end do - end do -end do - -uwsb(1) = 0. -vwsb(1) = 0. - -do j=1,ny - do i=1,nx - tkz=rdz2*grdf_z(nzm)*tk(i,j,nzm) - fw(i,j,nz)=-2.*tkz*(w(i,j,nz)-w(i,j,nzm))/adz(nzm)*rho(nzm) -#ifdef CLUBB_CRM - ! Add in the surface flux later -dschanen UWM 27 Aug 2008 - if ( doclubb .and. (doclubb_sfc_fluxes .or. docam_sfc_fluxes)) then - fu(i,j,1) = 0.0 ! This is handled by CLUBB - fv(i,j,1) = 0.0 ! " " - else - fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1) - fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1) - end if -#else - fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1) - fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1) -#endif /*CLUBB*/ - fu(i,j,nz)=fluxtu(i,j) * rdz * rhow(nz) - fv(i,j,nz)=fluxtv(i,j) * rdz * rhow(nz) - uwsb(1) = uwsb(1) + fu(i,j,1) - vwsb(1) = vwsb(1) + fv(i,j,1) - end do - end do - - do k=1,nzm - kc=k+1 - rhoi = 1./(rho(k)*adz(k)) - do j=1,ny - do i=1,nx - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,kc)-fu(i,j,k))*rhoi - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,kc)-fv(i,j,k))*rhoi - end do - end do - end do ! k - - do k=2,nzm - rhoi = 1./(rhow(k)*adzw(k)) - do j=1,ny - do i=1,nx - dwdt(i,j,k,na)=dwdt(i,j,k,na)-(fw(i,j,k+1)-fw(i,j,k))*rhoi - end do - end do - end do ! k - - -end subroutine diffuse_mom3D diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom3D_xy.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom3D_xy.F90 deleted file mode 100644 index f294f8e60e..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom3D_xy.F90 +++ /dev/null @@ -1,82 +0,0 @@ - -subroutine diffuse_mom3D_xy - -! momentum tendency due to SGS diffusion - -use crmx_vars -use crmx_sgs, only: tk, grdf_x, grdf_y, grdf_z -use crmx_params, only: docolumn -implicit none - -real rdx2,rdy2,rdz2,rdz,rdx25,rdy25 -real rdx21,rdy21,rdx251,rdy251,rdz25 -real dxy,dxz,dyx,dyz,dzx,dzy - -integer i,j,k,ic,ib,jb,jc,kc,kcu -real tkx, tky, tkz, rhoi, iadzw, iadz -real fu(0:nx,0:ny,nz),fv(0:nx,0:ny,nz),fw(0:nx,0:ny,nz) - -rdx2=1./(dx*dx) -rdy2=1./(dy*dy) - -rdx25=0.25*rdx2 -rdy25=0.25*rdy2 - -dxy=dx/dy -dxz=dx/dz -dyx=dy/dx -dyz=dy/dz - - -do k=1,nzm - kc=k+1 - kcu=min(kc,nzm) - dxz=dx/(dz*adzw(kc)) - dyz=dy/(dz*adzw(kc)) - rdx21=rdx2 * grdf_x(k) - rdy21=rdy2 * grdf_y(k) - rdx251=rdx25 * grdf_x(k) - rdy251=rdy25 * grdf_y(k) - do j=1,ny - jb=j-1 - do i=0,nx - ic=i+1 - tkx=rdx21*tk(i,j,k) - fu(i,j,k)=-2.*tkx*(u(ic,j,k)-u(i,j,k)) - tkx=rdx251*(tk(i,j,k)+tk(i,jb,k)+tk(ic,j,k)+tk(ic,jb,k)) - fv(i,j,k)=-tkx*(v(ic,j,k)-v(i,j,k)+(u(ic,j,k)-u(ic,jb,k))*dxy) - tkx=rdx251*(tk(i,j,k)+tk(ic,j,k)+tk(i,j,kcu)+tk(ic,j,kcu)) - fw(i,j,k)=-tkx*(w(ic,j,kc)-w(i,j,kc)+(u(ic,j,kcu)-u(ic,j,k))*dxz) - end do - do i=1,nx - ib=i-1 - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,k)-fu(ib,j,k)) - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,k)-fv(ib,j,k)) - dwdt(i,j,kc,na)=dwdt(i,j,kc,na)-(fw(i,j,k)-fw(ib,j,k)) - end do - end do - - do j=0,ny - jc=j+1 - do i=1,nx - ib=i-1 - tky=rdy21*tk(i,j,k) - fv(i,j,k)=-2.*tky*(v(i,jc,k)-v(i,j,k)) - tky=rdy251*(tk(i,j,k)+tk(ib,j,k)+tk(i,jc,k)+tk(ib,jc,k)) - fu(i,j,k)=-tky*(u(i,jc,k)-u(i,j,k)+(v(i,jc,k)-v(ib,jc,k))*dyx) - tky=rdy251*(tk(i,j,k)+tk(i,jc,k)+tk(i,j,kcu)+tk(i,jc,kcu)) - fw(i,j,k)=-tky*(w(i,jc,kc)-w(i,j,kc)+(v(i,jc,kcu)-v(i,jc,k))*dyz) - end do - end do - do j=1,ny - jb=j-1 - do i=1,nx - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,k)-fu(i,jb,k)) - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,k)-fv(i,jb,k)) - dwdt(i,j,kc,na)=dwdt(i,j,kc,na)-(fw(i,j,k)-fw(i,jb,k)) - end do - end do - -end do - -end subroutine diffuse_mom3D_xy diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom3D_z.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom3D_z.F90 deleted file mode 100644 index 31e6232efa..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_mom3D_z.F90 +++ /dev/null @@ -1,134 +0,0 @@ - -subroutine diffuse_mom3D_z - -! momentum tendency due to SGS diffusion - -use crmx_vars -use crmx_sgs, only: tk, grdf_x, grdf_y, grdf_z -use crmx_params, only: docolumn -#ifdef CLUBB_CRM -use crmx_params, only: doclubb, doclubb_sfc_fluxes, docam_sfc_fluxes -use crmx_sgs, only: tk_clubb -#endif -implicit none - -real rdx2,rdy2,rdz2,rdz,rdx25,rdy25 -real rdx21,rdy21,rdx251,rdy251,rdz25 -real dxy,dxz,dyx,dyz,dzx,dzy - -integer i,j,k,ic,ib,jb,jc,kc,kcu -real tkx, tky, tkz, rhoi, iadzw, iadz -real fu(0:nx,0:ny,nz),fv(0:nx,0:ny,nz),fw(0:nx,0:ny,nz) -real tktemp(0:nxp1, 1-YES3D:nyp1, nzm) - -#ifndef CLUBB_CRM -tktemp(:, :, :) = tk(:, :, :) -#else -if(doclubb) then -!tktemp(:, :, :) = 0.0 ! the vertical diffusion of moment has been done in CLUBB -!tktemp(:, :, :) = tk_clubb ! We need this for the vertical diffuseion of vertical velocity -! ! As dudt and dvdt are updated in clubb_sgs, dudt and dvdt are not updated here -tktemp(:, :, :) = tk_clubb * 0.2 ! use 0.2 here, as 0.4 is found too large for - ! 1.9x2.5 MMF simulation, as the explicit time integration scheme - ! is used for moment in SAM and large diffusion term can cause - ! numerical instability +++mhwang -else -tktemp(:, :, :) = tk(:, :, :) -endif -#endif - -rdx2=1./(dx*dx) -rdy2=1./(dy*dy) - -rdx25=0.25*rdx2 -rdy25=0.25*rdy2 - -!------------------------- -rdz=1./dz -dzx=dz/dx -dzy=dz/dy - -do k=1,nzm-1 - kc=k+1 - uwsb(kc)=0. - vwsb(kc)=0. - iadz = 1./adz(k) - iadzw= 1./adzw(kc) - rdz2 = rdz*rdz * grdf_z(k) - rdz25 = 0.25*rdz2 - do j=1,ny - jb=j-1 - do i=1,nx - ib=i-1 - tkz=rdz2*tktemp(i,j,k) - fw(i,j,kc)=-2.*tkz*(w(i,j,kc)-w(i,j,k))*rho(k)*iadz - tkz=rdz25*(tktemp(i,j,k)+tktemp(ib,j,k)+tktemp(i,j,kc)+tktemp(ib,j,kc)) - fu(i,j,kc)=-tkz*( (u(i,j,kc)-u(i,j,k))*iadzw + & - (w(i,j,kc)-w(ib,j,kc))*dzx)*rhow(kc) - tkz=rdz25*(tktemp(i,j,k)+tktemp(i,jb,k)+tktemp(i,j,kc)+tktemp(i,jb,kc)) - fv(i,j,kc)=-tkz*( (v(i,j,kc)-v(i,j,k))*iadzw + & - (w(i,j,kc)-w(i,jb,kc))*dzy)*rhow(kc) - uwsb(kc)=uwsb(kc)+fu(i,j,kc) - vwsb(kc)=vwsb(kc)+fv(i,j,kc) - end do - end do -end do - -uwsb(1) = 0. -vwsb(1) = 0. - -do j=1,ny - do i=1,nx - tkz=rdz2*grdf_z(nzm)*tktemp(i,j,nzm) - fw(i,j,nz)=-2.*tkz*(w(i,j,nz)-w(i,j,nzm))/adz(nzm)*rho(nzm) -#ifdef CLUBB_CRM - ! Add in the surface flux later -dschanen UWM 27 Aug 2008 - if ( doclubb .and. (doclubb_sfc_fluxes .or. docam_sfc_fluxes)) then - fu(i,j,1) = 0.0 ! This is handled by CLUBB - fv(i,j,1) = 0.0 ! " " - else - fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1) - fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1) - end if -#else - fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1) - fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1) -#endif /*CLUBB*/ - fu(i,j,nz)=fluxtu(i,j) * rdz * rhow(nz) - fv(i,j,nz)=fluxtv(i,j) * rdz * rhow(nz) - uwsb(1) = uwsb(1) + fu(i,j,1) - vwsb(1) = vwsb(1) + fv(i,j,1) - end do - end do - - do k=1,nzm - kc=k+1 - rhoi = 1./(rho(k)*adz(k)) - do j=1,ny - do i=1,nx -#ifdef CLUBB_CRM -! if(.not. doclubb) then ! when doclubb is true, dudt and dvdt have been updated in clubb_sgs - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,kc)-fu(i,j,k))*rhoi - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,kc)-fv(i,j,k))*rhoi -! end if -#else - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,kc)-fu(i,j,k))*rhoi - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,kc)-fv(i,j,k))*rhoi -#endif - - end do - end do - end do ! k - - - do k=2,nzm - rhoi = 1./(rhow(k)*adzw(k)) - do j=1,ny - do i=1,nx - dwdt(i,j,k,na)=dwdt(i,j,k,na)-(fw(i,j,k+1)-fw(i,j,k))*rhoi - end do - end do - end do ! k - - -end subroutine diffuse_mom3D_z diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar.F90 deleted file mode 100644 index bf3085be14..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar.F90 +++ /dev/null @@ -1,46 +0,0 @@ -subroutine diffuse_scalar (f,fluxb,fluxt, & - fdiff,flux,f2lediff,f2lediss,fwlediff,doit) - -use crmx_grid -use crmx_vars, only: rho, rhow -use crmx_sgs, only: tkh -implicit none - -! input: -real f(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real flux(nz) -real f2lediff(nz),f2lediss(nz),fwlediff(nz) -real fdiff(nz) -logical doit -! Local -real df(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -integer i,j,k - -!call t_startf ('diffuse_scalars') - -df(:,:,:) = f(:,:,:) - -if(RUN3D) then -! call diffuse_scalar3D (f,fluxb,fluxt,tkh,rho,rhow,flux) - call diffuse_scalar3D_xy (f,fluxb,fluxt,tkh,rho,rhow,flux) - call diffuse_scalar3D_z (f,fluxb,fluxt,tkh,rho,rhow,flux) -else -! call diffuse_scalar2D (f,fluxb,fluxt,tkh,rho,rhow,flux) - call diffuse_scalar2D_xy (f,fluxb,fluxt,tkh,rho,rhow,flux) - call diffuse_scalar2D_z (f,fluxb,fluxt,tkh,rho,rhow,flux) -endif - -do k=1,nzm - fdiff(k)=0. - do j=1,ny - do i=1,nx - fdiff(k)=fdiff(k)+f(i,j,k)-df(i,j,k) - end do - end do -end do - -!call t_stopf ('diffuse_scalars') - -end subroutine diffuse_scalar diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar2D.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar2D.F90 deleted file mode 100644 index d8ff8f7587..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar2D.F90 +++ /dev/null @@ -1,103 +0,0 @@ -subroutine diffuse_scalar2D (field,fluxb,fluxt,tkh,rho,rhow,flux) - -use crmx_grid -use crmx_params, only: docolumn,dowallx,dosgs -use crmx_sgs,only: grdf_x,grdf_z -implicit none - -! input -real field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real tkh(0:nxp1, 1-YES3D:nyp1, nzm) ! eddy conductivity -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real rho(nzm) -real rhow(nz) -real flux(nz) - -! local -real flx(0:nx,1,0:nzm) -real dfdt(nx,ny,nzm) -real rdx2,rdz2,rdz,rdx5,rdz5,tmp -real dxz,dzx,tkx,tkz,rhoi -integer i,j,k,ib,ic,kc,kb - -if(.not.dosgs.and..not.docolumn) return - -rdx2=1./(dx*dx) -rdz2=1./(dz*dz) -rdz=1./dz -dxz=dx/dz -dzx=dz/dx - -j=1 - -dfdt(:,:,:)=0. - -if(dowallx) then - - if(mod(rank,nsubdomains_x).eq.0) then - do k=1,nzm - field(0,j,k) = field(1,j,k) - end do - end if - if(mod(rank,nsubdomains_x).eq.nsubdomains_x-1) then - do k=1,nzm - field(nx+1,j,k) = field(nx,j,k) - end do - end if - -end if - - -if(.not.docolumn) then - - -do k=1,nzm - - rdx5=0.5*rdx2 *grdf_x(k) - - do i=0,nx - ic=i+1 - tkx=rdx5*(tkh(i,j,k)+tkh(ic,j,k)) - flx(i,j,k)=-tkx*(field(ic,j,k)-field(i,j,k)) - end do - do i=1,nx - ib=i-1 - dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(ib,j,k)) - end do - -end do - -end if - -flux(1) = 0. -tmp=1./adzw(nz) -do i=1,nx - flx(i,j,0)=fluxb(i,j)*rdz*rhow(1) - flx(i,j,nzm)=fluxt(i,j)*rdz*tmp*rhow(nz) - flux(1) = flux(1) + flx(i,j,0) -end do - - -do k=1,nzm-1 - kc=k+1 - flux(kc)=0. - rhoi = rhow(kc)/adzw(kc) - rdz5=0.5*rdz2 * grdf_z(k) - do i=1,nx - tkz=rdz5*(tkh(i,j,k)+tkh(i,j,kc)) - flx(i,j,k)=-tkz*(field(i,j,kc)-field(i,j,k))*rhoi - flux(kc) = flux(kc) + flx(i,j,k) - end do -end do - -do k=1,nzm - kb=k-1 - rhoi = 1./(adz(k)*rho(k)) - do i=1,nx - dfdt(i,j,k)=dtn*(dfdt(i,j,k)-(flx(i,j,k)-flx(i,j,kb))*rhoi) - field(i,j,k)=field(i,j,k) + dfdt(i,j,k) - end do -end do - -end subroutine diffuse_scalar2D diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar2D_xy.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar2D_xy.F90 deleted file mode 100644 index 8657d61349..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar2D_xy.F90 +++ /dev/null @@ -1,79 +0,0 @@ -subroutine diffuse_scalar2D_xy (field,fluxb,fluxt,tkh,rho,rhow,flux) - -use crmx_grid -use crmx_params, only: docolumn,dowallx,dosgs -use crmx_sgs,only: grdf_x,grdf_z -implicit none - -! input -real field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real tkh(0:nxp1, 1-YES3D:nyp1, nzm) ! eddy conductivity -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real rho(nzm) -real rhow(nz) -real flux(nz) - -! local -real flx(0:nx,1,0:nzm) -real dfdt(nx,ny,nzm) -real rdx2,rdz2,rdz,rdx5,rdz5,tmp -real dxz,dzx,tkx,tkz,rhoi -integer i,j,k,ib,ic,kc,kb - -if(.not.dosgs.and..not.docolumn) return - -rdx2=1./(dx*dx) -rdz2=1./(dz*dz) -rdz=1./dz -dxz=dx/dz -dzx=dz/dx - -j=1 - -dfdt(:,:,:)=0. - -if(dowallx) then - - if(mod(rank,nsubdomains_x).eq.0) then - do k=1,nzm - field(0,j,k) = field(1,j,k) - end do - end if - if(mod(rank,nsubdomains_x).eq.nsubdomains_x-1) then - do k=1,nzm - field(nx+1,j,k) = field(nx,j,k) - end do - end if - -end if - - -if(.not.docolumn) then - - -do k=1,nzm - - rdx5=0.5*rdx2 *grdf_x(k) - - do i=0,nx - ic=i+1 - tkx=rdx5*(tkh(i,j,k)+tkh(ic,j,k)) - flx(i,j,k)=-tkx*(field(ic,j,k)-field(i,j,k)) - end do - do i=1,nx - ib=i-1 - dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(ib,j,k)) - end do - - do i=1,nx - field(i,j,k)=field(i,j,k) + dfdt(i,j,k) * dtn - end do - -end do - -end if - -flux = 0.0 - -end subroutine diffuse_scalar2D_xy diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar2D_z.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar2D_z.F90 deleted file mode 100644 index 4d0b6e76f7..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar2D_z.F90 +++ /dev/null @@ -1,66 +0,0 @@ -subroutine diffuse_scalar2D_z (field,fluxb,fluxt,tkh,rho,rhow,flux) - -use crmx_grid -use crmx_params, only: docolumn,dowallx,dosgs -use crmx_sgs,only: grdf_x,grdf_z -implicit none - -! input -real field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real tkh(0:nxp1, 1-YES3D:nyp1, nzm) ! eddy conductivity -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real rho(nzm) -real rhow(nz) -real flux(nz) - -! local -real flx(0:nx,1,0:nzm) -real dfdt(nx,ny,nzm) -real rdx2,rdz2,rdz,rdx5,rdz5,tmp -real dxz,dzx,tkx,tkz,rhoi -integer i,j,k,ib,ic,kc,kb - -if(.not.dosgs.and..not.docolumn) return - -rdx2=1./(dx*dx) -rdz2=1./(dz*dz) -rdz=1./dz -dxz=dx/dz -dzx=dz/dx - -j=1 - -dfdt(:,:,:)=0. - -flux(1) = 0. -tmp=1./adzw(nz) -do i=1,nx - flx(i,j,0)=fluxb(i,j)*rdz*rhow(1) - flx(i,j,nzm)=fluxt(i,j)*rdz*tmp*rhow(nz) - flux(1) = flux(1) + flx(i,j,0) -end do - - -do k=1,nzm-1 - kc=k+1 - flux(kc)=0. - rhoi = rhow(kc)/adzw(kc) - rdz5=0.5*rdz2 * grdf_z(k) - do i=1,nx - tkz=rdz5*(tkh(i,j,k)+tkh(i,j,kc)) - flx(i,j,k)=-tkz*(field(i,j,kc)-field(i,j,k))*rhoi - flux(kc) = flux(kc) + flx(i,j,k) - end do -end do - -do k=1,nzm - kb=k-1 - rhoi = 1./(adz(k)*rho(k)) - do i=1,nx - dfdt(i,j,k)=dtn*(dfdt(i,j,k)-(flx(i,j,k)-flx(i,j,kb))*rhoi) - field(i,j,k)=field(i,j,k) + dfdt(i,j,k) - end do -end do - -end subroutine diffuse_scalar2D_z diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar3D.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar3D.F90 deleted file mode 100644 index f166ee61ea..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar3D.F90 +++ /dev/null @@ -1,177 +0,0 @@ -subroutine diffuse_scalar3D (field,fluxb,fluxt,tkh,rho,rhow,flux) - -use crmx_grid -use crmx_params, only: docolumn,dowallx,dowally,dosgs -use crmx_sgs, only: grdf_x,grdf_y,grdf_z -implicit none -! input -real field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real tkh(0:nxp1,1-YES3D:nyp1,nzm) ! eddy conductivity -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real rho(nzm) -real rhow(nz) -real flux(nz) -! local -real flx(0:nx,0:ny,0:nzm) -real dfdt(nx,ny,nz) -real rdx2,rdy2,rdz2,rdz,rdx5,rdy5,rdz5,tmp -real dxy,dxz,dyx,dyz,dzx,dzy,tkx,tky,tkz,rhoi -integer i,j,k,ib,ic,jb,jc,kc,kb - - -if(.not.dosgs) return - -rdx2=1./(dx*dx) -rdy2=1./(dy*dy) -rdz2=1./(dz*dz) -rdz=1./dz -dxy=dx/dy -dxz=dx/dz -dyx=dy/dx -dyz=dy/dz -dzx=dz/dx -dzy=dz/dy - -dfdt(:,:,:)=0. - -!----------------------------------------- -if(dowallx) then - - if(mod(rank,nsubdomains_x).eq.0) then - do k=1,nzm - do j=1,ny - field(0,j,k) = field(1,j,k) - end do - end do - end if - if(mod(rank,nsubdomains_x).eq.nsubdomains_x-1) then - do k=1,nzm - do j=1,ny - field(nx+1,j,k) = field(nx,j,k) - end do - end do - end if - -end if - -if(dowally) then - - if(rank.lt.nsubdomains_x) then - do k=1,nzm - do i=1,nx - field(i,1-YES3D,k) = field(i,1,k) - end do - end do - end if - if(rank.gt.nsubdomains-nsubdomains_x-1) then - do k=1,nzm - do i=1,ny - field(i,ny+YES3D,k) = field(i,ny,k) - end do - end do - end if - -end if - - - -if(dowally) then - - call task_rank_to_index(rank, ib, jb) - if(jb.eq.0) then - do k=1,nzm - do i=1,nx - field(i,1-YES3D,k) = field(i,1,k) - end do - end do - end if - if(jb.eq.nsubdomains_y-1) then - do k=1,nzm - do i=1,nx - field(i,ny+YES3D,k) = field(i,ny,k) - end do - end do - end if - -end if - -!----------------------------------------- - - -! Horizontal diffusion: - - -do k=1,nzm - - rdx5=0.5*rdx2 * grdf_x(k) - rdy5=0.5*rdy2 * grdf_y(k) - - do j=1,ny - do i=0,nx - ic=i+1 - tkx=rdx5*(tkh(i,j,k)+tkh(ic,j,k)) - flx(i,j,k)=-tkx*(field(ic,j,k)-field(i,j,k)) - end do - do i=1,nx - ib=i-1 - dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(ib,j,k)) - end do - end do - - do j=0,ny - jc=j+1 - do i=1,nx - tky=rdy5*(tkh(i,j,k)+tkh(i,jc,k)) - flx(i,j,k)=-tky*(field(i,jc,k)-field(i,j,k)) - end do - end do - do j=1,ny - jb=j-1 - do i=1,nx - dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(i,jb,k)) - end do - end do - -end do ! k - - -! Vertical diffusion: - -flux(1) = 0. -tmp=1./adzw(nz) -do j=1,ny - do i=1,nx - flx(i,j,0)=fluxb(i,j)*rdz*rhow(1) - flx(i,j,nzm)=fluxt(i,j)*rdz*tmp*rhow(nz) - flux(1) = flux(1) + flx(i,j,0) - end do -end do - - -do k=1,nzm-1 - kc=k+1 - flux(kc)=0. - rhoi = rhow(kc)/adzw(kc) - rdz5=0.5*rdz2 * grdf_z(k) - do j=1,ny - do i=1,nx - tkz=rdz5*(tkh(i,j,k)+tkh(i,j,kc)) - flx(i,j,k)=-tkz*(field(i,j,kc)-field(i,j,k))*rhoi - flux(kc) = flux(kc) + flx(i,j,k) - end do - end do -end do - -do k=1,nzm - kb=k-1 - rhoi = 1./(adz(k)*rho(k)) - do j=1,ny - do i=1,nx - dfdt(i,j,k)=dtn*(dfdt(i,j,k)-(flx(i,j,k)-flx(i,j,kb))*rhoi) - field(i,j,k)=field(i,j,k)+dfdt(i,j,k) - end do - end do -end do - -end subroutine diffuse_scalar3D diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar3D_xy.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar3D_xy.F90 deleted file mode 100644 index e9f0db80c7..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar3D_xy.F90 +++ /dev/null @@ -1,146 +0,0 @@ -subroutine diffuse_scalar3D_xy (field,fluxb,fluxt,tkh,rho,rhow,flux) - -use crmx_grid -use crmx_params, only: docolumn,dowallx,dowally,dosgs -use crmx_sgs, only: grdf_x,grdf_y,grdf_z -implicit none -! input -real field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real tkh(0:nxp1,1-YES3D:nyp1,nzm) ! eddy conductivity -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real rho(nzm) -real rhow(nz) -real flux(nz) -! local -real flx(0:nx,0:ny,0:nzm) -real dfdt(nx,ny,nz) -real rdx2,rdy2,rdz2,rdz,rdx5,rdy5,rdz5,tmp -real dxy,dxz,dyx,dyz,dzx,dzy,tkx,tky,tkz,rhoi -integer i,j,k,ib,ic,jb,jc,kc,kb - - -if(.not.dosgs) return - -rdx2=1./(dx*dx) -rdy2=1./(dy*dy) -rdz2=1./(dz*dz) -rdz=1./dz -dxy=dx/dy -dxz=dx/dz -dyx=dy/dx -dyz=dy/dz -dzx=dz/dx -dzy=dz/dy - -dfdt(:,:,:)=0. - -!----------------------------------------- -if(dowallx) then - - if(mod(rank,nsubdomains_x).eq.0) then - do k=1,nzm - do j=1,ny - field(0,j,k) = field(1,j,k) - end do - end do - end if - if(mod(rank,nsubdomains_x).eq.nsubdomains_x-1) then - do k=1,nzm - do j=1,ny - field(nx+1,j,k) = field(nx,j,k) - end do - end do - end if - -end if - -if(dowally) then - - if(rank.lt.nsubdomains_x) then - do k=1,nzm - do i=1,nx - field(i,1-YES3D,k) = field(i,1,k) - end do - end do - end if - if(rank.gt.nsubdomains-nsubdomains_x-1) then - do k=1,nzm - do i=1,ny - field(i,ny+YES3D,k) = field(i,ny,k) - end do - end do - end if - -end if - - - -if(dowally) then - - call task_rank_to_index(rank, ib, jb) - if(jb.eq.0) then - do k=1,nzm - do i=1,nx - field(i,1-YES3D,k) = field(i,1,k) - end do - end do - end if - if(jb.eq.nsubdomains_y-1) then - do k=1,nzm - do i=1,nx - field(i,ny+YES3D,k) = field(i,ny,k) - end do - end do - end if - -end if - -!----------------------------------------- - - -! Horizontal diffusion: - - -do k=1,nzm - - rdx5=0.5*rdx2 * grdf_x(k) - rdy5=0.5*rdy2 * grdf_y(k) - - do j=1,ny - do i=0,nx - ic=i+1 - tkx=rdx5*(tkh(i,j,k)+tkh(ic,j,k)) - flx(i,j,k)=-tkx*(field(ic,j,k)-field(i,j,k)) - end do - do i=1,nx - ib=i-1 - dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(ib,j,k)) - end do - end do - - do j=0,ny - jc=j+1 - do i=1,nx - tky=rdy5*(tkh(i,j,k)+tkh(i,jc,k)) - flx(i,j,k)=-tky*(field(i,jc,k)-field(i,j,k)) - end do - end do - do j=1,ny - jb=j-1 - do i=1,nx - dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(i,jb,k)) - end do - end do - - do j=1, ny - do i=1, nx - field(i,j,k) = field(i,j,k) + dfdt(i,j,k) * dtn - end do - end do - -end do ! k - -flux = 0.0 - -end subroutine diffuse_scalar3D_xy diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar3D_z.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar3D_z.F90 deleted file mode 100644 index d8066cc750..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar3D_z.F90 +++ /dev/null @@ -1,76 +0,0 @@ -subroutine diffuse_scalar3D_z (field,fluxb,fluxt,tkh,rho,rhow,flux) - -use crmx_grid -use crmx_params, only: docolumn,dowallx,dowally,dosgs -use crmx_sgs, only: grdf_x,grdf_y,grdf_z -implicit none -! input -real field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real tkh(0:nxp1,1-YES3D:nyp1,nzm) ! eddy conductivity -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real rho(nzm) -real rhow(nz) -real flux(nz) -! local -real flx(0:nx,0:ny,0:nzm) -real dfdt(nx,ny,nz) -real rdx2,rdy2,rdz2,rdz,rdx5,rdy5,rdz5,tmp -real dxy,dxz,dyx,dyz,dzx,dzy,tkx,tky,tkz,rhoi -integer i,j,k,ib,ic,jb,jc,kc,kb - - -if(.not.dosgs) return - -rdx2=1./(dx*dx) -rdy2=1./(dy*dy) -rdz2=1./(dz*dz) -rdz=1./dz -dxy=dx/dy -dxz=dx/dz -dyx=dy/dx -dyz=dy/dz -dzx=dz/dx -dzy=dz/dy - -dfdt(:,:,:)=0. - -! Vertical diffusion: - -flux(1) = 0. -tmp=1./adzw(nz) -do j=1,ny - do i=1,nx - flx(i,j,0)=fluxb(i,j)*rdz*rhow(1) - flx(i,j,nzm)=fluxt(i,j)*rdz*tmp*rhow(nz) - flux(1) = flux(1) + flx(i,j,0) - end do -end do - - -do k=1,nzm-1 - kc=k+1 - flux(kc)=0. - rhoi = rhow(kc)/adzw(kc) - rdz5=0.5*rdz2 * grdf_z(k) - do j=1,ny - do i=1,nx - tkz=rdz5*(tkh(i,j,k)+tkh(i,j,kc)) - flx(i,j,k)=-tkz*(field(i,j,kc)-field(i,j,k))*rhoi - flux(kc) = flux(kc) + flx(i,j,k) - end do - end do -end do - -do k=1,nzm - kb=k-1 - rhoi = 1./(adz(k)*rho(k)) - do j=1,ny - do i=1,nx - dfdt(i,j,k)=dtn*(dfdt(i,j,k)-(flx(i,j,k)-flx(i,j,kb))*rhoi) - field(i,j,k)=field(i,j,k)+dfdt(i,j,k) - end do - end do -end do - -end subroutine diffuse_scalar3D_z diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar_xy.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar_xy.F90 deleted file mode 100644 index 2d3944e1f4..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar_xy.F90 +++ /dev/null @@ -1,53 +0,0 @@ -subroutine diffuse_scalar_xy (f,fluxb,fluxt, & - fdiff,flux,f2lediff,f2lediss,fwlediff,doit) - -use crmx_grid -use crmx_vars, only: rho, rhow -use crmx_sgs, only: tkh -implicit none - -! input: -real f(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real flux(nz) -real fdiff(nz) -real f2lediff(nz) -real f2lediss(nz) -real fwlediff(nz) -logical doit -! Local -real df(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real f0(nzm),df0(nzm),factor_xy -real r2dx,r2dy,r2dx0,r2dy0,r2dz -integer i,j,k,kb,kc,jb,jc - -!call t_startf ('diffuse_scalars_xy') - - - do k=1,nzm - do j=dimy1_s,dimy2_s - do i=dimx1_s,dimx2_s - df(i,j,k) = f(i,j,k) - end do - end do - end do - -if(RUN3D) then - call diffuse_scalar3D_xy (f,fluxb,fluxt,tkh,rho,rhow,flux) -else - call diffuse_scalar2D_xy (f,fluxb,fluxt,tkh,rho,rhow,flux) -endif - - do k=1,nzm - fdiff(k)=0. - do j=1,ny - do i=1,nx - fdiff(k)=fdiff(k)+f(i,j,k)-df(i,j,k) - end do - end do - end do - -!call t_stopf ('diffuse_scalars_xy') - -end subroutine diffuse_scalar_xy diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar_z.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar_z.F90 deleted file mode 100644 index e74aa7f2b5..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_diffuse_scalar_z.F90 +++ /dev/null @@ -1,70 +0,0 @@ -subroutine diffuse_scalar_z (f,fluxb,fluxt, & - fdiff,flux,f2lediff,f2lediss,fwlediff,doit) - -use crmx_grid -use crmx_vars, only: rho, rhow -use crmx_sgs, only: tkh -#ifdef CLUBB_CRM -use crmx_sgs, only: tkh_clubb -use crmx_params, only: doclubb -#endif -implicit none - -! input: -real f(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real flux(nz) -real fdiff(nz) -real f2lediff(nz) -real f2lediss(nz) -real fwlediff(nz) -logical doit -! Local -real df(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real tkhtemp(0:nxp1, 1-YES3D:nyp1, nzm) ! eddy diffusivity -real f0(nzm),df0(nzm),factor_xy -real f2lediss_z(nzm) -real r2dx,r2dy,r2dx0,r2dy0,r2dz -integer i,j,k,kb,kc,jb,jc - -!call t_startf ('diffuse_scalars_z') - -tkhtemp = 0.0 -#ifndef CLUBB_CRM -tkhtemp(:, :, :) = tkh(:, :, :) -#else -if(doclubb) then - tkhtemp(:, :, :) = tkh_clubb(:, :, :) -else - tkhtemp(:, :, :) = tkh(:, :, :) -endif -#endif - - do k=1,nzm - do j=dimy1_s,dimy2_s - do i=dimx1_s,dimx2_s - df(i,j,k) = f(i,j,k) - end do - end do - end do - - -if(RUN3D) then - call diffuse_scalar3D_z (f,fluxb,fluxt,tkhtemp,rho,rhow,flux) -else - call diffuse_scalar2D_z (f,fluxb,fluxt,tkhtemp,rho,rhow,flux) -endif - - do k=1,nzm - fdiff(k)=0. - do j=1,ny - do i=1,nx - fdiff(k)=fdiff(k)+f(i,j,k)-df(i,j,k) - end do - end do - end do - -!call t_stopf ('diffuse_scalars_z') - -end subroutine diffuse_scalar_z diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_fluxes_scalar_z.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_fluxes_scalar_z.F90 deleted file mode 100644 index 5cd9b14561..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_fluxes_scalar_z.F90 +++ /dev/null @@ -1,64 +0,0 @@ -subroutine fluxes_scalar_z (f,fluxb,fluxt, & - fdiff,flux,f2lediff,f2lediss,fwlediff,doit) - -!-------------------------------------------------------------------- -! This subroutine is only used to apply the surface fluxes for scalars. -! This is needed when surface fluxes are applied in the host model in SAM_CLUBB -! Here tkh is zet to zero so vertical diffusion is not calculated. -! Minghuai Wang, 2013-02 -!--------------------------------------------------------------------- - -use crmx_grid -use crmx_vars, only: rho, rhow -!use sgs, only: tkh -implicit none - -! input: -real f(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real flux(nz) -real fdiff(nz) -real f2lediff(nz) -real f2lediss(nz) -real fwlediff(nz) -logical doit -! Local -real df(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real f0(nzm),df0(nzm),factor_xy -real f2lediss_z(nzm) -real tkh2(0:nxp1, 1-YES3D:nyp1, nzm) ! eddy conductivity -real r2dx,r2dy,r2dx0,r2dy0,r2dz -integer i,j,k,kb,kc,jb,jc - -!call t_startf ('fluxes_scalars_z') - -tkh2 = 0.0 - - do k=1,nzm - do j=dimy1_s,dimy2_s - do i=dimx1_s,dimx2_s - df(i,j,k) = f(i,j,k) - end do - end do - end do - - -if(RUN3D) then - call diffuse_scalar3D_z (f,fluxb,fluxt,tkh2,rho,rhow,flux) -else - call diffuse_scalar2D_z (f,fluxb,fluxt,tkh2,rho,rhow,flux) -endif - - do k=1,nzm - fdiff(k)=0. - do j=1,ny - do i=1,nx - fdiff(k)=fdiff(k)+f(i,j,k)-df(i,j,k) - end do - end do - end do - -!call t_stopf ('fluxes_scalars_z') - -end subroutine fluxes_scalar_z diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_sgs.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_sgs.F90 deleted file mode 100644 index 82fb15ad33..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_sgs.F90 +++ /dev/null @@ -1,661 +0,0 @@ -module crmx_sgs - -! module for original SAM subgrid-scale SGS closure (Smagorinsky or 1st-order TKE) -! Marat Khairoutdinov, 2012 - -use crmx_grid, only: nx,nxp1,ny,nyp1,YES3D,nzm,nz,dimx1_s,dimx2_s,dimy1_s,dimy2_s -use crmx_params, only: dosgs -use crmx_vars, only: tke2, tk2 -#ifdef CLUBB_CRM -use crmx_clubbvars, only: khzt, khzm -use crmx_params, only: doclubb -#endif -implicit none - -!---------------------------------------------------------------------- -! Required definitions: - -!!! prognostic scalar (need to be advected arround the grid): - -integer, parameter :: nsgs_fields = 1 ! total number of prognostic sgs vars - -real sgs_field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm, nsgs_fields) - -!!! sgs diagnostic variables that need to exchange boundary information (via MPI): - -#ifndef CLUBB_CRM -integer, parameter :: nsgs_fields_diag = 2 ! total number of diagnostic sgs vars -#else -integer, parameter :: nsgs_fields_diag = 4 ! total number of diagnostic sgs vars -#endif - -! diagnostic fields' boundaries: -integer, parameter :: dimx1_d=0, dimx2_d=nxp1, dimy1_d=1-YES3D, dimy2_d=nyp1 - -real sgs_field_diag(dimx1_d:dimx2_d, dimy1_d:dimy2_d, nzm, nsgs_fields_diag) - -logical:: advect_sgs = .false. ! advect prognostics or not, default - not (Smagorinsky) -logical, parameter:: do_sgsdiag_bound = .true. ! exchange boundaries for diagnostics fields - -! SGS fields that output by default (if =1). -integer, parameter :: flag_sgs3Dout(nsgs_fields) = (/0/) -#ifndef CLUBB_CRM -integer, parameter :: flag_sgsdiag3Dout(nsgs_fields_diag) = (/0,0/) -#else -integer, parameter :: flag_sgsdiag3Dout(nsgs_fields_diag) = (/0,0,0,0/) -#endif - -real fluxbsgs (nx, ny, 1:nsgs_fields) ! surface fluxes -real fluxtsgs (nx, ny, 1:nsgs_fields) ! top boundary fluxes - -!!! these arrays may be needed for output statistics: - -real sgswle(nz,1:nsgs_fields) ! resolved vertical flux -real sgswsb(nz,1:nsgs_fields) ! SGS vertical flux -real sgsadv(nz,1:nsgs_fields) ! tendency due to vertical advection -real sgslsadv(nz,1:nsgs_fields) ! tendency due to large-scale vertical advection -real sgsdiff(nz,1:nsgs_fields) ! tendency due to vertical diffusion - -!------------------------------------------------------------------ -! internal (optional) definitions: - -! make aliases for prognostic variables: - -real tke(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! SGS TKE -equivalence (tke(dimx1_s,dimy1_s,1),sgs_field(dimx1_s,dimy1_s,1,1)) - -! make aliases for diagnostic variables: - -real tk (dimx1_d:dimx2_d, dimy1_d:dimy2_d, nzm) ! SGS eddy viscosity -real tkh (dimx1_d:dimx2_d, dimy1_d:dimy2_d, nzm) ! SGS eddy conductivity -equivalence (tk(dimx1_d,dimy1_d,1), sgs_field_diag(dimx1_d, dimy1_d,1,1)) -equivalence (tkh(dimx1_d,dimy1_d,1), sgs_field_diag(dimx1_d, dimy1_d,1,2)) -#ifdef CLUBB_CRM -real tk_clubb (dimx1_d:dimx2_d, dimy1_d:dimy2_d, nzm) ! SGS eddy viscosity -real tkh_clubb (dimx1_d:dimx2_d, dimy1_d:dimy2_d, nzm) ! SGS eddy conductivity -equivalence (tk_clubb(dimx1_d,dimy1_d,1), sgs_field_diag(dimx1_d, dimy1_d,1,3)) -equivalence (tkh_clubb(dimx1_d,dimy1_d,1), sgs_field_diag(dimx1_d, dimy1_d,1,4)) -#endif - -real grdf_x(nzm)! grid factor for eddy diffusion in x -real grdf_y(nzm)! grid factor for eddy diffusion in y -real grdf_z(nzm)! grid factor for eddy diffusion in z - -logical:: dosmagor ! if true, then use Smagorinsky closure - -! Local diagnostics: - -real tkesbbuoy(nz), tkesbshear(nz),tkesbdiss(nz), tkesbdiff(nz) - -CONTAINS - -! required microphysics subroutines and function: -!---------------------------------------------------------------------- -!!! Read microphysics options from prm (namelist) file - -subroutine sgs_setparm() - - use crmx_grid, only: case - implicit none - - integer ierr, ios, ios_missing_namelist, place_holder - - !====================================================================== - ! UW ADDITION - NAMELIST /SGS_TKE/ & - dosmagor ! Diagnostic Smagorinsky closure - - NAMELIST /BNCUIODSBJCB/ place_holder - - dosmagor = .true. ! default - - !---------------------------------- - ! Read namelist for microphysics options from prm file: - !------------ - !open(55,file='./'//trim(case)//'/prm', status='old',form='formatted') - - !read (UNIT=55,NML=BNCUIODSBJCB,IOSTAT=ios_missing_namelist) - !rewind(55) !note that one must rewind before searching for new namelists - - !read (55,SGS_TKE,IOSTAT=ios) - - advect_sgs = .not.dosmagor - - !if (ios.ne.0) then - ! !namelist error checking - ! if(ios.ne.ios_missing_namelist) then - ! write(*,*) '****** ERROR: bad specification in SGS_TKE namelist' - ! call task_abort() - ! end if - !end if - !close(55) - - ! END UW ADDITION - !====================================================================== - -end subroutine sgs_setparm - -!---------------------------------------------------------------------- -!!! Initialize sgs: - - -subroutine sgs_init() - - use crmx_grid, only: nrestart, dx, dy, dz, adz, masterproc - use crmx_params, only: LES -#ifdef CLUBB_CRM - use crmx_params, only: doclubb -#endif - integer k - - if(nrestart.eq.0) then - - sgs_field = 0. - sgs_field_diag = 0. - - fluxbsgs = 0. - fluxtsgs = 0. - - end if - -! if(masterproc) then -! if(dosmagor) then -! write(*,*) 'Smagorinsky SGS Closure' -! else -! write(*,*) 'Prognostic TKE 1.5-order SGS Closure' -! end if -!#ifdef CLUBB_CRM -! if ( doclubb ) then -! write(*,*) 'CLUBB Parameterization' -! end if -!#endif -! end if - - if(LES) then - do k=1,nzm - grdf_x(k) = dx**2/(adz(k)*dz)**2 - grdf_y(k) = dy**2/(adz(k)*dz)**2 - grdf_z(k) = 1. - end do - else - do k=1,nzm - grdf_x(k) = min(16.,dx**2/(adz(k)*dz)**2) - grdf_y(k) = min(16.,dy**2/(adz(k)*dz)**2) - grdf_z(k) = 1. - end do - end if - - sgswle = 0. - sgswsb = 0. - sgsadv = 0. - sgsdiff = 0. - sgslsadv = 0. - - -end subroutine sgs_init - -!---------------------------------------------------------------------- -!!! make some initial noise in sgs: -! -subroutine setperturb_sgs(ptype) - -use crmx_vars, only: q0, z -integer, intent(in) :: ptype -integer i,j,k - -select case (ptype) - - case(0) - - do k=1,nzm - do j=1,ny - do i=1,nx - if(k.le.4.and..not.dosmagor) then - tke(i,j,k)=0.04*(5-k) - endif - end do - end do - end do - - case(1) - - do k=1,nzm - do j=1,ny - do i=1,nx - if(q0(k).gt.6.e-3.and..not.dosmagor) then - tke(i,j,k)=1. - endif - end do - end do - end do - - case(2) - - case(3) ! gcss wg1 smoke-cloud case - - do k=1,nzm - do j=1,ny - do i=1,nx - if(q0(k).gt.0.5e-3.and..not.dosmagor) then - tke(i,j,k)=1. - endif - end do - end do - end do - - - case(4) ! gcss wg1 arm case - - do k=1,nzm - do j=1,ny - do i=1,nx - if(z(k).le.150..and..not.dosmagor) then - tke(i,j,k)=0.15*(1.-z(k)/150.) - endif - end do - end do - end do - - - case(5) ! gcss wg1 BOMEX case - - do k=1,nzm - do j=1,ny - do i=1,nx - if(z(k).le.3000..and..not.dosmagor) then - tke(i,j,k)=1.-z(k)/3000. - endif - end do - end do - end do - - case(6) ! GCSS Lagragngian ASTEX - - - do k=1,nzm - do j=1,ny - do i=1,nx - if(q0(k).gt.6.e-3.and..not.dosmagor) then - tke(i,j,k)=1. - endif - end do - end do - end do - - - case default - -end select - -end subroutine setperturb_sgs - -!---------------------------------------------------------------------- -!!! Estimate Courant number limit for SGS -! - -subroutine kurant_sgs(cfl) - -use crmx_grid, only: dt, dx, dy, dz, adz, adzw -implicit none - -real, intent(out) :: cfl - -integer k -real tkhmax(nz) - -do k = 1,nzm - tkhmax(k) = maxval(tkh(1:nx,1:ny,k)) -end do - -cfl = 0. -do k=1,nzm - cfl = max(cfl, & - 0.5*tkhmax(k)*grdf_z(k)*dt/(dz*adzw(k))**2, & - 0.5*tkhmax(k)*grdf_x(k)*dt/dx**2, & - YES3D*0.5*tkhmax(k)*grdf_y(k)*dt/dy**2) -end do - -end subroutine kurant_sgs - - -!---------------------------------------------------------------------- -!!! compute sgs diffusion of momentum: -! -subroutine sgs_mom() -#ifdef CLUBB_CRM - use crmx_params, only: doclubb - use crmx_clubb_sgs, only: apply_clubb_sgs_tndcy_mom - use crmx_vars, only: dudt, dvdt -#endif - -#ifdef CLUBB_CRM - if ( doclubb ) then -! call apply_clubb_sgs_tndcy_mom & -! ( dudt, dvdt ) ! in/out - endif -#endif /*CLUBB_CRM*/ - - call diffuse_mom() - -end subroutine sgs_mom - -!---------------------------------------------------------------------- -!!! compute sgs diffusion of scalars: -! -subroutine sgs_scalars() - - use crmx_vars - use crmx_microphysics - use crmx_crmtracers - use crmx_params, only: dotracers, doclubb, doclubb_sfc_fluxes, doclubbnoninter, docam_sfc_fluxes -#ifdef CLUBB_CRM - use crmx_clubbvars, only: edsclr_dim, sclr_dim - use crmx_clubb_sgs, only: total_energy - use crmx_clubb_sgs, only: apply_clubb_sgs_tndcy_scalars - use crmx_grid, only: dtn - use crmx_clubb_precision, only: time_precision -#endif /*CLUBB_CRM*/ - implicit none - - real dummy(nz) - real f2lediff_xy(nz), f2lediss_xy(nz), fwlediff_xy(nz) - real f2lediff_z(nz), f2lediss_z(nz), fwlediff_z(nz) - real sdiff_xy(nz), sdiff_z(nz) - real fluxbtmp(nx,ny), fluxttmp(nx,ny) !bloss - integer k - - -#ifdef CLUBB_CRM - total_energy_evap = total_energy_evap - total_energy(t) -#endif - -! Update for t, qv, qcl from clubb_sgs -#ifdef CLUBB_CRM - if ( doclubb ) then - - ! Recalculate q, qv, qcl based on new micro_fields (updated by horizontal - ! diffusion) - call micro_update() - - ! Then Re-compute q/qv/qcl based on values computed in CLUBB - call apply_clubb_sgs_tndcy_scalars & - ( real( dtn, kind=time_precision), & ! in - t, qv, qcl) ! in/out - - call micro_adjust( qv, qcl ) ! in - end if -#endif /*CLUBB_CRM*/ - - f2lediff_xy = 0.0 - f2lediss_xy = 0.0 - fwlediff_xy = 0.0 - -! call diffuse_scalar(t,fluxbt,fluxtt,tdiff,twsb, & -! t2lediff,t2lediss,twlediff,.true.) - call diffuse_scalar_xy(t,fluxbt,fluxtt,tdiff_xy,twsb, & - f2lediff_xy,f2lediss_xy,fwlediff_xy,.true.) - f2lediff_z =0.0 - f2lediss_z =0.0 - fwlediff_z =0.0 -#ifdef CLUBB_CRM - ! Diffuse moist static energy in the vertical only if CLUBB is not being - ! called - if ( .not. doclubb ) then - call diffuse_scalar_z(t,fluxbt,fluxtt,tdiff_z,twsb, & - f2lediff_z,f2lediss_z,fwlediff_z,.true.) - else ! doclubb - if(doclubb_sfc_fluxes .or. docam_sfc_fluxes) then - ! The flux will be applied in advance_clubb_core, so the 2nd argument - ! is zero. - call fluxes_scalar_z(t,fzero,fluxtt,tdiff_z,twsb, & - f2lediff_z,f2lediss_z,fwlediff_z,.true.) - else - call fluxes_scalar_z(t,fluxbt,fluxtt,tdiff_z,twsb, & - f2lediff_z,f2lediss_z,fwlediff_z,.true.) - end if - end if -#else - call diffuse_scalar_z(t,fluxbt,fluxtt,tdiff_z,twsb, & - f2lediff_z,f2lediss_z,fwlediff_z,.true.) -#endif - - tdiff = tdiff_xy + tdiff_z - - t2lediff = f2lediff_xy + f2lediff_z - t2lediss = f2lediss_xy + f2lediss_z - twlediff = fwlediff_xy + fwlediff_z - -#ifdef CLUBB_CRM - total_energy_evap = total_energy_evap + total_energy(t) -#endif - - if(advect_sgs) then -! call diffuse_scalar(tke,fzero,fzero,dummy,sgswsb, & -! dummy,dummy,dummy,.false.) - call diffuse_scalar_xy(tke,fzero,fzero,dummy,sgswsb, & - dummy,dummy,dummy,.false.) - call diffuse_scalar_z(tke,fzero,fzero,dummy,sgswsb, & - dummy,dummy,dummy,.false.) - end if - - -! -! diffusion of microphysics prognostics: -! - call micro_flux() - - total_water_evap = total_water_evap - total_water() - - do k = 1,nmicro_fields - if( k.eq.index_water_vapor &! transport water-vapor variable no metter what -#ifdef CLUBB_CRM - .or. ( docloud.or.doclubb.or.doclubbnoninter ).and.flag_precip(k).ne.1 & ! transport non-precipitation vars -#else - .or. docloud.and.flag_precip(k).ne.1 & ! transport non-precipitation vars -#endif - - .or. doprecip.and.flag_precip(k).eq.1 ) then - - fluxbtmp(1:nx,1:ny) = fluxbmk(1:nx,1:ny,k) - fluxttmp(1:nx,1:ny) = fluxtmk(1:nx,1:ny,k) - sdiff_xy = 0.0 - sdiff_z = 0.0 - -! call diffuse_scalar(micro_field(:,:,:,k),fluxbtmp,fluxttmp, & -! mkdiff(:,k),mkwsb(:,k), dummy,dummy,dummy,.false.) - call diffuse_scalar_xy(micro_field(:,:,:,k),fluxbtmp,fluxttmp, & - sdiff_xy,mkwsb(:,k), dummy,dummy,dummy,.false.) - if(k.ne.index_water_vapor) then - call diffuse_scalar_z(micro_field(:,:,:,k),fluxbtmp,fluxttmp, & - sdiff_z,mkwsb(:,k), dummy,dummy,dummy,.false.) - else ! k==index_water_vapor - if(.not. doclubb) then - call diffuse_scalar_z(micro_field(:,:,:,k),fluxbtmp,fluxttmp, & - sdiff_z,mkwsb(:,k), dummy,dummy,dummy,.false.) - else ! doclubb - call fluxes_scalar_z(micro_field(:,:,:,k),fluxbtmp,fluxttmp, & - sdiff_z,mkwsb(:,k), dummy,dummy,dummy,.false.) - end if - end if - mkdiff(:, k) = sdiff_xy + sdiff_z - end if - end do - - total_water_evap = total_water_evap + total_water() - - ! diffusion of tracers: - - if(dotracers) then - - call tracers_flux() - - do k = 1,ntracers - -#ifdef CLUBB_CRM - ! If CLUBB is using the high-order or eddy diffusivity scalars, then - ! we should apply the flux within advance_clubb_core when - ! doclubb_sfc_fluxes is set to true. -dschanen UWM 2 Mar 2010 - if ( ( edsclr_dim > 0 .or. sclr_dim > 0 ) .and. (doclubb_sfc_fluxes .or. docam_sfc_fluxes)) then - fluxbtmp = 0. ! Apply surface flux in CLUBB - else - fluxbtmp = fluxbtr(:,:,k) - end if -#else - fluxbtmp = fluxbtr(:,:,k) -#endif /*CLUBB_CRM*/ - fluxttmp = fluxttr(:,:,k) -! call diffuse_scalar(tracer(:,:,:,k),fluxbtmp,fluxttmp, & -! trdiff(:,k),trwsb(:,k), & -! dummy,dummy,dummy,.false.) - call diffuse_scalar_xy(tracer(:,:,:,k),fluxbtmp,fluxttmp, & - trdiff(:,k),trwsb(:,k), & - dummy,dummy,dummy,.false.) - -#ifdef CLUBB_CRM - ! Only diffuse the tracers if CLUBB is either disabled or using the - ! eddy scalars code to diffuse them. - if ( .not. doclubb .or. ( doclubb .and. edsclr_dim < 1 .and. sclr_dim < 1 ) ) then - call diffuse_scalar_z(tracer(:,:,:,k),fluxbtmp,fluxttmp, & - trdiff(:,k),trwsb(:,k), & - dummy,dummy,dummy,.false.) - end if -#else - call diffuse_scalar_z(tracer(:,:,:,k),fluxbtmp,fluxttmp, & - trdiff(:,k),trwsb(:,k), & - dummy,dummy,dummy,.false.) -#endif -!!$ call diffuse_scalar(tracer(:,:,:,k),fluxbtr(:,:,k),fluxttr(:,:,k),trdiff(:,k),trwsb(:,k), & -!!$ dummy,dummy,dummy,.false.) - - end do - - end if - - - -end subroutine sgs_scalars - -!---------------------------------------------------------------------- -!!! compute sgs processes (beyond advection): -! -subroutine sgs_proc() - - use crmx_grid, only: nstep,dt,icycle - use crmx_params, only: dosmoke -#ifdef CLUBB_CRM - use crmx_clubbvars, only: khzt, khzm - use crmx_microphysics - use crmx_params, only: doclubb, doclubbnoninter, nclubb - use crmx_grid, only: dtn, time, dt - use crmx_vars, only: u, v, w, rho, rhow, wsub, qpl, qci, qpi, t, qv, qcl - use crmx_clubb_precision, only: time_precision - use crmx_clubb_sgs, only: advance_clubb_sgs -#endif - -! SGS CLUBB -#ifdef CLUBB_CRM - if ( doclubb .or. doclubbnoninter ) then - ! In case of ice fall, we recompute qci here for the - ! single-moment scheme. Also, subsidence, diffusion and advection have - ! been applied to micro_field but not qv/qcl so they must be updated. - call micro_update() - - ! We call CLUBB here because adjustments to the wind - ! must occur prior to adams() -dschanen 26 Aug 2008 - ! Here we call clubb only if nstep divides the current timestep, - ! or we're on the very first timestep - -! in the case with m2005, clubb is only called in the first subscycle (icycle=1)) - if ( ((nstep == 1 .or. mod( nstep, nclubb ) == 0) .and. & - (icycle == 1)).and.(nclubb .ne. 1) ) then ! call every CRM step, so dt is used - call advance_clubb_sgs & - ( real( dt*real( nclubb ), kind=time_precision), & ! in - real( 0., kind=time_precision ), & ! in - real( time, kind=time_precision ), & ! in - rho, rhow, wsub, u, v, w, qpl, qci, qpi, & ! in - t, qv, qcl ) ! in - else if(nclubb.eq.1) then ! call every icycle, so dtn is used - call advance_clubb_sgs & - ( real( dtn*real( nclubb ), kind=time_precision), & ! in - real( 0., kind=time_precision ), & ! in - real( time, kind=time_precision ), & ! in - rho, rhow, wsub, u, v, w, qpl, qci, qpi, & ! in - t, qv, qcl ) ! in - end if ! nstep == 1 .or. mod( nstep, nclubb) == 0 - - end if ! doclubb .or. doclubbnoninter -#endif - -! SGS TKE equation: - - if(dosgs) call tke_full() - - tke2 = tke - tk2 = tk - -#ifdef CLUBB_CRM - if(doclubb) then -! tk = khzt -! tkh = khzt - -! tk_clubb = khzt -! tkh_clubb = khzt - tk_clubb = khzm - tkh_clubb = khzm - end if -#endif - - -end subroutine sgs_proc - -!---------------------------------------------------------------------- -!!! Diagnose arrays nessesary for dynamical core and statistics: -! -subroutine sgs_diagnose() -! None - -end subroutine sgs_diagnose - -!---------------------------------------------------------------------- -! called when stepout() called - -subroutine sgs_print() - - call fminmax_print('tke:',tke,dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm) - call fminmax_print('tk:',tk,0,nxp1,1-YES3D,nyp1,nzm) - call fminmax_print('tkh:',tkh,0,nxp1,1-YES3D,nyp1,nzm) - -end subroutine sgs_print - -!---------------------------------------------------------------------- -!!! Initialize the list of sgs statistics -! -subroutine sgs_hbuf_init(namelist,deflist,unitlist,status,average_type,count,sgscount) -character(*) namelist(*), deflist(*), unitlist(*) -integer status(*),average_type(*),count,sgscount - -character*8 name -character*80 longname -character*10 units - -#ifdef CLUBB -if (doclubb) then -name = 'TKCLUBB' -longname = 'Eddy diffusivity from CLUBB' -units = 'm2/s' -call add_to_namelist(count,sgscount,name,longname,units,0) - -name = 'TKHCLUBB' -longname = 'Eddy diffusivity from CLUBB' -units = 'm2/s' -call add_to_namelist(count,sgscount,name,longname,units,0) -end if -#endif - -end subroutine sgs_hbuf_init - - -end module crmx_sgs - - - diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_shear_prod2D.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_shear_prod2D.F90 deleted file mode 100644 index 50fe343ebe..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_shear_prod2D.F90 +++ /dev/null @@ -1,109 +0,0 @@ - -subroutine shear_prod2D(def2) - -use crmx_vars -implicit none - -real def2(nx,ny,nzm) - -real rdx0,rdx,rdx_up,rdx_dn -real rdz,rdzw_up,rdzw_dn -integer i,j,k,ib,ic,kb,kc - -rdx0=1./dx -j=1 - - -do k=2,nzm-1 - - kb=k-1 - kc=k+1 - rdz = 1./(dz*adz(k)) - rdzw_up = 1./(dz*adzw(kc)) - rdzw_dn = 1./(dz*adzw(k)) - rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy - rdx_up=rdx0 * sqrt(dx*rdzw_up) - rdx_dn=rdx0 * sqrt(dx*rdzw_dn) - - do i=1,nx - ib=i-1 - ic=i+1 - - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.5 * ( & - ( (v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (v(i ,j ,k)-v(ib,j ,k))*rdx )**2 + & - ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ & - (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + & - ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ & - (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 + & - ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ & - (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + & - ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ & - (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 + & - ( (v(i,j ,kc)-v0(kc)-v(i,j , k)+v0(k))*rdzw_up )**2 + & - ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn )**2 ) - - end do -end do ! k - - -k=1 -kc=k+1 - -rdz = 1./(dz*adz(k)) -rdzw_up = 1./(dz*adzw(kc)) -rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy -rdx_up=rdx0 * sqrt(dx*rdzw_up) - -do i=1,nx - ib=i-1 - ic=i+1 - - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.5 * ( & - ( (v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) & - +( (v(i,j ,kc)-v0(kc)-v(i,j,k)+v0(k))*rdzw_up )**2 & - + 0.5 * ( & - ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ & - (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + & - ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ & - (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 ) -end do - -k=nzm -kc=k+1 -kb=k-1 - -rdz = 1./(dz*adz(k)) -rdzw_dn = 1./(dz*adzw(k)) -rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy -rdx_dn=rdx0 * sqrt(dx*rdzw_dn) - - -do i=1,nx - ib=i-1 - ic=i+1 - - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.5 * ( & - ( (v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) & - + ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn )**2 & - + 0.5 * ( & - ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ & - (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + & - ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ & - (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 ) - -end do - -end - diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_shear_prod3D.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_shear_prod3D.F90 deleted file mode 100644 index 2ecd9c25a6..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_shear_prod3D.F90 +++ /dev/null @@ -1,155 +0,0 @@ - -subroutine shear_prod3D(def2) - -use crmx_vars -implicit none - -real def2(nx,ny,nzm) - -real rdx0,rdx,rdx_up,rdx_dn -real rdy0,rdy,rdy_up,rdy_dn -real rdz,rdzw_up,rdzw_dn -integer i,j,k,ib,ic,jb,jc,kb,kc - -rdx0=1./dx -rdy0=1./dy - -do k=2,nzm-1 - - kb=k-1 - kc=k+1 - rdz = 1./(dz*adz(k)) - rdzw_up = 1./(dz*adzw(kc)) - rdzw_dn = 1./(dz*adzw(k)) - rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy - rdy=rdy0 * sqrt(dy*rdz) - rdx_up=rdx0 * sqrt(dx*rdzw_up) - rdy_up=rdy0 * sqrt(dy*rdzw_up) - rdx_dn=rdx0 * sqrt(dx*rdzw_dn) - rdy_dn=rdy0 * sqrt(dy*rdzw_dn) - - do j=1,ny - jb=j-YES3D - jc=j+YES3D - do i=1,nx - ib=i-1 - ic=i+1 - - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (v(i,jc,k)-v(i,j,k))*rdy)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.25 * ( & - ( (u(ic,jc,k)-u(ic,j ,k))*rdy+(v(ic,jc,k)-v(i ,jc,k))*rdx )**2 + & - ( (u(i ,jc,k)-u(i ,j ,k))*rdy+(v(i ,jc,k)-v(ib,jc,k))*rdx )**2 + & - ( (u(ic,j ,k)-u(ic,jb,k))*rdy+(v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (u(i ,j ,k)-u(i ,jb,k))*rdy+(v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) - def2(i,j,k)=def2(i,j,k) & - + 0.25 * ( & - ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ & - (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + & - ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ & - (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 + & - ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ & - (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + & - ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ & - (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 ) - def2(i,j,k)=def2(i,j,k) & - + 0.25 * ( & - ( (v(i,jc,kc)-v0(kc)-v(i,jc, k)+v0(k))*rdzw_up+ & - (w(i,jc,kc)-w(i,j ,kc))*rdy_up )**2 + & - ( (v(i,j ,kc)-v0(kc)-v(i,j , k)+v0(k))*rdzw_up+ & - (w(i,j ,kc)-w(i,jb,kc))*rdy_up )**2 + & - ( (v(i,jc,k )-v0(k)-v(i,jc,kb)+v0(kb))*rdzw_dn+ & - (w(i,jc,k )-w(i,j ,k ))*rdy_dn )**2 + & - ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn+ & - (w(i,j ,k )-w(i,jb,k ))*rdy_dn )**2 ) - - end do - end do -end do ! k - - -k=1 -kc=k+1 - -rdz = 1./(dz*adz(k)) -rdzw_up = 1./(dz*adzw(kc)) -rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy -rdy=rdy0 * sqrt(dy*rdz) -rdx_up=rdx0 * sqrt(dx*rdzw_up) -rdy_up=rdy0 * sqrt(dy*rdzw_up) - -do j=1,ny - jb=j-YES3D - jc=j+YES3D - do i=1,nx - ib=i-1 - ic=i+1 - - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (v(i,jc,k)-v(i,j,k))*rdy)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.25 * ( & - ( (u(ic,jc,k)-u(ic,j ,k))*rdy+(v(ic,jc,k)-v(i ,jc,k))*rdx )**2 + & - ( (u(i ,jc,k)-u(i ,j ,k))*rdy+(v(i ,jc,k)-v(ib,jc,k))*rdx )**2 + & - ( (u(ic,j ,k)-u(ic,jb,k))*rdy+(v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (u(i ,j ,k)-u(i ,jb,k))*rdy+(v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) & - + 0.5 * ( & - ( (v(i,jc,kc)-v0(kc)-v(i,jc, k)+v0(k))*rdzw_up+ & - (w(i,jc,kc)-w(i,j ,kc))*rdy_up )**2 + & - ( (v(i,j ,kc)-v0(kc)-v(i,j , k)+v0(k))*rdzw_up+ & - (w(i,j ,kc)-w(i,jb,kc))*rdy_up )**2 ) & - + 0.5 * ( & - ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ & - (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + & - ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ & - (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 ) - - - end do -end do - - -k=nzm -kc=k+1 -kb=k-1 - -rdz = 1./(dz*adz(k)) -rdzw_dn = 1./(dz*adzw(k)) -rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy -rdy=rdy0 * sqrt(dy*rdz) -rdx_dn=rdx0 * sqrt(dx*rdzw_dn) -rdy_dn=rdy0 * sqrt(dy*rdzw_dn) - -do j=1,ny - jb=j-1*YES3D - jc=j+1*YES3D - do i=1,nx - ib=i-1 - ic=i+1 - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (v(i,jc,k)-v(i,j,k))*rdy)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.25 * ( & - ( (u(ic,jc,k)-u(ic,j ,k))*rdy+(v(ic,jc,k)-v(i ,jc,k))*rdx )**2 + & - ( (u(i ,jc,k)-u(i ,j ,k))*rdy+(v(i ,jc,k)-v(ib,jc,k))*rdx )**2 + & - ( (u(ic,j ,k)-u(ic,jb,k))*rdy+(v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (u(i ,j ,k)-u(i ,jb,k))*rdy+(v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) & - + 0.5 * ( & - ( (v(i,jc,k )-v0(k)-v(i,jc,kb)+v0(kb))*rdzw_dn+ & - (w(i,jc,k )-w(i,j ,k ))*rdy_dn )**2 + & - ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn+ & - (w(i,j ,k )-w(i,jb,k ))*rdy_dn )**2 ) & - + 0.5 * ( & - ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ & - (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + & - ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ & - (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 ) - end do -end do - -end - diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_stat_clubb.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_stat_clubb.F90 deleted file mode 100644 index 8a0bb38481..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_stat_clubb.F90 +++ /dev/null @@ -1,1479 +0,0 @@ -! $Id: stat_clubb.F90 1070 2013-04-19 20:05:10Z minghuai.wang@pnl.gov $ -module crmx_stat_clubb -#ifdef CLUBB_CRM - use crmx_grid, only: nx, ny, nz, nzm - implicit none - - public :: stats_clubb_update - -#ifdef CLUBB_LH - public stats_clubb_silhs_update -#endif - - public :: stats_end_timestep_clubb, stats_init_clubb -#ifndef CRM - public :: hbuf_stats_init_clubb -#endif - - ! Output arrays for CLUBB statistics - real, allocatable, dimension(:,:,:,:) :: out_zt, out_zm, out_rad_zt, out_rad_zm, & - out_sfc, out_LH_zt, out_LH_sfc - - private - - contains -!--------------------------------------------------------------------------------------------------- - subroutine stats_clubb_update( upwp, vpwp, up2, vp2, wprtp, wpthlp, & - wp2, wp3, rtp2, thlp2, rtpthlp, cloud_frac, rcm, um, vm, t_tndcy, & - qc_tndcy, qv_tndcy,u_tndcy,v_tndcy ) - -! Description: -! Update statistics for CLUBB variables -! -! References: -! None -!--------------------------------------------------------------------------------------------------- - use crmx_grid, only: nx, ny, nzm, nz, dimx1_s, dimx2_s, dimy1_s, dimy2_s - -#ifndef CRM - use hbuffer, only: hbuf_put, hbuf_avg_put -#endif - - ! Modules from CLUBB - use crmx_clubb_precision, only: core_rknd ! Constant - - use crmx_interpolation, only: lin_int ! Procedure(s) - - use crmx_grid_class, only: gr - - use crmx_clubbvars, only: tndcy_precision, l_stats_samgrid - - implicit none - - real(kind=core_rknd), dimension(nx, ny, nz), intent(in) :: & - upwp, &! u'w' [m^2/s^2] - vpwp, &! u'w' [m^2/s^2] - up2, &! u'^2 [m^2/s^2] - vp2, &! v'^2 [m^2/s^2] - wprtp, &! w' r_t' [(m kg)/(s kg)] - wpthlp, &! w' th_l' [(m K)/s] - wp2, &! w'^2 [m^2/s^2] - rtp2, &! r_t'^2 [(kg/kg)^2] - thlp2, &! th_l'^2 [K^2] - rtpthlp, &! r_t' th_l' [(kg K)/kg] - cloud_frac, &! Cloud Fraction [-] - rcm ! Cloud water [kg/kg] - - ! w'^3 is requires additional ghost points on the x and y dimension - real(kind=core_rknd), dimension(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nz), intent(in) :: & - wp3,& ! w'^3 [m^3/s^3] - um, & ! x-wind [m/s] - vm ! y-wind [m/s] - - real(tndcy_precision), dimension(nx, ny, nzm), intent(in) :: & - t_tndcy, & ! CLUBB contribution to moist static energy [K/s] - qc_tndcy, & ! CLUBB contribution to liquid water [kg/kg/s] - qv_tndcy, & ! CLUBB contribution to vapor water [kg/kg/s] - u_tndcy, & ! CLUBB contribution to x-wind [m/s^2] - v_tndcy ! CLUBB contribution to y-wind [m/s^2] - - ! Local variables - real, dimension(nzm) :: & - upwp_avg, & - vpwp_avg, & - up2_avg, & - vp2_avg, & - wprtp_avg, & - wpthlp_avg, & - wp2_avg, & - thlp2_avg, & - rtp2_avg, & - rtpthlp_avg,& - sigma_sqd_w_avg, & - Kh_zt_avg, & - tau_zm_avg - - real :: factor_xy - - integer :: i, j, k - - !--------------------------------------------------------- - ! CLUBB variables - ! Notes: The variables located on the vertical velocity levels - ! must be interpolated for the stats grid, which is on the pressure levels. - ! -dschanen 21 Jul 2008 - factor_xy = 1. / real( nx*ny ) - - upwp_avg = 0.0 - vpwp_avg = 0.0 - vp2_avg = 0.0 - up2_avg = 0.0 - wprtp_avg = 0.0 - wpthlp_avg = 0.0 - wp2_avg = 0.0 - - thlp2_avg = 0.0 - rtp2_avg = 0.0 - rtpthlp_avg = 0.0 - - ! Here we omit the ghost point, since the SAM stats don't have one - do i = 1, nx - do j = 1, ny - do k = 1, nzm - upwp_avg(k) = upwp_avg(k) & - + lin_int( gr%zt(k+1), gr%zm(k+1), gr%zm(k), upwp(i,j,k+1), upwp(i,j,k) ) - vpwp_avg(k) = vpwp_avg(k) & - + lin_int( gr%zt(k+1), gr%zm(k+1), gr%zm(k), vpwp(i,j,k+1), vpwp(i,j,k) ) - vp2_avg(k) = vp2_avg(k) & - + lin_int( gr%zt(k+1), gr%zm(k+1), gr%zm(k), vp2(i,j,k+1), vp2(i,j,k) ) - up2_avg(k) = up2_avg(k) & - + lin_int( gr%zt(k+1), gr%zm(k+1), gr%zm(k), up2(i,j,k+1), up2(i,j,k) ) - wprtp_avg(k) = wprtp_avg(k) & - + lin_int( gr%zt(k+1), gr%zm(k+1), gr%zm(k), wprtp(i,j,k+1), wprtp(i,j,k) ) - wpthlp_avg(k) = wpthlp_avg(k) & - + lin_int( gr%zt(k+1), gr%zm(k+1), gr%zm(k), wpthlp(i,j,k+1), wpthlp(i,j,k) ) - wp2_avg(k) = wp2_avg(k) & - + lin_int( gr%zt(k+1), gr%zm(k+1), gr%zm(k), wp2(i,j,k+1), wp2(i,j,k) ) - rtp2_avg(k) = rtp2_avg(k) & - + lin_int( gr%zt(k+1), gr%zm(k+1), gr%zm(k), rtp2(i,j,k+1), rtp2(i,j,k) ) - thlp2_avg(k) = thlp2_avg(k) & - + lin_int( gr%zt(k+1), gr%zm(k+1), gr%zm(k), thlp2(i,j,k+1), thlp2(i,j,k) ) - rtpthlp_avg(k) = rtpthlp_avg(k) & - + lin_int( gr%zt(k+1), gr%zm(k+1), gr%zm(k), rtpthlp(i,j,k+1), rtpthlp(i,j,k) ) - end do ! k = 1..nzm - end do ! j = 1..ny - end do ! i = 1..nx - -#ifndef CRM - ! Velocity grid variables - call hbuf_put('UPWP', upwp_avg, factor_xy) - call hbuf_put('VPWP', vpwp_avg, factor_xy) - call hbuf_put('VP2', vp2_avg, factor_xy) - call hbuf_put('UP2', up2_avg, factor_xy) - call hbuf_put('WPRTP', wprtp_avg, factor_xy) - call hbuf_put('WPTHLP', wpthlp_avg, factor_xy) - call hbuf_put('WP2', wp2_avg, factor_xy) - call hbuf_put('RTP2', rtp2_avg, factor_xy) - call hbuf_put('THLP2', thlp2_avg, factor_xy) - call hbuf_put('RTPTHLP', rtpthlp_avg, factor_xy) - - ! CLUBB thermodynamic grid varibles (SAM pressure levels + ghost point) - call hbuf_avg_put('CLD_FRAC', real( cloud_frac(1:nx,1:ny,2:nz) ), 1,nx, 1,ny, nzm, 1.) - call hbuf_avg_put('RCM', real( rcm(1:nx,1:ny,2:nz) ), 1,nx, 1,ny, nzm, 1.) - call hbuf_avg_put('UM', real( um(1:nx,1:ny,2:nz) ), 1,nx, 1,ny, nzm, 1.) - call hbuf_avg_put('VM', real( vm(1:nx,1:ny,2:nz) ), 1,nx, 1,ny, nzm, 1.) - call hbuf_avg_put('WP3', real( wp3(1:nx,1:ny,2:nz) ), 1,nx, 1,ny, nzm, 1.) - - ! CLUBB tendency of state variables - call hbuf_avg_put('T_TNDCY', real(t_tndcy(1:nx,1:ny,1:nzm)), 1,nx, 1,ny, nzm, 1.) - call hbuf_avg_put('QC_TNDCY', real(qc_tndcy(1:nx,1:ny,1:nzm)), 1,nx, 1,ny, nzm, 1.) - call hbuf_avg_put('QV_TNDCY', real(qv_tndcy(1:nx,1:ny,1:nzm)), 1,nx, 1,ny, nzm, 1.) - call hbuf_avg_put('U_TNDCY', real(U_tndcy(1:nx,1:ny,1:nzm)), 1,nx, 1,ny, nzm, 1.) - call hbuf_avg_put('V_TNDCY', real(V_tndcy(1:nx,1:ny,1:nzm)), 1,nx, 1,ny, nzm, 1.) - - if(l_stats_samgrid) then !output clubb statistics in SAM - call hbuf_clubb_output () - end if -#endif - - return - end subroutine stats_clubb_update - -#ifdef CLUBB_LH -!--------------------------------------------------------------------------------------------------- - subroutine stats_clubb_silhs_update( ) - -! Description: -! Update statistics for CLUBB SILHS variables -! -! References: -! None -!--------------------------------------------------------------------------------------------------- - use crmx_grid, only: nx, ny, nzm, nz - - use hbuffer, only: hbuf_put, hbuf_avg_put - - use crmx_microphysics, only: & - nmicro_fields, mkname, index_water_vapor - - ! Modules from CLUBB - use crmx_clubb_precision, only: core_rknd ! Constant - - use crmx_interpolation, only: lin_int ! Procedure(s) - - use crmx_grid_class, only: gr - - use crmx_clubb_silhs_vars, only: & - LH_rt, LH_t, X_nl_all_levs, LH_sample_point_weights, LH_t_avg_tndcy, & - LH_micro_field_avg_tndcy - - use latin_hypercube_arrays, only: & - d_variables - - use crmx_parameters_microphys, only: & - LH_microphys_calls - - use crmx_corr_matrix_module, only: & - iiLH_s_mellor, iiLH_w, & - iiLH_rrain, iiLH_rsnow, iiLH_rice, & - iiLH_Nr, iiLH_Nsnow, iiLH_Ni, iiLH_Nc - - use crmx_array_index, only: & - iirrainm, iiNrm, iirsnowm, iiricem, & ! Variables - iiNcm, iiNsnowm, iiNim - - implicit none - - ! Local Variables - real, dimension(nx,ny,nzm) :: & - LH_rt_weighted, & - LH_t_weighted - - real, dimension(nx,ny,nzm,d_variables) :: & - X_nl_all_levs_weighted - - character(len=8) :: stat_name - integer :: indx, ivar, k - - ! ---- Begin Code ---- - - ! Determine cloud weighted sample averages - LH_rt_weighted = 0. - LH_t_weighted = 0. - X_nl_all_levs_weighted = 0. - - do indx = 1, LH_microphys_calls - do k = 1, nzm - LH_rt_weighted(:,:,k) = LH_rt_weighted(:,:,k) & - + LH_rt(:,:,k,indx) * LH_sample_point_weights(:,:,indx) - LH_t_weighted(:,:,k) = LH_t_weighted(:,:,k) & - + LH_t(:,:,k,indx) * LH_sample_point_weights(:,:,indx) - - do ivar = 1, d_variables - X_nl_all_levs_weighted(:,:,k,ivar) = X_nl_all_levs_weighted(:,:,k,ivar) & - + X_nl_all_levs(:,:,k,indx,ivar) * LH_sample_point_weights(:,:,indx) - end do - - end do ! k = 1..nzm - end do ! indx = 1..LH_microphys_calls - - LH_rt_weighted = LH_rt_weighted / real( LH_microphys_calls ) - LH_t_weighted = LH_t_weighted / real( LH_microphys_calls ) - X_nl_all_levs_weighted = X_nl_all_levs_weighted / real( LH_microphys_calls ) - - call hbuf_avg_put( 'LH_RT', LH_rt_weighted, 1,nx, 1,ny, nzm, 1. ) - call hbuf_avg_put( 'LH_TL', LH_t_weighted, 1,nx, 1,ny, nzm, 1. ) - - do ivar = 1, d_variables - if ( ivar == iiLH_s_mellor ) then - stat_name = "LH_S_MEL" - else if ( ivar == iiLH_w ) then - stat_name = "LH_W" - else if ( ivar == iiLH_rrain ) then - stat_name = "LH_RRAIN" - else if ( ivar == iiLH_rsnow ) then - stat_name = "LH_RSNOW" - else if ( ivar == iiLH_rice ) then - stat_name = "LH_RICE" - else if ( ivar == iiLH_Nr ) then - stat_name = "LH_NR" - else if ( ivar == iiLH_Nsnow ) then - stat_name = "LH_NSNOW" - else if ( ivar == iiLH_Ni ) then - stat_name = "LH_NI" - else if ( ivar == iiLH_Nc ) then - stat_name = "LH_NC" - end if ! ivar - - call hbuf_avg_put( stat_name, X_nl_all_levs_weighted(:,:,:,ivar), 1,nx, 1,ny, nzm, 1. ) - end do - - ! Tendency averages - - call hbuf_avg_put( 'LH_TL_MC', real( LH_t_avg_tndcy ), & - 1,nx, 1,ny, nzm, 1. ) - - do ivar = 1, nmicro_fields - if ( ivar == index_water_vapor ) then - stat_name = 'LH_RT_MC' - else if ( ivar == iirrainm ) then - stat_name = 'LH_RR_MC' - else if ( ivar == iirsnowm ) then - stat_name = 'LH_RS_MC' - else if ( ivar == iiricem ) then - stat_name = 'LH_RI_MC' - else if ( ivar == iiNim ) then - stat_name = 'LH_NI_MC' - else if ( ivar == iiNrm ) then - stat_name = 'LH_NR_MC' - else if ( ivar == iiNsnowm ) then - stat_name = 'LH_NS_MC' - else - stat_name = '' - end if - if ( stat_name /= '' ) then - call hbuf_avg_put( stat_name, & - real( LH_micro_field_avg_tndcy(:,:,:,ivar) ), & - 1,nx, 1,ny, nzm, 1. ) - end if - end do - - return - end subroutine stats_clubb_silhs_update -#endif /* CLUBB_LH */ - -subroutine stats_init_clubb( l_stats_in, l_output_rad_files_in, stats_tsamp_in, stats_tout_in, & - nzmax, nnrad_zt,nnrad_zm, time_current, delt ) - ! - ! Description: Initializes the statistics saving functionality of - ! the CLUBB model. This is for purpose of SAM-CLUBB interface. Here - ! the traditional stats_init of CLUBB is not called, as it is not compatible - ! with SAM output. This is adopted from clubb_intr.F90 in CAM5.2. - - !----------------------------------------------------------------------- - - - use crmx_stats_variables, only: & - zt, & ! Variables - ztscr01, & - ztscr02, & - ztscr03, & - ztscr04, & - ztscr05, & - ztscr06, & - ztscr07, & - ztscr08, & - ztscr09, & - ztscr10, & - ztscr11, & - ztscr12, & - ztscr13, & - ztscr14, & - ztscr15, & - ztscr16, & - ztscr17, & - ztscr18, & - ztscr19, & - ztscr20, & - ztscr21 - - use crmx_stats_variables, only: & - LH_zt, & ! Variable(s) - LH_sfc - - use crmx_stats_variables, only: & - zm, & ! Variables - zmscr01, & - zmscr02, & - zmscr03, & - zmscr04, & - zmscr05, & - zmscr06, & - zmscr07, & - zmscr08, & - zmscr09, & - zmscr10, & - zmscr11, & - zmscr12, & - zmscr13, & - zmscr14, & - zmscr15, & - zmscr16, & - zmscr17, & - rad_zt - - use crmx_stats_variables, only: & - rad_zm, & - sfc, & - l_stats, & - l_output_rad_files, & - stats_tsamp, & - stats_tout, & - l_stats_samp, & - l_stats_last, & - fname_rad_zt, & - fname_rad_zm, & - fname_sfc, & - l_netcdf, & - l_grads - - use crmx_clubb_precision, only: & - time_precision, & ! Constant(s) - core_rknd - - use crmx_stats_zm, only: & - nvarmax_zm, & ! Constant(s) - stats_init_zm ! Procedure(s) - - use crmx_stats_zt, only: & - nvarmax_zt, & ! Constant(s) - stats_init_zt ! Procedure(s) - - use crmx_stats_LH_zt, only: & - nvarmax_LH_zt, & ! Constant(s) - stats_init_LH_zt ! Procedure(s) - - use crmx_stats_LH_sfc, only: & - nvarmax_LH_sfc, & ! Constant(s) - stats_init_LH_sfc ! Procedure(s) - - use crmx_stats_rad_zt, only: & - nvarmax_rad_zt, & ! Constant(s) - stats_init_rad_zt ! Procedure(s) - - use crmx_stats_rad_zm, only: & - nvarmax_rad_zm, & ! Constant(s) - stats_init_rad_zm ! Procedure(s) - - use crmx_stats_sfc, only: & - nvarmax_sfc, & ! Constant(s) - stats_init_sfc ! Procedure(s) - - use crmx_error_code, only: & - clubb_at_least_debug_level ! Function - - use crmx_constants_clubb, only: & - fstdout, fstderr, var_length ! Constants - - use crmx_parameters_microphys, only: & - LH_microphys_disabled, & ! Constant - LH_microphys_type ! Variable - - implicit none - - ! Input Variables - - logical, intent(in) :: l_stats_in ! Stats on? T/F - - logical, intent(in) :: l_output_rad_files_in ! Rad 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) :: nzmax ! 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) :: & - time_current ! Model time [s] - - real(kind=time_precision), intent(in) :: & - delt ! Timestep (dt_main in CLUBB) [s] - - - ! Local Variables - - ! Namelist Variables - - character(len=var_length), dimension(nvarmax_zt) :: & - clubb_vars_zt ! Variables on the thermodynamic levels - - character(len=var_length), dimension(nvarmax_LH_zt) :: & - clubb_vars_LH_zt ! Latin Hypercube variables on the thermodynamic levels - - character(len=var_length), dimension(nvarmax_LH_sfc) :: & - clubb_vars_LH_sfc ! Latin Hypercube variables at the surface - - 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_LH_zt, & - clubb_vars_LH_sfc, & - clubb_vars_rad_zt, & - clubb_vars_rad_zm, & - clubb_vars_sfc - - ! Local Variables - - logical :: l_error - - character(len=200) :: fname, temp1, sub - - integer :: i, ntot, read_status - integer :: iunit - - ! Initialize - l_error = .false. - - ! Set stats_variables variables with inputs from calling subroutine - l_stats = l_stats_in - - l_output_rad_files = l_output_rad_files_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_LH_zt = '' - clubb_vars_LH_sfc = '' - clubb_vars_rad_zt = '' - clubb_vars_rad_zm = '' - clubb_vars_sfc = '' - - ! Read variables to compute from the namelist - ! in SAM, namelist is read on every MPI task, so no need for mpibcast -! if (masterproc) then - iunit= 55 - open(unit=iunit,file="clubb_stats_sam") - read(unit=iunit, nml=clubb_stats_nl, iostat=read_status) - if (read_status /= 0) then - stop 'stats_init_clubb: error reading namelist' - end if - close(unit=iunit) -! end if - -!#ifdef SPMD - ! Broadcast namelist variables -! call mpibcast(clubb_vars_zt, var_length*nvarmax_zt, mpichar, 0, mpicom) -! call mpibcast(clubb_vars_zm, var_length*nvarmax_zm, mpichar, 0, mpicom) -! call mpibcast(clubb_vars_LH_zt, var_length*nvarmax_LH_zt, mpichar, 0, mpicom) -! call mpibcast(clubb_vars_LH_sfc, var_length*nvarmax_LH_sfc, mpichar, 0, mpicom) -! call mpibcast(clubb_vars_rad_zt, var_length*nvarmax_rad_zt, mpichar, 0, mpicom) -! call mpibcast(clubb_vars_rad_zm, var_length*nvarmax_rad_zm, mpichar, 0, mpicom) -! call mpibcast(clubb_vars_sfc, var_length*nvarmax_sfc, mpichar, 0, mpicom) -!#endif - - ! Hardcode these for use in SAM-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 - real(floor(stats_tsamp/delt), kind=time_precision ) ) & - > 1.e-8_time_precision ) 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 - write(2001, *) 'i=', i-1, ' clubb_vars_zt ', trim(clubb_vars_zt(i)) - 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 - stop "stats_init_clubb: number of zt statistical variables exceeds limit" - endif - - zt%nn = ntot - zt%kk = nzmax - - allocate( zt%z( zt%kk ) ) - - allocate( zt%x( 1, 1, zt%kk, zt%nn ) ) - allocate( zt%n( 1, 1, zt%kk, zt%nn ) ) - allocate( zt%l_in_update( 1, 1, zt%kk, zt%nn ) ) - call stats_zero( zt%kk, zt%nn, zt%x, zt%n, zt%l_in_update ) - - allocate( zt%f%var( zt%nn ) ) - allocate( zt%f%z( zt%kk ) ) - - ! Allocate scratch space - - allocate( ztscr01(zt%kk) ) - allocate( ztscr02(zt%kk) ) - allocate( ztscr03(zt%kk) ) - allocate( ztscr04(zt%kk) ) - allocate( ztscr05(zt%kk) ) - allocate( ztscr06(zt%kk) ) - allocate( ztscr07(zt%kk) ) - allocate( ztscr08(zt%kk) ) - allocate( ztscr09(zt%kk) ) - allocate( ztscr10(zt%kk) ) - allocate( ztscr11(zt%kk) ) - allocate( ztscr12(zt%kk) ) - allocate( ztscr13(zt%kk) ) - allocate( ztscr14(zt%kk) ) - allocate( ztscr15(zt%kk) ) - allocate( ztscr16(zt%kk) ) - allocate( ztscr17(zt%kk) ) - allocate( ztscr18(zt%kk) ) - allocate( ztscr19(zt%kk) ) - allocate( ztscr20(zt%kk) ) - allocate( ztscr21(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 - - ! Default initialization for array indices for zt - - call stats_init_zt( clubb_vars_zt, l_error ) - - ! Setup output file for LH_zt (Latin Hypercube stats) - - if ( LH_microphys_type /= LH_microphys_disabled ) then - - i = 1 - do while ( ichar(clubb_vars_LH_zt(i)(1:1)) /= 0 & - .and. len_trim(clubb_vars_LH_zt(i)) /= 0 & - .and. i <= nvarmax_LH_zt ) - i = i + 1 - end do - ntot = i - 1 - 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 clubb_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 - - LH_zt%nn = ntot - LH_zt%kk = nzmax - - allocate( LH_zt%z( LH_zt%kk ) ) -! LH_zt%z = gzt - - allocate( LH_zt%x( 1, 1, LH_zt%kk, LH_zt%nn ) ) - allocate( LH_zt%n( 1, 1, LH_zt%kk, LH_zt%nn ) ) - allocate( LH_zt%l_in_update( 1, 1, LH_zt%kk, LH_zt%nn ) ) - call stats_zero( LH_zt%kk, LH_zt%nn, LH_zt%x, LH_zt%n, LH_zt%l_in_update ) - - allocate( LH_zt%f%var( LH_zt%nn ) ) - allocate( LH_zt%f%z( LH_zt%kk ) ) - - call stats_init_LH_zt( clubb_vars_LH_zt, l_error ) - - i = 1 - do while ( ichar(clubb_vars_LH_sfc(i)(1:1)) /= 0 & - .and. len_trim(clubb_vars_LH_sfc(i)) /= 0 & - .and. i <= nvarmax_LH_sfc ) - i = i + 1 - end do - ntot = i - 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 clubb_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 - - LH_sfc%nn = ntot - LH_sfc%kk = 1 - - allocate( LH_sfc%z( LH_sfc%kk ) ) - - allocate( LH_sfc%x( 1, 1, LH_sfc%kk, LH_sfc%nn ) ) - allocate( LH_sfc%n( 1, 1, LH_sfc%kk, LH_sfc%nn ) ) - allocate( LH_sfc%l_in_update( 1, 1, LH_sfc%kk, LH_sfc%nn ) ) - - call stats_zero( LH_sfc%kk, LH_sfc%nn, LH_sfc%x, LH_sfc%n, LH_sfc%l_in_update ) - - allocate( LH_sfc%f%var( LH_sfc%nn ) ) - allocate( LH_sfc%f%z( LH_sfc%kk ) ) - - call stats_init_LH_sfc( clubb_vars_LH_sfc, l_error ) - - end if ! LH_microphys_type /= LH_microphys_disabled - - ! 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 - stop "stats_init_clubb: number of zm statistical variables exceeds limit" - endif - - zm%nn = ntot - zm%kk = nzmax - - allocate( zm%z( zm%kk ) ) - - allocate( zm%x( 1, 1, zm%kk, zm%nn ) ) - allocate( zm%n( 1, 1, zm%kk, zm%nn ) ) - allocate( zm%l_in_update( 1, 1, zm%kk, zm%nn ) ) - - call stats_zero( zm%kk, zm%nn, zm%x, zm%n, zm%l_in_update ) - - allocate( zm%f%var( zm%nn ) ) - allocate( zm%f%z( zm%kk ) ) - - ! Allocate scratch space - - allocate( zmscr01(zm%kk) ) - allocate( zmscr02(zm%kk) ) - allocate( zmscr03(zm%kk) ) - allocate( zmscr04(zm%kk) ) - allocate( zmscr05(zm%kk) ) - allocate( zmscr06(zm%kk) ) - allocate( zmscr07(zm%kk) ) - allocate( zmscr08(zm%kk) ) - allocate( zmscr09(zm%kk) ) - allocate( zmscr10(zm%kk) ) - allocate( zmscr11(zm%kk) ) - allocate( zmscr12(zm%kk) ) - allocate( zmscr13(zm%kk) ) - allocate( zmscr14(zm%kk) ) - allocate( zmscr15(zm%kk) ) - allocate( zmscr16(zm%kk) ) - allocate( zmscr17(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 - - 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 - stop "stats_init_clubb: number of rad_zt statistical variables exceeds limit" - endif - - rad_zt%nn = ntot - rad_zt%kk = nnrad_zt - - allocate( rad_zt%z( rad_zt%kk ) ) - - allocate( rad_zt%x( 1, 1, rad_zt%kk, rad_zt%nn ) ) - allocate( rad_zt%n( 1, 1, rad_zt%kk, rad_zt%nn ) ) - allocate( rad_zt%l_in_update( 1, 1, rad_zt%kk, rad_zt%nn ) ) - - call stats_zero( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n, rad_zt%l_in_update ) - - allocate( rad_zt%f%var( rad_zt%nn ) ) - allocate( rad_zt%f%z( 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 - stop "stats_init_clubb: number of rad_zm statistical variables exceeds limit" - endif - - rad_zm%nn = ntot - rad_zm%kk = nnrad_zm - - allocate( rad_zm%z( rad_zm%kk ) ) - - allocate( rad_zm%x( 1, 1, rad_zm%kk, rad_zm%nn ) ) - allocate( rad_zm%n( 1, 1, rad_zm%kk, rad_zm%nn ) ) - allocate( rad_zm%l_in_update( 1, 1, rad_zm%kk, rad_zm%nn ) ) - - call stats_zero( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n, rad_zm%l_in_update ) - - allocate( rad_zm%f%var( rad_zm%nn ) ) - allocate( rad_zm%f%z( 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 - stop "stats_init_clubb: number of sfc statistical variables exceeds limit" - endif - - sfc%nn = ntot - sfc%kk = 1 - - allocate( sfc%z( sfc%kk ) ) - - allocate( sfc%x( 1, 1, sfc%kk, sfc%nn ) ) - allocate( sfc%n( 1, 1, sfc%kk, sfc%nn ) ) - allocate( sfc%l_in_update( 1, 1, sfc%kk, sfc%nn ) ) - - call stats_zero( sfc%kk, sfc%nn, sfc%x, sfc%n, sfc%l_in_update ) - - allocate( sfc%f%var( sfc%nn ) ) - allocate( sfc%f%z( sfc%kk ) ) - - call stats_init_sfc( clubb_vars_sfc, l_error ) - - ! Check for errors - - if ( l_error ) then - write(fstderr,*) 'stats_init: errors found' - stop - endif - - allocate(out_zt(nx, ny, nz, zt%nn)) - allocate(out_zm(nx, ny, nz, zm%nn)) - allocate(out_sfc(nx, ny, nz, sfc%nn)) - - if(l_output_rad_files) then - allocate(out_rad_zt(nx, ny, nz, rad_zt%nn)) - allocate(out_rad_zm(nx, ny, nz, rad_zm%nn)) - end if - - if(LH_microphys_type /= LH_microphys_disabled ) then - allocate(out_LH_zt(nx, ny, nz, LH_zt%nn)) - allocate(out_LH_sfc(nx, ny, nz, LH_sfc%nn)) - end if - - return - - end subroutine stats_init_clubb -!================================================================================== ! -! ! -!================================================================================== ! -#ifndef CRM - subroutine hbuf_stats_init_clubb(namelist,deflist,unitlist,status,average_type,count,clubbcount) - - use crmx_stats_variables, only: & - zt, LH_zt, zm, rad_zm, rad_zt, sfc, LH_sfc, l_output_rad_files - use crmx_parameters_microphys, only: & - LH_microphys_disabled, & ! Constant - LH_microphys_type ! Variable - - implicit none - - character(*) namelist(*), deflist(*), unitlist(*) - integer status(*),average_type(*),count, clubbcount, n, ii, jj, ncond - - character*8 name - character*80 longname - character*10 units - -! Local variables - integer :: i - character*100 temp1, sub - - clubbcount = 0 - -! Now call add fields - do i = 1, zt%nn - - temp1 = trim(zt%f%var(i)%name) - sub = temp1 -! if (len(temp1) > 16) sub = temp1(1:16) - -! call addfld(trim(sub),trim(zt%f%var(i)%units),nnzp,& -! 'A',trim(zt%f%var(i)%description),phys_decomp) - call add_to_namelist(count, clubbcount, trim(sub), trim(zt%f%var(i)%description), & - trim(zt%f%var(i)%units), 0) - enddo - - do i = 1, zm%nn - - temp1 = trim(zm%f%var(i)%name) - sub = temp1 -! if (len(temp1) > 16) sub = temp1(1:16) - -! call addfld(trim(sub),trim(zm%f%var(i)%units),nnzp,& -! 'A',trim(zm%f%var(i)%description),phys_decomp) - call add_to_namelist(count, clubbcount, trim(sub), trim(zm%f%var(i)%description), & - trim(zm%f%var(i)%units), 0) - enddo - - if (l_output_rad_files) then - do i = 1, rad_zt%nn -! call addfld(trim(rad_zt%f%var(i)%name),trim(rad_zt%f%var(i)%units),nnzp,& -! 'A',trim(rad_zt%f%var(i)%description),phys_decomp) - call add_to_namelist(count, clubbcount, trim(rad_zt%f%var(i)%name), & - trim(rad_zt%f%var(i)%description), trim(rad_zt%f%var(i)%units), 0) - enddo - - do i = 1, rad_zm%nn -! call addfld(trim(rad_zm%f%var(i)%name),trim(rad_zm%f%var(i)%units),nnzp,& -! 'A',trim(rad_zm%f%var(i)%description),phys_decomp) - call add_to_namelist(count, clubbcount, trim(rad_zm%f%var(i)%name), & - trim(rad_zm%f%var(i)%description), trim(rad_zm%f%var(i)%units), 0) - enddo - endif - - if ( LH_microphys_type /= LH_microphys_disabled ) then - do i=1, LH_zt%nn - call add_to_namelist(count, clubbcount, trim(LH_zt%f%var(i)%name), & - trim(LH_zt%f%var(i)%description), trim(LH_zt%f%var(i)%units), 0) - end do - do i=1, LH_sfc%nn - call add_to_namelist(count, clubbcount, trim(LH_sfc%f%var(i)%name), & - trim(LH_sfc%f%var(i)%description), trim(LH_sfc%f%var(i)%units), 0) - end do - endif - - do i = 1, sfc%nn - call add_to_namelist(count, clubbcount, trim(sfc%f%var(i)%name), & - trim(sfc%f%var(i)%description), trim(sfc%f%var(i)%units), 0) - enddo - - return - - end subroutine hbuf_stats_init_clubb - !================================================================================ - - subroutine hbuf_clubb_output() - - use crmx_stats_variables, only: & - zt, LH_zt, zm, rad_zm, rad_zt, sfc, LH_sfc, l_output_rad_files - use crmx_parameters_microphys, only: & - LH_microphys_disabled, & ! Constant - LH_microphys_type ! Variable - use hbuffer, only: hbuf_avg_put - - implicit none - - ! locale variables - integer :: i - character*100 temp1, sub - - do i = 1, zt%nn - call hbuf_avg_put(trim(zt%f%var(i)%name), out_zt(1:nx, 1:ny, 2:nz, i), 1, nx, 1, ny, nzm, 1.) - enddo - - do i = 1, zm%nn - !Velocity level. Here we just simplely put the last nz-1 onto the pressure level. - call hbuf_avg_put(trim(zm%f%var(i)%name), out_zm(1:nx, 1:ny, 1:(nz-1), i), & - 1, nx, 1, ny, nzm, 1.) - enddo - - if (l_output_rad_files) then - do i = 1, rad_zt%nn - call hbuf_avg_put(trim(rad_zt%f%var(i)%name), & - out_rad_zt(1:nx, 1:ny, 2:nz, i), 1, nx, 1, ny, nzm, 1.) - enddo - - do i = 1, rad_zm%nn - call hbuf_avg_put(trim(rad_zm%f%var(i)%name), & - out_rad_zm(1:nx, 1:ny, 1:(nz-1), i), 1, nx, 1, ny, nzm, 1.) - enddo - endif - - if ( LH_microphys_type /= LH_microphys_disabled ) then - do i=1, LH_zt%nn - call hbuf_avg_put(trim(LH_zt%f%var(i)%name), & - out_LH_zt(1:nx, 1:ny, 2:nz, i), 1, nx, 1, ny, nzm, 1.) - end do - - do i=1, LH_sfc%nn - ! For simplicity, hbuf_avg_put is also called for surface varialbes. - ! so zeroout values from level 2 to nz - out_LH_sfc(:, :, 2:nz, i) = 0.0 - call hbuf_avg_put(trim(LH_sfc%f%var(i)%name), & - out_LH_sfc(1:nx, 1:ny, 1:(nz-1), i), 1, nx, 1, ny, nzm, 1.) - end do - end if - - do i = 1, sfc%nn - ! For simplicity, hbuf_avg_put is also called for surface varialbes. - ! so zeroout values from level 2 to nz - out_sfc(:, :, 2:nz, i) = 0.0 - call hbuf_avg_put(trim(sfc%f%var(i)%name), & - out_sfc(1:nx, 1:ny, 1:(nz-1), i), 1, nx, 1, ny, nzm, 1.) - enddo - - return - - end subroutine hbuf_clubb_output -#endif /*CRM*/ - ! =============================================================================== ! - ! ! - ! =============================================================================== ! - - !----------------------------------------------------------------------- - subroutine stats_end_timestep_clubb(ix, jy) - - ! Description: Called when the stats timestep has ended. This subroutine - ! is responsible for calling statistics to be written to the output - ! format. - !----------------------------------------------------------------------- - - use crmx_constants_clubb, only: & - fstderr ! Constant(s) - - use crmx_stats_variables, only: & - zt, & ! Variable(s) - LH_zt, & - LH_sfc, & - zm, & - rad_zt, & - rad_zm, & - sfc, & - l_stats_last, & - stats_tsamp, & - stats_tout, & - l_output_rad_files - - use crmx_error_code, only: & - clubb_at_least_debug_level ! Procedure(s) - - use crmx_parameters_microphys, only: & - LH_microphys_disabled ! Constant - - use crmx_parameters_microphys, only: & - LH_microphys_type, & ! Variable(s) - LH_microphys_calls - - - implicit none - - - integer, intent(in) :: ix - integer, intent(in) :: jy - - ! Local Variables - - integer :: i, k - logical :: l_error - - ! ---- Begin Code ---- - - ! 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, zt%nn - do k = 1, zt%kk - - if ( zt%n(1,1,k,i) /= 0 .and. & - zt%n(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(zt%f%var(i)%name), ' in zt ', & - 'at k = ', k, & - '; zt%n(',k,',',i,') = ', zt%n(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, zm%nn - do k = 1, zm%kk - - if ( zm%n(1,1,k,i) /= 0 .and. & - zm%n(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(zm%f%var(i)%name), ' in zm ', & - 'at k = ', k, & - '; zm%n(',k,',',i,') = ', zm%n(1,1,k,i) - endif - - endif - - enddo - enddo - - if ( LH_microphys_type /= LH_microphys_disabled ) then - ! Look for errors by checking the number of sampling points - ! for each variable in the LH_zt statistics at each vertical level. - do i = 1, LH_zt%nn - do k = 1, LH_zt%kk - - if ( LH_zt%n(1,1,k,i) /= 0 .and. & - LH_zt%n(1,1,k,i) /= floor( stats_tout/stats_tsamp ) .and. & - LH_zt%n(1,1,k,i) /= LH_microphys_calls * 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(LH_zt%f%var(i)%name), ' in LH_zt ', & - 'at k = ', k, & - '; LH_zt%n(',k,',',i,') = ', LH_zt%n(1,1,k,i) - end if ! clubb_at_lest_debug_level 1 - - end if ! n /= 0 and n /= LH_microphys_calls * stats_tout/stats_tsamp - - end do ! k = 1 .. LH_zt%kk - end do ! i = 1 .. LH_zt%nn - - ! Look for errors by checking the number of sampling points - ! for each variable in the LH_zt statistics at each vertical level. - do i = 1, LH_sfc%nn - do k = 1, LH_sfc%kk - - if ( LH_sfc%n(1,1,k,i) /= 0 .and. & - LH_sfc%n(1,1,k,i) /= floor( stats_tout/stats_tsamp ) .and. & - LH_sfc%n(1,1,k,i) /= LH_microphys_calls * 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(LH_sfc%f%var(i)%name), ' in LH_sfc ', & - 'at k = ', k, & - '; LH_sfc%n(',k,',',i,') = ', LH_sfc%n(1,1,k,i) - end if ! clubb_at_lest_debug_level 1 - - end if ! n /= 0 and n /= LH_microphys_calls * stats_tout/stats_tsamp - - end do ! k = 1 .. LH_sfc%kk - end do ! i = 1 .. LH_sfc%nn - end if ! LH_microphys_type /= LH_microphys_disabled - - - 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, rad_zt%nn - do k = 1, rad_zt%kk - - if ( rad_zt%n(1,1,k,i) /= 0 .and. & - rad_zt%n(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(rad_zt%f%var(i)%name), ' in rad_zt ', & - 'at k = ', k, & - '; rad_zt%n(',k,',',i,') = ', rad_zt%n(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, rad_zm%nn - do k = 1, rad_zm%kk - - if ( rad_zm%n(1,1,k,i) /= 0 .and. & - rad_zm%n(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(rad_zm%f%var(i)%name), ' in rad_zm ', & - 'at k = ', k, & - '; rad_zm%n(',k,',',i,') = ', rad_zm%n(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, sfc%nn - do k = 1, sfc%kk - - if ( sfc%n(1,1,k,i) /= 0 .and. & - sfc%n(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(sfc%f%var(i)%name), ' in sfc ', & - 'at k = ', k, & - '; sfc%n(',k,',',i,') = ', sfc%n(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.' - stop 'stats_end_timestep: error(s) found' - endif - - ! Compute averages - call stats_avg( zt%kk, zt%nn, zt%x, zt%n ) - call stats_avg( zm%kk, zm%nn, zm%x, zm%n ) - if ( LH_microphys_type /= LH_microphys_disabled ) then - call stats_avg( LH_zt%kk, LH_zt%nn, LH_zt%x, LH_zt%n ) - call stats_avg( LH_sfc%kk, LH_sfc%nn, LH_sfc%x, LH_sfc%n ) - end if - if ( l_output_rad_files ) then - call stats_avg( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n ) - call stats_avg( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n ) - end if - call stats_avg( sfc%kk, sfc%nn, sfc%x, sfc%n ) - - ! 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, zt%nn - do k = 1, zt%kk - out_zt(ix,jy,k,i) = zt%x(1,1,k,i) - if(out_zt(ix,jy,k,i) /= out_zt(ix,jy,k,i)) out_zt(ix,jy,k,i) = 0.0 - enddo - enddo - - do i = 1, zm%nn - do k = 1, zt%kk - out_zm(ix,jy,k,i) = zm%x(1,1,k,i) - if(out_zm(ix,jy,k,i) /= out_zm(ix,jy,k,i)) out_zm(ix,jy,k,i) = 0.0 - enddo - enddo - - if (l_output_rad_files) then - do i = 1, rad_zt%nn - do k = 1, rad_zt%kk - out_rad_zt(ix,jy,k,i) = rad_zt%x(1,1,k,i) - if(out_rad_zt(ix,jy,k,i) /= out_rad_zt(ix,jy,k,i)) out_rad_zt(ix,jy,k,i) = 0.0 - enddo - enddo - - do i = 1, rad_zm%nn - do k = 1, rad_zm%kk - out_rad_zm(ix,jy,k,i) = rad_zm%x(1,1,k,i) - if(out_rad_zm(ix,jy,k,i) /= out_rad_zm(ix,jy,k,i)) out_rad_zm(ix,jy,k,i) = 0.0 - enddo - enddo - endif - - if ( LH_microphys_type /= LH_microphys_disabled ) then - do i=1, LH_zt%nn - do k=1, LH_zt%kk - out_LH_zt(ix,jy,k,i) = LH_zt%x(1,1,k,i) - if(out_LH_zt(ix,jy,k,i) /= out_LH_zt(ix,jy,k,i)) out_LH_zt(ix,jy,k,i) = 0.0 - enddo - enddo - - out_LH_sfc(ix,jy,:,:) = 0.0 - do i=1, LH_sfc%nn - out_LH_sfc(ix,jy,1,i) = LH_sfc%x(1,1,1,i) - if(out_LH_sfc(ix,jy,1,i) /= out_LH_sfc(ix,jy,1,i)) out_LH_sfc(ix,jy,1,i) = 0.0 - end do - endif - - out_sfc(ix, jy, :, :) = 0.0 - do i = 1, sfc%nn - out_sfc(ix,jy,1,i) = sfc%x(1,1,1,i) - if(out_sfc(ix,jy,1,i) /= out_sfc(ix,jy,1,i)) out_sfc(ix,jy,1,i) = 0.0 - enddo - - ! Reset sample fields - call stats_zero( zt%kk, zt%nn, zt%x, zt%n, zt%l_in_update ) - call stats_zero( zm%kk, zm%nn, zm%x, zm%n, zm%l_in_update ) - if (l_output_rad_files) then - call stats_zero( rad_zt%kk, rad_zt%nn, rad_zt%x, rad_zt%n, rad_zt%l_in_update ) - call stats_zero( rad_zm%kk, rad_zm%nn, rad_zm%x, rad_zm%n, rad_zm%l_in_update ) - end if - if ( LH_microphys_type /= LH_microphys_disabled) then - call stats_zero( LH_zt%kk, LH_zt%nn, LH_zt%x, LH_zt%n, LH_zt%l_in_update ) - call stats_zero( LH_sfc%kk, LH_sfc%nn, LH_sfc%x, LH_sfc%n, LH_sfc%l_in_update ) - end if - call stats_zero( sfc%kk, sfc%nn, sfc%x, sfc%n, sfc%l_in_update ) - - return - - end subroutine stats_end_timestep_clubb - - ! =============================================================================== ! - ! ! - ! =============================================================================== ! - - !----------------------------------------------------------------------- - subroutine stats_zero( kk, nn, x, n, l_in_update ) - - ! Description: - ! Initialize stats to zero - !----------------------------------------------------------------------- - - use crmx_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_stat_rknd - n(:,:,:,:) = 0_stat_nknd - l_in_update(:,:,:,:) = .false. - end if - - return - - end subroutine stats_zero - - ! =============================================================================== ! - ! ! - ! =============================================================================== ! - - !----------------------------------------------------------------------- - subroutine stats_avg( kk, nn, x, n ) - - ! Description: - ! Compute the average of stats fields - !----------------------------------------------------------------------- - use crmx_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), kind=stat_rknd ) - end if - - end do - end do - - return - - end subroutine stats_avg -#endif /* CLUBB_CRM*/ -end module crmx_stat_clubb diff --git a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_tke_full.F90 b/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_tke_full.F90 deleted file mode 100644 index 79dd936cdc..0000000000 --- a/src/physics/spcam/crm/SGS_CLUBBkvhkvm/crmx_tke_full.F90 +++ /dev/null @@ -1,147 +0,0 @@ - -subroutine tke_full - -! this subroutine solves the TKE equation - -use crmx_vars -use crmx_sgs -use crmx_params -implicit none - -real def2(nx,ny,nzm) -real grd,betdz,Ck,Ce,Ces,Ce1,Ce2,smix,Pr,Cee,Cs -real buoy_sgs,ratio,a_prod_sh,a_prod_bu,a_diss -real lstarn, lstarp, bbb, omn, omp -real qsatt,dqsat -integer i,j,k,kc,kb - -!call t_startf('tke_full') - -!Cs = 0.1944 -Cs = 0.15 -Ck=0.1 -Ce=Ck**3/Cs**4 -Ces=Ce/0.7*3.0 - -if(RUN3D) then - call shear_prod3D(def2) -else - call shear_prod2D(def2) -endif - -do k=1,nzm - kb=k-1 - kc=k+1 - - grd=dz*adz(k) - - betdz=bet(k)/dz/(adzw(kc)+adzw(k)) - Ce1=Ce/0.7*0.19 - Ce2=Ce/0.7*0.51 - if(k.eq.1) then - kb=1 - kc=2 - betdz=bet(k)/dz/adzw(kc) - Ce1=Ces/0.7*0.19 - Ce2=Ces/0.7*0.51 - end if - if(k.eq.nzm) then - kb=nzm-1 - kc=nzm - betdz=bet(k)/dz/adzw(k) - Ce1=Ces/0.7*0.19 - Ce2=Ces/0.7*0.51 - end if - tkelediss(k) = 0. - tkesbdiss(k) = 0. - tkesbshear(k)= 0. - tkesbbuoy(k) = 0. - do j=1,ny - do i=1,nx -! SGS buoyancy flux - -!bloss: removed temperature diagnostics for omn. -! - use mass weighted qsat, dqsat and latent heat for cloud -! - separate buoyancy contributions for precipitating water and ice. - - - if(qcl(i,j,k)+qci(i,j,k) .gt. 0.) then - - omn = qcl(i,j,k)/(qcl(i,j,k)+qci(i,j,k)+1.e-20) - lstarn = fac_cond+(1.-omn)*fac_fus - - dqsat = omn*dtqsatw_crm(tabs(i,j,k),pres(k))+ & - (1.-omn)*dtqsati_crm(tabs(i,j,k),pres(k)) - qsatt = omn*qsatw_crm(tabs(i,j,k),pres(k))+(1.-omn)*qsati_crm(tabs(i,j,k),pres(k)) - bbb = 1. + epsv*qsatt-qcl(i,j,k)-qci(i,j,k) -qpl(i,j,k)-qpi(i,j,k)+1.61*tabs(i,j,k)*dqsat - bbb = bbb / (1.+lstarn*dqsat) - buoy_sgs=betdz*(bbb*(t(i,j,kc)-t(i,j,kb)) & - +(bbb*lstarn - (1.+lstarn*dqsat)*tabs(i,j,k))* & - (qv(i,j,kc)+qcl(i,j,kc)+qci(i,j,kc)-qv(i,j,kb)-qcl(i,j,kb)-qci(i,j,kb)) & - + (bbb*fac_cond - (1.+fac_cond*dqsat)*tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & - + (bbb*fac_sub - (1.+fac_sub *dqsat)*tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) -!bloss +(bbb*lstarp - (1.+lstarp*dqsat)*tabs(i,j,k))* & -!bloss (qpl(i,j,kc)+qpi(i,j,kc)-qpl(i,j,kb)-qpi(i,j,kb)) ) - else - - bbb = 1.+epsv*qv(i,j,k)-qpl(i,j,k)-qpi(i,j,k) - buoy_sgs=betdz*( bbb*(t(i,j,kc)-t(i,j,kb)) & - +epsv*tabs(i,j,k)* & - (qv(i,j,kc)+qcl(i,j,kc)+qci(i,j,kc)-qv(i,j,kb)-qcl(i,j,kb)-qci(i,j,kb)) & - +(bbb*fac_cond-tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & - +(bbb*fac_sub -tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) -!bloss +(bbb*lstarp-tabs(i,j,k))* & -!bloss (qpl(i,j,kc)+qpi(i,j,kc)-qpl(i,j,kb)-qpi(i,j,kb)) ) - end if - - if(buoy_sgs.le.0.) then - smix=grd - else - smix=min(grd,max(0.1*grd, sqrt(0.76*tk(i,j,k)/Ck/sqrt(buoy_sgs+1.e-10)))) - end if - - - ratio=smix/grd - Pr=1. -! Pr=1. +2.*ratio - Cee=Ce1+Ce2*ratio - - if(dosmagor) then - - tk(i,j,k)=sqrt(Ck**3/Cee*max(0.,def2(i,j,k)-Pr*buoy_sgs))*smix**2 - tke(i,j,k) = (tk(i,j,k)/(Ck*smix))**2 - a_prod_sh=(tk(i,j,k)+0.001)*def2(i,j,k) - a_prod_bu=-(tk(i,j,k)+0.001)*Pr*buoy_sgs - a_diss=a_prod_sh+a_prod_bu - - else - - tke(i,j,k)=max(0.,tke(i,j,k)) - a_prod_sh=(tk(i,j,k)+0.001)*def2(i,j,k) - a_prod_bu=-(tk(i,j,k)+0.001)*Pr*buoy_sgs - a_diss=min(tke(i,j,k)/(4.*dt),Cee/smix*tke(i,j,k)**1.5) ! cap the diss rate (useful for large time steps - tke(i,j,k)=max(0.,tke(i,j,k)+dtn*(max(0.,a_prod_sh+a_prod_bu)-a_diss)) - tk(i,j,k)=Ck*smix*sqrt(tke(i,j,k)) - - end if - - tkh(i,j,k)=Pr*tk(i,j,k) - - tkelediss(k) = tkelediss(k) - a_prod_sh - tkesbdiss(k) = tkesbdiss(k) + a_diss - tkesbshear(k)= tkesbshear(k)+ a_prod_sh - tkesbbuoy(k) = tkesbbuoy(k) + a_prod_bu - - end do ! i - end do ! j - - tkelediss(k) = tkelediss(k)/float(nx*ny) - - -end do ! k - -!call t_stopf('tke_full') - -end - - diff --git a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_mom.F90 b/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_mom.F90 deleted file mode 100644 index 669f8f6e07..0000000000 --- a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_mom.F90 +++ /dev/null @@ -1,20 +0,0 @@ -subroutine diffuse_mom - -! Interface to the diffusion routines - -use crmx_vars -implicit none -integer i,j,k - -!call t_startf ('diffuse_mom') - -if(RUN3D) then - call diffuse_mom3D() -else - call diffuse_mom2D() -endif - -!call t_stopf ('diffuse_mom') - -end subroutine diffuse_mom - diff --git a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_mom2D.F90 b/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_mom2D.F90 deleted file mode 100644 index d336f118b6..0000000000 --- a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_mom2D.F90 +++ /dev/null @@ -1,114 +0,0 @@ - -subroutine diffuse_mom2D - -! momentum tendency due to SGS diffusion - -use crmx_vars -use crmx_sgs, only: tk, grdf_x, grdf_z -use crmx_params, only: docolumn -implicit none - -real rdx2,rdz2,rdz,rdx25,rdz25,rdx21,rdx251 -real dxz,dzx - -integer i,j,k,ic,ib,kc,kcu -real tkx, tkz, rhoi, iadzw, iadz -real fu(0:nx,1,nz),fv(0:nx,1,nz),fw(0:nx,1,nz) - -rdx2=1./dx/dx -rdx25=0.25*rdx2 - -dxz=dx/dz - -j=1 - -if(.not.docolumn) then - - -do k=1,nzm - - kc=k+1 - kcu=min(kc,nzm) - dxz=dx/(dz*adzw(kc)) - rdx21=rdx2 * grdf_x(k) - rdx251=rdx25 * grdf_x(k) - - do i=0,nx - ic=i+1 - tkx=rdx21*tk(i,j,k) - fu(i,j,k)=-2.*tkx*(u(ic,j,k)-u(i,j,k)) - fv(i,j,k)=-tkx*(v(ic,j,k)-v(i,j,k)) - tkx=rdx251*(tk(i,j,k)+tk(ic,j,k)+tk(i,j,kcu)+tk(ic,j,kcu)) - fw(i,j,k)=-tkx*(w(ic,j,kc)-w(i,j,kc)+(u(ic,j,kcu)-u(ic,j,k))*dxz) - end do - do i=1,nx - ib=i-1 - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,k)-fu(ib,j,k)) - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,k)-fv(ib,j,k)) - dwdt(i,j,kc,na)=dwdt(i,j,kc,na)-(fw(i,j,k)-fw(ib,j,k)) - end do - -end do - -end if - -!------------------------- -rdz=1./dz -dzx=dz/dx - -do k=1,nzm-1 - kc=k+1 - uwsb(kc)=0. - vwsb(kc)=0. - iadz = 1./adz(k) - iadzw= 1./adzw(kc) - rdz2=rdz*rdz *grdf_z(k) - rdz25=0.25*rdz2 - do i=1,nx - ib=i-1 - tkz=rdz2*tk(i,j,k) - fw(i,j,kc)=-2.*tkz*(w(i,j,kc)-w(i,j,k))*rho(k)*iadz - tkz=rdz25*(tk(i,j,k)+tk(ib,j,k)+tk(i,j,kc)+tk(ib,j,kc)) - fu(i,j,kc)=-tkz*( (u(i,j,kc)-u(i,j,k))*iadzw + & - (w(i,j,kc)-w(ib,j,kc))*dzx)*rhow(kc) - fv(i,j,kc)=-tkz*(v(i,j,kc)-v(i,j,k))*iadzw*rhow(kc) - uwsb(kc)=uwsb(kc)+fu(i,j,kc) - vwsb(kc)=vwsb(kc)+fv(i,j,kc) - end do -end do - -uwsb(1) = 0. -vwsb(1) = 0. - -do i=1,nx - tkz=rdz2*grdf_z(nzm)*tk(i,j,nzm) - fw(i,j,nz)=-2.*tkz*(w(i,j,nz)-w(i,j,nzm))/adz(nzm)*rho(nzm) - fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1) - fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1) - fu(i,j,nz)=fluxtu(i,j) * rdz * rhow(nz) - fv(i,j,nz)=fluxtv(i,j) * rdz * rhow(nz) - uwsb(1) = uwsb(1) + fu(i,j,1) - vwsb(1) = vwsb(1) + fv(i,j,1) -end do - - -do k=1,nzm - kc=k+1 - rhoi = 1./(rho(k)*adz(k)) - do i=1,nx - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,kc)-fu(i,j,k))*rhoi - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,kc)-fv(i,j,k))*rhoi - end do -end do ! k - -do k=2,nzm - rhoi = 1./(rhow(k)*adzw(k)) - do i=1,nx - dwdt(i,j,k,na)=dwdt(i,j,k,na)-(fw(i,j,k+1)-fw(i,j,k))*rhoi - end do -end do ! k - - -end subroutine diffuse_mom2D - - diff --git a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_mom3D.F90 b/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_mom3D.F90 deleted file mode 100644 index 18df252162..0000000000 --- a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_mom3D.F90 +++ /dev/null @@ -1,150 +0,0 @@ - -subroutine diffuse_mom3D - -! momentum tendency due to SGS diffusion - -use crmx_vars -use crmx_sgs, only: tk, grdf_x, grdf_y, grdf_z -use crmx_params, only: docolumn -implicit none - -real rdx2,rdy2,rdz2,rdz,rdx25,rdy25 -real rdx21,rdy21,rdx251,rdy251,rdz25 -real dxy,dxz,dyx,dyz,dzx,dzy - -integer i,j,k,ic,ib,jb,jc,kc,kcu -real tkx, tky, tkz, rhoi, iadzw, iadz -real fu(0:nx,0:ny,nz),fv(0:nx,0:ny,nz),fw(0:nx,0:ny,nz) - -rdx2=1./(dx*dx) -rdy2=1./(dy*dy) - -rdx25=0.25*rdx2 -rdy25=0.25*rdy2 - -dxy=dx/dy -dxz=dx/dz -dyx=dy/dx -dyz=dy/dz - - -do k=1,nzm - kc=k+1 - kcu=min(kc,nzm) - dxz=dx/(dz*adzw(kc)) - dyz=dy/(dz*adzw(kc)) - rdx21=rdx2 * grdf_x(k) - rdy21=rdy2 * grdf_y(k) - rdx251=rdx25 * grdf_x(k) - rdy251=rdy25 * grdf_y(k) - do j=1,ny - jb=j-1 - do i=0,nx - ic=i+1 - tkx=rdx21*tk(i,j,k) - fu(i,j,k)=-2.*tkx*(u(ic,j,k)-u(i,j,k)) - tkx=rdx251*(tk(i,j,k)+tk(i,jb,k)+tk(ic,j,k)+tk(ic,jb,k)) - fv(i,j,k)=-tkx*(v(ic,j,k)-v(i,j,k)+(u(ic,j,k)-u(ic,jb,k))*dxy) - tkx=rdx251*(tk(i,j,k)+tk(ic,j,k)+tk(i,j,kcu)+tk(ic,j,kcu)) - fw(i,j,k)=-tkx*(w(ic,j,kc)-w(i,j,kc)+(u(ic,j,kcu)-u(ic,j,k))*dxz) - end do - do i=1,nx - ib=i-1 - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,k)-fu(ib,j,k)) - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,k)-fv(ib,j,k)) - dwdt(i,j,kc,na)=dwdt(i,j,kc,na)-(fw(i,j,k)-fw(ib,j,k)) - end do - end do - - do j=0,ny - jc=j+1 - do i=1,nx - ib=i-1 - tky=rdy21*tk(i,j,k) - fv(i,j,k)=-2.*tky*(v(i,jc,k)-v(i,j,k)) - tky=rdy251*(tk(i,j,k)+tk(ib,j,k)+tk(i,jc,k)+tk(ib,jc,k)) - fu(i,j,k)=-tky*(u(i,jc,k)-u(i,j,k)+(v(i,jc,k)-v(ib,jc,k))*dyx) - tky=rdy251*(tk(i,j,k)+tk(i,jc,k)+tk(i,j,kcu)+tk(i,jc,kcu)) - fw(i,j,k)=-tky*(w(i,jc,kc)-w(i,j,kc)+(v(i,jc,kcu)-v(i,jc,k))*dyz) - end do - end do - do j=1,ny - jb=j-1 - do i=1,nx - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,k)-fu(i,jb,k)) - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,k)-fv(i,jb,k)) - dwdt(i,j,kc,na)=dwdt(i,j,kc,na)-(fw(i,j,k)-fw(i,jb,k)) - end do - end do - -end do - -!------------------------- -rdz=1./dz -dzx=dz/dx -dzy=dz/dy - -do k=1,nzm-1 - kc=k+1 - uwsb(kc)=0. - vwsb(kc)=0. - iadz = 1./adz(k) - iadzw= 1./adzw(kc) - rdz2 = rdz*rdz * grdf_z(k) - rdz25 = 0.25*rdz2 - do j=1,ny - jb=j-1 - do i=1,nx - ib=i-1 - tkz=rdz2*tk(i,j,k) - fw(i,j,kc)=-2.*tkz*(w(i,j,kc)-w(i,j,k))*rho(k)*iadz - tkz=rdz25*(tk(i,j,k)+tk(ib,j,k)+tk(i,j,kc)+tk(ib,j,kc)) - fu(i,j,kc)=-tkz*( (u(i,j,kc)-u(i,j,k))*iadzw + & - (w(i,j,kc)-w(ib,j,kc))*dzx)*rhow(kc) - tkz=rdz25*(tk(i,j,k)+tk(i,jb,k)+tk(i,j,kc)+tk(i,jb,kc)) - fv(i,j,kc)=-tkz*( (v(i,j,kc)-v(i,j,k))*iadzw + & - (w(i,j,kc)-w(i,jb,kc))*dzy)*rhow(kc) - uwsb(kc)=uwsb(kc)+fu(i,j,kc) - vwsb(kc)=vwsb(kc)+fv(i,j,kc) - end do - end do -end do - -uwsb(1) = 0. -vwsb(1) = 0. - -do j=1,ny - do i=1,nx - tkz=rdz2*grdf_z(nzm)*tk(i,j,nzm) - fw(i,j,nz)=-2.*tkz*(w(i,j,nz)-w(i,j,nzm))/adz(nzm)*rho(nzm) - fu(i,j,1)=fluxbu(i,j) * rdz * rhow(1) - fv(i,j,1)=fluxbv(i,j) * rdz * rhow(1) - fu(i,j,nz)=fluxtu(i,j) * rdz * rhow(nz) - fv(i,j,nz)=fluxtv(i,j) * rdz * rhow(nz) - uwsb(1) = uwsb(1) + fu(i,j,1) - vwsb(1) = vwsb(1) + fv(i,j,1) - end do - end do - - do k=1,nzm - kc=k+1 - rhoi = 1./(rho(k)*adz(k)) - do j=1,ny - do i=1,nx - dudt(i,j,k,na)=dudt(i,j,k,na)-(fu(i,j,kc)-fu(i,j,k))*rhoi - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fv(i,j,kc)-fv(i,j,k))*rhoi - end do - end do - end do ! k - - do k=2,nzm - rhoi = 1./(rhow(k)*adzw(k)) - do j=1,ny - do i=1,nx - dwdt(i,j,k,na)=dwdt(i,j,k,na)-(fw(i,j,k+1)-fw(i,j,k))*rhoi - end do - end do - end do ! k - - -end subroutine diffuse_mom3D diff --git a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_scalar.F90 b/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_scalar.F90 deleted file mode 100644 index a5b48d4fd8..0000000000 --- a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_scalar.F90 +++ /dev/null @@ -1,42 +0,0 @@ -subroutine diffuse_scalar (f,fluxb,fluxt, & - fdiff,flux,f2lediff,f2lediss,fwlediff,doit) - -use crmx_grid -use crmx_vars, only: rho, rhow -use crmx_sgs, only: tkh -implicit none - -! input: -real f(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real flux(nz) -real f2lediff(nz),f2lediss(nz),fwlediff(nz) -real fdiff(nz) -logical doit -! Local -real df(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -integer i,j,k - -!call t_startf ('diffuse_scalars') - -df(:,:,:) = f(:,:,:) - -if(RUN3D) then - call diffuse_scalar3D (f,fluxb,fluxt,tkh,rho,rhow,flux) -else - call diffuse_scalar2D (f,fluxb,fluxt,tkh,rho,rhow,flux) -endif - -do k=1,nzm - fdiff(k)=0. - do j=1,ny - do i=1,nx - fdiff(k)=fdiff(k)+f(i,j,k)-df(i,j,k) - end do - end do -end do - -!call t_stopf ('diffuse_scalars') - -end subroutine diffuse_scalar diff --git a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_scalar2D.F90 b/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_scalar2D.F90 deleted file mode 100644 index d8ff8f7587..0000000000 --- a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_scalar2D.F90 +++ /dev/null @@ -1,103 +0,0 @@ -subroutine diffuse_scalar2D (field,fluxb,fluxt,tkh,rho,rhow,flux) - -use crmx_grid -use crmx_params, only: docolumn,dowallx,dosgs -use crmx_sgs,only: grdf_x,grdf_z -implicit none - -! input -real field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real tkh(0:nxp1, 1-YES3D:nyp1, nzm) ! eddy conductivity -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real rho(nzm) -real rhow(nz) -real flux(nz) - -! local -real flx(0:nx,1,0:nzm) -real dfdt(nx,ny,nzm) -real rdx2,rdz2,rdz,rdx5,rdz5,tmp -real dxz,dzx,tkx,tkz,rhoi -integer i,j,k,ib,ic,kc,kb - -if(.not.dosgs.and..not.docolumn) return - -rdx2=1./(dx*dx) -rdz2=1./(dz*dz) -rdz=1./dz -dxz=dx/dz -dzx=dz/dx - -j=1 - -dfdt(:,:,:)=0. - -if(dowallx) then - - if(mod(rank,nsubdomains_x).eq.0) then - do k=1,nzm - field(0,j,k) = field(1,j,k) - end do - end if - if(mod(rank,nsubdomains_x).eq.nsubdomains_x-1) then - do k=1,nzm - field(nx+1,j,k) = field(nx,j,k) - end do - end if - -end if - - -if(.not.docolumn) then - - -do k=1,nzm - - rdx5=0.5*rdx2 *grdf_x(k) - - do i=0,nx - ic=i+1 - tkx=rdx5*(tkh(i,j,k)+tkh(ic,j,k)) - flx(i,j,k)=-tkx*(field(ic,j,k)-field(i,j,k)) - end do - do i=1,nx - ib=i-1 - dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(ib,j,k)) - end do - -end do - -end if - -flux(1) = 0. -tmp=1./adzw(nz) -do i=1,nx - flx(i,j,0)=fluxb(i,j)*rdz*rhow(1) - flx(i,j,nzm)=fluxt(i,j)*rdz*tmp*rhow(nz) - flux(1) = flux(1) + flx(i,j,0) -end do - - -do k=1,nzm-1 - kc=k+1 - flux(kc)=0. - rhoi = rhow(kc)/adzw(kc) - rdz5=0.5*rdz2 * grdf_z(k) - do i=1,nx - tkz=rdz5*(tkh(i,j,k)+tkh(i,j,kc)) - flx(i,j,k)=-tkz*(field(i,j,kc)-field(i,j,k))*rhoi - flux(kc) = flux(kc) + flx(i,j,k) - end do -end do - -do k=1,nzm - kb=k-1 - rhoi = 1./(adz(k)*rho(k)) - do i=1,nx - dfdt(i,j,k)=dtn*(dfdt(i,j,k)-(flx(i,j,k)-flx(i,j,kb))*rhoi) - field(i,j,k)=field(i,j,k) + dfdt(i,j,k) - end do -end do - -end subroutine diffuse_scalar2D diff --git a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_scalar3D.F90 b/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_scalar3D.F90 deleted file mode 100644 index f166ee61ea..0000000000 --- a/src/physics/spcam/crm/SGS_TKE/crmx_diffuse_scalar3D.F90 +++ /dev/null @@ -1,177 +0,0 @@ -subroutine diffuse_scalar3D (field,fluxb,fluxt,tkh,rho,rhow,flux) - -use crmx_grid -use crmx_params, only: docolumn,dowallx,dowally,dosgs -use crmx_sgs, only: grdf_x,grdf_y,grdf_z -implicit none -! input -real field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! scalar -real tkh(0:nxp1,1-YES3D:nyp1,nzm) ! eddy conductivity -real fluxb(nx,ny) ! bottom flux -real fluxt(nx,ny) ! top flux -real rho(nzm) -real rhow(nz) -real flux(nz) -! local -real flx(0:nx,0:ny,0:nzm) -real dfdt(nx,ny,nz) -real rdx2,rdy2,rdz2,rdz,rdx5,rdy5,rdz5,tmp -real dxy,dxz,dyx,dyz,dzx,dzy,tkx,tky,tkz,rhoi -integer i,j,k,ib,ic,jb,jc,kc,kb - - -if(.not.dosgs) return - -rdx2=1./(dx*dx) -rdy2=1./(dy*dy) -rdz2=1./(dz*dz) -rdz=1./dz -dxy=dx/dy -dxz=dx/dz -dyx=dy/dx -dyz=dy/dz -dzx=dz/dx -dzy=dz/dy - -dfdt(:,:,:)=0. - -!----------------------------------------- -if(dowallx) then - - if(mod(rank,nsubdomains_x).eq.0) then - do k=1,nzm - do j=1,ny - field(0,j,k) = field(1,j,k) - end do - end do - end if - if(mod(rank,nsubdomains_x).eq.nsubdomains_x-1) then - do k=1,nzm - do j=1,ny - field(nx+1,j,k) = field(nx,j,k) - end do - end do - end if - -end if - -if(dowally) then - - if(rank.lt.nsubdomains_x) then - do k=1,nzm - do i=1,nx - field(i,1-YES3D,k) = field(i,1,k) - end do - end do - end if - if(rank.gt.nsubdomains-nsubdomains_x-1) then - do k=1,nzm - do i=1,ny - field(i,ny+YES3D,k) = field(i,ny,k) - end do - end do - end if - -end if - - - -if(dowally) then - - call task_rank_to_index(rank, ib, jb) - if(jb.eq.0) then - do k=1,nzm - do i=1,nx - field(i,1-YES3D,k) = field(i,1,k) - end do - end do - end if - if(jb.eq.nsubdomains_y-1) then - do k=1,nzm - do i=1,nx - field(i,ny+YES3D,k) = field(i,ny,k) - end do - end do - end if - -end if - -!----------------------------------------- - - -! Horizontal diffusion: - - -do k=1,nzm - - rdx5=0.5*rdx2 * grdf_x(k) - rdy5=0.5*rdy2 * grdf_y(k) - - do j=1,ny - do i=0,nx - ic=i+1 - tkx=rdx5*(tkh(i,j,k)+tkh(ic,j,k)) - flx(i,j,k)=-tkx*(field(ic,j,k)-field(i,j,k)) - end do - do i=1,nx - ib=i-1 - dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(ib,j,k)) - end do - end do - - do j=0,ny - jc=j+1 - do i=1,nx - tky=rdy5*(tkh(i,j,k)+tkh(i,jc,k)) - flx(i,j,k)=-tky*(field(i,jc,k)-field(i,j,k)) - end do - end do - do j=1,ny - jb=j-1 - do i=1,nx - dfdt(i,j,k)=dfdt(i,j,k)-(flx(i,j,k)-flx(i,jb,k)) - end do - end do - -end do ! k - - -! Vertical diffusion: - -flux(1) = 0. -tmp=1./adzw(nz) -do j=1,ny - do i=1,nx - flx(i,j,0)=fluxb(i,j)*rdz*rhow(1) - flx(i,j,nzm)=fluxt(i,j)*rdz*tmp*rhow(nz) - flux(1) = flux(1) + flx(i,j,0) - end do -end do - - -do k=1,nzm-1 - kc=k+1 - flux(kc)=0. - rhoi = rhow(kc)/adzw(kc) - rdz5=0.5*rdz2 * grdf_z(k) - do j=1,ny - do i=1,nx - tkz=rdz5*(tkh(i,j,k)+tkh(i,j,kc)) - flx(i,j,k)=-tkz*(field(i,j,kc)-field(i,j,k))*rhoi - flux(kc) = flux(kc) + flx(i,j,k) - end do - end do -end do - -do k=1,nzm - kb=k-1 - rhoi = 1./(adz(k)*rho(k)) - do j=1,ny - do i=1,nx - dfdt(i,j,k)=dtn*(dfdt(i,j,k)-(flx(i,j,k)-flx(i,j,kb))*rhoi) - field(i,j,k)=field(i,j,k)+dfdt(i,j,k) - end do - end do -end do - -end subroutine diffuse_scalar3D diff --git a/src/physics/spcam/crm/SGS_TKE/crmx_sgs.F90 b/src/physics/spcam/crm/SGS_TKE/crmx_sgs.F90 deleted file mode 100644 index b252482838..0000000000 --- a/src/physics/spcam/crm/SGS_TKE/crmx_sgs.F90 +++ /dev/null @@ -1,422 +0,0 @@ -module crmx_sgs - -! module for original SAM subgrid-scale SGS closure (Smagorinsky or 1st-order TKE) -! Marat Khairoutdinov, 2012 - -use crmx_grid, only: nx,nxp1,ny,nyp1,YES3D,nzm,nz,dimx1_s,dimx2_s,dimy1_s,dimy2_s -use crmx_params, only: dosgs -use crmx_vars, only: tke2, tk2 -implicit none - -!---------------------------------------------------------------------- -! Required definitions: - -!!! prognostic scalar (need to be advected arround the grid): - -integer, parameter :: nsgs_fields = 1 ! total number of prognostic sgs vars - -real sgs_field(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm, nsgs_fields) - -!!! sgs diagnostic variables that need to exchange boundary information (via MPI): - -integer, parameter :: nsgs_fields_diag = 2 ! total number of diagnostic sgs vars - -! diagnostic fields' boundaries: -integer, parameter :: dimx1_d=0, dimx2_d=nxp1, dimy1_d=1-YES3D, dimy2_d=nyp1 - -real sgs_field_diag(dimx1_d:dimx2_d, dimy1_d:dimy2_d, nzm, nsgs_fields_diag) - -logical:: advect_sgs = .false. ! advect prognostics or not, default - not (Smagorinsky) -logical, parameter:: do_sgsdiag_bound = .true. ! exchange boundaries for diagnostics fields - -! SGS fields that output by default (if =1). -integer, parameter :: flag_sgs3Dout(nsgs_fields) = (/0/) -integer, parameter :: flag_sgsdiag3Dout(nsgs_fields_diag) = (/0,0/) - -real fluxbsgs (nx, ny, 1:nsgs_fields) ! surface fluxes -real fluxtsgs (nx, ny, 1:nsgs_fields) ! top boundary fluxes - -!!! these arrays may be needed for output statistics: - -real sgswle(nz,1:nsgs_fields) ! resolved vertical flux -real sgswsb(nz,1:nsgs_fields) ! SGS vertical flux -real sgsadv(nz,1:nsgs_fields) ! tendency due to vertical advection -real sgslsadv(nz,1:nsgs_fields) ! tendency due to large-scale vertical advection -real sgsdiff(nz,1:nsgs_fields) ! tendency due to vertical diffusion - -!------------------------------------------------------------------ -! internal (optional) definitions: - -! make aliases for prognostic variables: - -real tke(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! SGS TKE -equivalence (tke(dimx1_s,dimy1_s,1),sgs_field(dimx1_s,dimy1_s,1,1)) - -! make aliases for diagnostic variables: - -real tk (dimx1_d:dimx2_d, dimy1_d:dimy2_d, nzm) ! SGS eddy viscosity -real tkh (dimx1_d:dimx2_d, dimy1_d:dimy2_d, nzm) ! SGS eddy conductivity -equivalence (tk(dimx1_d,dimy1_d,1), sgs_field_diag(dimx1_d, dimy1_d,1,1)) -equivalence (tkh(dimx1_d,dimy1_d,1), sgs_field_diag(dimx1_d, dimy1_d,1,2)) - - -real grdf_x(nzm)! grid factor for eddy diffusion in x -real grdf_y(nzm)! grid factor for eddy diffusion in y -real grdf_z(nzm)! grid factor for eddy diffusion in z - -logical:: dosmagor ! if true, then use Smagorinsky closure - -! Local diagnostics: - -real tkesbbuoy(nz), tkesbshear(nz),tkesbdiss(nz), tkesbdiff(nz) - -CONTAINS - -! required microphysics subroutines and function: -!---------------------------------------------------------------------- -!!! Read microphysics options from prm (namelist) file - -subroutine sgs_setparm() - - use crmx_grid, only: case - implicit none - - integer ierr, ios, ios_missing_namelist, place_holder - - !====================================================================== - NAMELIST /SGS_TKE/ & - dosmagor ! Diagnostic Smagorinsky closure - - NAMELIST /BNCUIODSBJCB/ place_holder - - dosmagor = .true. ! default - - !---------------------------------- - ! Read namelist for microphysics options from prm file: - !------------ - !open(55,file='./'//trim(case)//'/prm', status='old',form='formatted') - - !read (UNIT=55,NML=BNCUIODSBJCB,IOSTAT=ios_missing_namelist) - !rewind(55) !note that one must rewind before searching for new namelists - - !read (55,SGS_TKE,IOSTAT=ios) - - advect_sgs = .not.dosmagor - - !if (ios.ne.0) then - ! !namelist error checking - ! if(ios.ne.ios_missing_namelist) then - ! write(*,*) '****** ERROR: bad specification in SGS_TKE namelist' - ! call task_abort() - ! end if - !end if - !close(55) - - ! END UW ADDITION - !====================================================================== - -end subroutine sgs_setparm - -!---------------------------------------------------------------------- -!!! Initialize sgs: - - -subroutine sgs_init() - - use crmx_grid, only: nrestart, dx, dy, dz, adz, masterproc - use crmx_params, only: LES - integer k - - if(nrestart.eq.0) then - - sgs_field = 0. - sgs_field_diag = 0. - - fluxbsgs = 0. - fluxtsgs = 0. - - end if - -! if(masterproc) then -! if(dosmagor) then -! write(*,*) 'Smagorinsky SGS Closure' -! else -! write(*,*) 'Prognostic TKE 1.5-order SGS Closure' -! end if -! end if - - if(LES) then - do k=1,nzm - grdf_x(k) = dx**2/(adz(k)*dz)**2 - grdf_y(k) = dy**2/(adz(k)*dz)**2 - grdf_z(k) = 1. - end do - else - do k=1,nzm - grdf_x(k) = min(16.,dx**2/(adz(k)*dz)**2) - grdf_y(k) = min(16.,dy**2/(adz(k)*dz)**2) - grdf_z(k) = 1. - end do - end if - - sgswle = 0. - sgswsb = 0. - sgsadv = 0. - sgsdiff = 0. - sgslsadv = 0. - - -end subroutine sgs_init - -!---------------------------------------------------------------------- -!!! make some initial noise in sgs: -! -subroutine setperturb_sgs(ptype) - -use crmx_vars, only: q0, z -integer, intent(in) :: ptype -integer i,j,k - -select case (ptype) - - case(0) - - do k=1,nzm - do j=1,ny - do i=1,nx - if(k.le.4.and..not.dosmagor) then - tke(i,j,k)=0.04*(5-k) - endif - end do - end do - end do - - case(1) - - do k=1,nzm - do j=1,ny - do i=1,nx - if(q0(k).gt.6.e-3.and..not.dosmagor) then - tke(i,j,k)=1. - endif - end do - end do - end do - - case(2) - - case(3) ! gcss wg1 smoke-cloud case - - do k=1,nzm - do j=1,ny - do i=1,nx - if(q0(k).gt.0.5e-3.and..not.dosmagor) then - tke(i,j,k)=1. - endif - end do - end do - end do - - - case(4) ! gcss wg1 arm case - - do k=1,nzm - do j=1,ny - do i=1,nx - if(z(k).le.150..and..not.dosmagor) then - tke(i,j,k)=0.15*(1.-z(k)/150.) - endif - end do - end do - end do - - - case(5) ! gcss wg1 BOMEX case - - do k=1,nzm - do j=1,ny - do i=1,nx - if(z(k).le.3000..and..not.dosmagor) then - tke(i,j,k)=1.-z(k)/3000. - endif - end do - end do - end do - - case(6) ! GCSS Lagragngian ASTEX - - - do k=1,nzm - do j=1,ny - do i=1,nx - if(q0(k).gt.6.e-3.and..not.dosmagor) then - tke(i,j,k)=1. - endif - end do - end do - end do - - - case default - -end select - -end subroutine setperturb_sgs - -!---------------------------------------------------------------------- -!!! Estimate Courant number limit for SGS -! - -subroutine kurant_sgs(cfl) - -use crmx_grid, only: dt, dx, dy, dz, adz, adzw -implicit none - -real, intent(out) :: cfl - -integer k -real tkhmax(nz) - -do k = 1,nzm - tkhmax(k) = maxval(tkh(1:nx,1:ny,k)) -end do - -cfl = 0. -do k=1,nzm - cfl = max(cfl, & - 0.5*tkhmax(k)*grdf_z(k)*dt/(dz*adzw(k))**2, & - 0.5*tkhmax(k)*grdf_x(k)*dt/dx**2, & - YES3D*0.5*tkhmax(k)*grdf_y(k)*dt/dy**2) -end do - -end subroutine kurant_sgs - - -!---------------------------------------------------------------------- -!!! compute sgs diffusion of momentum: -! -subroutine sgs_mom() - - call diffuse_mom() - -end subroutine sgs_mom - -!---------------------------------------------------------------------- -!!! compute sgs diffusion of scalars: -! -subroutine sgs_scalars() - - use crmx_vars - use crmx_microphysics - use crmx_crmtracers - use crmx_params, only: dotracers - implicit none - - real dummy(nz) - real fluxbtmp(nx,ny), fluxttmp(nx,ny) !bloss - integer k - - - call diffuse_scalar(t,fluxbt,fluxtt,tdiff,twsb, & - t2lediff,t2lediss,twlediff,.true.) - - if(advect_sgs) then - call diffuse_scalar(tke,fzero,fzero,dummy,sgswsb, & - dummy,dummy,dummy,.false.) - end if - - -! -! diffusion of microphysics prognostics: -! - call micro_flux() - - total_water_evap = total_water_evap - total_water() - - do k = 1,nmicro_fields - if( k.eq.index_water_vapor &! transport water-vapor variable no metter what - .or. docloud.and.flag_precip(k).ne.1 & ! transport non-precipitation vars - .or. doprecip.and.flag_precip(k).eq.1 ) then - fluxbtmp(1:nx,1:ny) = fluxbmk(1:nx,1:ny,k) - fluxttmp(1:nx,1:ny) = fluxtmk(1:nx,1:ny,k) - call diffuse_scalar(micro_field(:,:,:,k),fluxbtmp,fluxttmp, & - mkdiff(:,k),mkwsb(:,k), dummy,dummy,dummy,.false.) - end if - end do - - total_water_evap = total_water_evap + total_water() - - ! diffusion of tracers: - - if(dotracers) then - - call tracers_flux() - - do k = 1,ntracers - - fluxbtmp = fluxbtr(:,:,k) - fluxttmp = fluxttr(:,:,k) - call diffuse_scalar(tracer(:,:,:,k),fluxbtmp,fluxttmp, & - trdiff(:,k),trwsb(:,k), & - dummy,dummy,dummy,.false.) -!!$ call diffuse_scalar(tracer(:,:,:,k),fluxbtr(:,:,k),fluxttr(:,:,k),trdiff(:,k),trwsb(:,k), & -!!$ dummy,dummy,dummy,.false.) - - end do - - end if - - - -end subroutine sgs_scalars - -!---------------------------------------------------------------------- -!!! compute sgs processes (beyond advection): -! -subroutine sgs_proc() - - use crmx_grid, only: nstep,dt,icycle - use crmx_params, only: dosmoke - -! SGS TKE equation: - - if(dosgs) call tke_full() - - tke2 = tke - tk2 = tk - -end subroutine sgs_proc - -!---------------------------------------------------------------------- -!!! Diagnose arrays nessesary for dynamical core and statistics: -! -subroutine sgs_diagnose() -! None - -end subroutine sgs_diagnose - -!---------------------------------------------------------------------- -! called when stepout() called - -subroutine sgs_print() - - call fminmax_print('tke:',tke,dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm) - call fminmax_print('tk:',tk,0,nxp1,1-YES3D,nyp1,nzm) - call fminmax_print('tkh:',tkh,0,nxp1,1-YES3D,nyp1,nzm) - -end subroutine sgs_print - -!---------------------------------------------------------------------- -!!! Initialize the list of sgs statistics -! -subroutine sgs_hbuf_init(namelist,deflist,unitlist,status,average_type,count,sgscount) -character(*) namelist(*), deflist(*), unitlist(*) -integer status(*),average_type(*),count,sgscount - -end subroutine sgs_hbuf_init - - -end module crmx_sgs - - - diff --git a/src/physics/spcam/crm/SGS_TKE/crmx_shear_prod2D.F90 b/src/physics/spcam/crm/SGS_TKE/crmx_shear_prod2D.F90 deleted file mode 100644 index 50fe343ebe..0000000000 --- a/src/physics/spcam/crm/SGS_TKE/crmx_shear_prod2D.F90 +++ /dev/null @@ -1,109 +0,0 @@ - -subroutine shear_prod2D(def2) - -use crmx_vars -implicit none - -real def2(nx,ny,nzm) - -real rdx0,rdx,rdx_up,rdx_dn -real rdz,rdzw_up,rdzw_dn -integer i,j,k,ib,ic,kb,kc - -rdx0=1./dx -j=1 - - -do k=2,nzm-1 - - kb=k-1 - kc=k+1 - rdz = 1./(dz*adz(k)) - rdzw_up = 1./(dz*adzw(kc)) - rdzw_dn = 1./(dz*adzw(k)) - rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy - rdx_up=rdx0 * sqrt(dx*rdzw_up) - rdx_dn=rdx0 * sqrt(dx*rdzw_dn) - - do i=1,nx - ib=i-1 - ic=i+1 - - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.5 * ( & - ( (v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (v(i ,j ,k)-v(ib,j ,k))*rdx )**2 + & - ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ & - (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + & - ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ & - (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 + & - ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ & - (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + & - ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ & - (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 + & - ( (v(i,j ,kc)-v0(kc)-v(i,j , k)+v0(k))*rdzw_up )**2 + & - ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn )**2 ) - - end do -end do ! k - - -k=1 -kc=k+1 - -rdz = 1./(dz*adz(k)) -rdzw_up = 1./(dz*adzw(kc)) -rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy -rdx_up=rdx0 * sqrt(dx*rdzw_up) - -do i=1,nx - ib=i-1 - ic=i+1 - - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.5 * ( & - ( (v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) & - +( (v(i,j ,kc)-v0(kc)-v(i,j,k)+v0(k))*rdzw_up )**2 & - + 0.5 * ( & - ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ & - (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + & - ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ & - (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 ) -end do - -k=nzm -kc=k+1 -kb=k-1 - -rdz = 1./(dz*adz(k)) -rdzw_dn = 1./(dz*adzw(k)) -rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy -rdx_dn=rdx0 * sqrt(dx*rdzw_dn) - - -do i=1,nx - ib=i-1 - ic=i+1 - - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.5 * ( & - ( (v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) & - + ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn )**2 & - + 0.5 * ( & - ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ & - (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + & - ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ & - (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 ) - -end do - -end - diff --git a/src/physics/spcam/crm/SGS_TKE/crmx_shear_prod3D.F90 b/src/physics/spcam/crm/SGS_TKE/crmx_shear_prod3D.F90 deleted file mode 100644 index 2ecd9c25a6..0000000000 --- a/src/physics/spcam/crm/SGS_TKE/crmx_shear_prod3D.F90 +++ /dev/null @@ -1,155 +0,0 @@ - -subroutine shear_prod3D(def2) - -use crmx_vars -implicit none - -real def2(nx,ny,nzm) - -real rdx0,rdx,rdx_up,rdx_dn -real rdy0,rdy,rdy_up,rdy_dn -real rdz,rdzw_up,rdzw_dn -integer i,j,k,ib,ic,jb,jc,kb,kc - -rdx0=1./dx -rdy0=1./dy - -do k=2,nzm-1 - - kb=k-1 - kc=k+1 - rdz = 1./(dz*adz(k)) - rdzw_up = 1./(dz*adzw(kc)) - rdzw_dn = 1./(dz*adzw(k)) - rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy - rdy=rdy0 * sqrt(dy*rdz) - rdx_up=rdx0 * sqrt(dx*rdzw_up) - rdy_up=rdy0 * sqrt(dy*rdzw_up) - rdx_dn=rdx0 * sqrt(dx*rdzw_dn) - rdy_dn=rdy0 * sqrt(dy*rdzw_dn) - - do j=1,ny - jb=j-YES3D - jc=j+YES3D - do i=1,nx - ib=i-1 - ic=i+1 - - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (v(i,jc,k)-v(i,j,k))*rdy)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.25 * ( & - ( (u(ic,jc,k)-u(ic,j ,k))*rdy+(v(ic,jc,k)-v(i ,jc,k))*rdx )**2 + & - ( (u(i ,jc,k)-u(i ,j ,k))*rdy+(v(i ,jc,k)-v(ib,jc,k))*rdx )**2 + & - ( (u(ic,j ,k)-u(ic,jb,k))*rdy+(v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (u(i ,j ,k)-u(i ,jb,k))*rdy+(v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) - def2(i,j,k)=def2(i,j,k) & - + 0.25 * ( & - ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ & - (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + & - ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ & - (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 + & - ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ & - (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + & - ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ & - (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 ) - def2(i,j,k)=def2(i,j,k) & - + 0.25 * ( & - ( (v(i,jc,kc)-v0(kc)-v(i,jc, k)+v0(k))*rdzw_up+ & - (w(i,jc,kc)-w(i,j ,kc))*rdy_up )**2 + & - ( (v(i,j ,kc)-v0(kc)-v(i,j , k)+v0(k))*rdzw_up+ & - (w(i,j ,kc)-w(i,jb,kc))*rdy_up )**2 + & - ( (v(i,jc,k )-v0(k)-v(i,jc,kb)+v0(kb))*rdzw_dn+ & - (w(i,jc,k )-w(i,j ,k ))*rdy_dn )**2 + & - ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn+ & - (w(i,j ,k )-w(i,jb,k ))*rdy_dn )**2 ) - - end do - end do -end do ! k - - -k=1 -kc=k+1 - -rdz = 1./(dz*adz(k)) -rdzw_up = 1./(dz*adzw(kc)) -rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy -rdy=rdy0 * sqrt(dy*rdz) -rdx_up=rdx0 * sqrt(dx*rdzw_up) -rdy_up=rdy0 * sqrt(dy*rdzw_up) - -do j=1,ny - jb=j-YES3D - jc=j+YES3D - do i=1,nx - ib=i-1 - ic=i+1 - - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (v(i,jc,k)-v(i,j,k))*rdy)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.25 * ( & - ( (u(ic,jc,k)-u(ic,j ,k))*rdy+(v(ic,jc,k)-v(i ,jc,k))*rdx )**2 + & - ( (u(i ,jc,k)-u(i ,j ,k))*rdy+(v(i ,jc,k)-v(ib,jc,k))*rdx )**2 + & - ( (u(ic,j ,k)-u(ic,jb,k))*rdy+(v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (u(i ,j ,k)-u(i ,jb,k))*rdy+(v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) & - + 0.5 * ( & - ( (v(i,jc,kc)-v0(kc)-v(i,jc, k)+v0(k))*rdzw_up+ & - (w(i,jc,kc)-w(i,j ,kc))*rdy_up )**2 + & - ( (v(i,j ,kc)-v0(kc)-v(i,j , k)+v0(k))*rdzw_up+ & - (w(i,j ,kc)-w(i,jb,kc))*rdy_up )**2 ) & - + 0.5 * ( & - ( (u(ic,j,kc)-u0(kc)-u(ic,j, k)+u0(k))*rdzw_up+ & - (w(ic,j,kc)-w(i ,j,kc))*rdx_up )**2 + & - ( (u(i ,j,kc)-u0(kc)-u(i ,j, k)+u0(k))*rdzw_up+ & - (w(i ,j,kc)-w(ib,j,kc))*rdx_up )**2 ) - - - end do -end do - - -k=nzm -kc=k+1 -kb=k-1 - -rdz = 1./(dz*adz(k)) -rdzw_dn = 1./(dz*adzw(k)) -rdx=rdx0 * sqrt(dx*rdz) ! take into account grid anisotropy -rdy=rdy0 * sqrt(dy*rdz) -rdx_dn=rdx0 * sqrt(dx*rdzw_dn) -rdy_dn=rdy0 * sqrt(dy*rdzw_dn) - -do j=1,ny - jb=j-1*YES3D - jc=j+1*YES3D - do i=1,nx - ib=i-1 - ic=i+1 - def2(i,j,k)=2.* ( & - ( (u(ic,j,k)-u(i,j,k))*rdx)**2+ & - ( (v(i,jc,k)-v(i,j,k))*rdy)**2+ & - ( (w(i,j,kc)-w(i,j,k))*rdz)**2 ) & - + 0.25 * ( & - ( (u(ic,jc,k)-u(ic,j ,k))*rdy+(v(ic,jc,k)-v(i ,jc,k))*rdx )**2 + & - ( (u(i ,jc,k)-u(i ,j ,k))*rdy+(v(i ,jc,k)-v(ib,jc,k))*rdx )**2 + & - ( (u(ic,j ,k)-u(ic,jb,k))*rdy+(v(ic,j ,k)-v(i ,j ,k))*rdx )**2 + & - ( (u(i ,j ,k)-u(i ,jb,k))*rdy+(v(i ,j ,k)-v(ib,j ,k))*rdx )**2 ) & - + 0.5 * ( & - ( (v(i,jc,k )-v0(k)-v(i,jc,kb)+v0(kb))*rdzw_dn+ & - (w(i,jc,k )-w(i,j ,k ))*rdy_dn )**2 + & - ( (v(i,j ,k )-v0(k)-v(i,j ,kb)+v0(kb))*rdzw_dn+ & - (w(i,j ,k )-w(i,jb,k ))*rdy_dn )**2 ) & - + 0.5 * ( & - ( (u(ic,j,k )-u0(k)-u(ic,j,kb)+u0(kb))*rdzw_dn+ & - (w(ic,j,k )-w(i ,j,k ))*rdx_dn )**2 + & - ( (u(i ,j,k )-u0(k)-u(i ,j,kb)+u0(kb))*rdzw_dn+ & - (w(i ,j,k )-w(ib,j,k ))*rdx_dn )**2 ) - end do -end do - -end - diff --git a/src/physics/spcam/crm/SGS_TKE/crmx_tke_full.F90 b/src/physics/spcam/crm/SGS_TKE/crmx_tke_full.F90 deleted file mode 100644 index 79dd936cdc..0000000000 --- a/src/physics/spcam/crm/SGS_TKE/crmx_tke_full.F90 +++ /dev/null @@ -1,147 +0,0 @@ - -subroutine tke_full - -! this subroutine solves the TKE equation - -use crmx_vars -use crmx_sgs -use crmx_params -implicit none - -real def2(nx,ny,nzm) -real grd,betdz,Ck,Ce,Ces,Ce1,Ce2,smix,Pr,Cee,Cs -real buoy_sgs,ratio,a_prod_sh,a_prod_bu,a_diss -real lstarn, lstarp, bbb, omn, omp -real qsatt,dqsat -integer i,j,k,kc,kb - -!call t_startf('tke_full') - -!Cs = 0.1944 -Cs = 0.15 -Ck=0.1 -Ce=Ck**3/Cs**4 -Ces=Ce/0.7*3.0 - -if(RUN3D) then - call shear_prod3D(def2) -else - call shear_prod2D(def2) -endif - -do k=1,nzm - kb=k-1 - kc=k+1 - - grd=dz*adz(k) - - betdz=bet(k)/dz/(adzw(kc)+adzw(k)) - Ce1=Ce/0.7*0.19 - Ce2=Ce/0.7*0.51 - if(k.eq.1) then - kb=1 - kc=2 - betdz=bet(k)/dz/adzw(kc) - Ce1=Ces/0.7*0.19 - Ce2=Ces/0.7*0.51 - end if - if(k.eq.nzm) then - kb=nzm-1 - kc=nzm - betdz=bet(k)/dz/adzw(k) - Ce1=Ces/0.7*0.19 - Ce2=Ces/0.7*0.51 - end if - tkelediss(k) = 0. - tkesbdiss(k) = 0. - tkesbshear(k)= 0. - tkesbbuoy(k) = 0. - do j=1,ny - do i=1,nx -! SGS buoyancy flux - -!bloss: removed temperature diagnostics for omn. -! - use mass weighted qsat, dqsat and latent heat for cloud -! - separate buoyancy contributions for precipitating water and ice. - - - if(qcl(i,j,k)+qci(i,j,k) .gt. 0.) then - - omn = qcl(i,j,k)/(qcl(i,j,k)+qci(i,j,k)+1.e-20) - lstarn = fac_cond+(1.-omn)*fac_fus - - dqsat = omn*dtqsatw_crm(tabs(i,j,k),pres(k))+ & - (1.-omn)*dtqsati_crm(tabs(i,j,k),pres(k)) - qsatt = omn*qsatw_crm(tabs(i,j,k),pres(k))+(1.-omn)*qsati_crm(tabs(i,j,k),pres(k)) - bbb = 1. + epsv*qsatt-qcl(i,j,k)-qci(i,j,k) -qpl(i,j,k)-qpi(i,j,k)+1.61*tabs(i,j,k)*dqsat - bbb = bbb / (1.+lstarn*dqsat) - buoy_sgs=betdz*(bbb*(t(i,j,kc)-t(i,j,kb)) & - +(bbb*lstarn - (1.+lstarn*dqsat)*tabs(i,j,k))* & - (qv(i,j,kc)+qcl(i,j,kc)+qci(i,j,kc)-qv(i,j,kb)-qcl(i,j,kb)-qci(i,j,kb)) & - + (bbb*fac_cond - (1.+fac_cond*dqsat)*tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & - + (bbb*fac_sub - (1.+fac_sub *dqsat)*tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) -!bloss +(bbb*lstarp - (1.+lstarp*dqsat)*tabs(i,j,k))* & -!bloss (qpl(i,j,kc)+qpi(i,j,kc)-qpl(i,j,kb)-qpi(i,j,kb)) ) - else - - bbb = 1.+epsv*qv(i,j,k)-qpl(i,j,k)-qpi(i,j,k) - buoy_sgs=betdz*( bbb*(t(i,j,kc)-t(i,j,kb)) & - +epsv*tabs(i,j,k)* & - (qv(i,j,kc)+qcl(i,j,kc)+qci(i,j,kc)-qv(i,j,kb)-qcl(i,j,kb)-qci(i,j,kb)) & - +(bbb*fac_cond-tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & - +(bbb*fac_sub -tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) -!bloss +(bbb*lstarp-tabs(i,j,k))* & -!bloss (qpl(i,j,kc)+qpi(i,j,kc)-qpl(i,j,kb)-qpi(i,j,kb)) ) - end if - - if(buoy_sgs.le.0.) then - smix=grd - else - smix=min(grd,max(0.1*grd, sqrt(0.76*tk(i,j,k)/Ck/sqrt(buoy_sgs+1.e-10)))) - end if - - - ratio=smix/grd - Pr=1. -! Pr=1. +2.*ratio - Cee=Ce1+Ce2*ratio - - if(dosmagor) then - - tk(i,j,k)=sqrt(Ck**3/Cee*max(0.,def2(i,j,k)-Pr*buoy_sgs))*smix**2 - tke(i,j,k) = (tk(i,j,k)/(Ck*smix))**2 - a_prod_sh=(tk(i,j,k)+0.001)*def2(i,j,k) - a_prod_bu=-(tk(i,j,k)+0.001)*Pr*buoy_sgs - a_diss=a_prod_sh+a_prod_bu - - else - - tke(i,j,k)=max(0.,tke(i,j,k)) - a_prod_sh=(tk(i,j,k)+0.001)*def2(i,j,k) - a_prod_bu=-(tk(i,j,k)+0.001)*Pr*buoy_sgs - a_diss=min(tke(i,j,k)/(4.*dt),Cee/smix*tke(i,j,k)**1.5) ! cap the diss rate (useful for large time steps - tke(i,j,k)=max(0.,tke(i,j,k)+dtn*(max(0.,a_prod_sh+a_prod_bu)-a_diss)) - tk(i,j,k)=Ck*smix*sqrt(tke(i,j,k)) - - end if - - tkh(i,j,k)=Pr*tk(i,j,k) - - tkelediss(k) = tkelediss(k) - a_prod_sh - tkesbdiss(k) = tkesbdiss(k) + a_diss - tkesbshear(k)= tkesbshear(k)+ a_prod_sh - tkesbbuoy(k) = tkesbbuoy(k) + a_prod_bu - - end do ! i - end do ! j - - tkelediss(k) = tkelediss(k)/float(nx*ny) - - -end do ! k - -!call t_stopf('tke_full') - -end - - diff --git a/src/physics/spcam/crm/crmx_abcoefs.F90 b/src/physics/spcam/crm/crmx_abcoefs.F90 deleted file mode 100644 index 0694eb0143..0000000000 --- a/src/physics/spcam/crm/crmx_abcoefs.F90 +++ /dev/null @@ -1,28 +0,0 @@ - -subroutine abcoefs - -! coefficients for the Adams-Bashforth scheme - -use crmx_grid - -implicit none - -real alpha, beta - -if(nstep.ge.3.and.nadams.eq.3.or.nrestart.eq.2) then - alpha = dt3(nb) / dt3(na) - beta = dt3(nc) / dt3(na) - ct = (2.+3.* alpha) / (6.* (alpha + beta) * beta) - bt = -(1.+2.*(alpha + beta) * ct)/(2. * alpha) - at = 1. - bt - ct -else if(nstep.ge.2) then - at = 3./2. - bt = -1./2. - ct = 0. -else - at = 1. - bt = 0. - ct = 0. -end if - -end subroutine abcoefs diff --git a/src/physics/spcam/crm/crmx_adams.F90 b/src/physics/spcam/crm/crmx_adams.F90 deleted file mode 100644 index 97b35188fc..0000000000 --- a/src/physics/spcam/crm/crmx_adams.F90 +++ /dev/null @@ -1,45 +0,0 @@ - -subroutine adams - -! Adams-Bashforth scheme - -use crmx_vars - -implicit none - -real dtdx, dtdy, dtdz, rhox, rhoy, rhoz -integer i,j,k - -dtdx = dtn/dx -dtdy = dtn/dy -dtdz = dtn/dz - -do k=1,nzm - rhox = rho(k)*dtdx - rhoy = rho(k)*dtdy - rhoz = rhow(k)*dtdz - do j=1,ny - do i=1,nx - - dudt(i,j,k,nc) = u(i,j,k) + dt3(na) & - *(at*dudt(i,j,k,na)+bt*dudt(i,j,k,nb)+ct*dudt(i,j,k,nc)) - - dvdt(i,j,k,nc) = v(i,j,k) + dt3(na) & - *(at*dvdt(i,j,k,na)+bt*dvdt(i,j,k,nb)+ct*dvdt(i,j,k,nc)) - - dwdt(i,j,k,nc) = w(i,j,k) + dt3(na) & - *(at*dwdt(i,j,k,na)+bt*dwdt(i,j,k,nb)+ct*dwdt(i,j,k,nc)) - - u(i,j,k) = 0.5*(u(i,j,k)+dudt(i,j,k,nc)) * rhox - v(i,j,k) = 0.5*(v(i,j,k)+dvdt(i,j,k,nc)) * rhoy - misc(i,j,k) = 0.5*(w(i,j,k)+dwdt(i,j,k,nc)) - w(i,j,k) = 0.5*(w(i,j,k)+dwdt(i,j,k,nc)) * rhoz - - - end do - end do -end do - -end subroutine adams - - diff --git a/src/physics/spcam/crm/crmx_advect2_mom_xy.F90 b/src/physics/spcam/crm/crmx_advect2_mom_xy.F90 deleted file mode 100644 index 600596d177..0000000000 --- a/src/physics/spcam/crm/crmx_advect2_mom_xy.F90 +++ /dev/null @@ -1,95 +0,0 @@ - -subroutine advect2_mom_xy - -! momentum tendency due to 2nd-order-central horizontal advection - -use crmx_vars - -implicit none - -real fu(0:nx,1-YES3D:ny,nzm) -real fv(0:nx,1-YES3D:ny,nzm) -real fw(0:nx,1-YES3D:ny,nzm) -real dx25, dy25, irho - -integer i, j, k, kc, kcu, ic, jb, ib, jc - -dx25 = 0.25 / dx -dy25 = 0.25 / dy - - -if(RUN3D) then - -do k = 1,nzm - kc= k+1 - kcu =min(kc, nzm) - irho = 1./(rhow(kc)*adzw(kc)) - - do j = 1, ny - jb = j-1 - do i = 0, nx - ic = i+1 - fu(i,j,k)=dx25*(u(ic,j,k)+u(i,j,k))*(u(i,j,k)+u(ic,j,k)) - fv(i,j,k)=dx25*(u(ic,j,k)+u(ic,jb,k))*(v(i,j,k)+v(ic,j,k)) - fw(i,j,k)=dx25*(u(ic,j,k)*rho(k)*adz(k)+ & - u(ic,j,kcu)*rho(kcu)*adz(kcu))*(w(i,j,kc)+w(ic,j,kc)) - end do - do i = 1, nx - ib = i-1 - dudt(i,j,k,na) = dudt(i,j,k,na) - (fu(i,j,k)-fu(ib,j,k)) - dvdt(i,j,k,na) = dvdt(i,j,k,na) - (fv(i,j,k)-fv(ib,j,k)) - dwdt(i,j,kc,na) = dwdt(i,j,kc,na)-irho*(fw(i,j,k)-fw(ib,j,k)) - end do - end do - - do j = 0, ny - jc = j+1 - do i = 1, nx - ib = i-1 - fu(i,j,k)=dy25*(v(i,jc,k)+v(ib,jc,k))*(u(i,j,k)+u(i,jc,k)) - fv(i,j,k)=dy25*(v(i,jc,k)+v(i,j,k))*(v(i,j,k)+v(i,jc,k)) - fw(i,j,k)=dy25*(v(i,jc,k)*rho(k)*adz(k)+ & - v(i,jc,kcu)*rho(kcu)*adz(kcu))*(w(i,j,kc)+w(i,jc,kc)) - end do - end do - do j = 1,ny - jb = j-1 - do i = 1, nx - dudt(i,j,k,na) = dudt(i,j,k,na) - (fu(i,j,k) - fu(i,jb,k)) - dvdt(i,j,k,na) = dvdt(i,j,k,na) - (fv(i,j,k) - fv(i,jb,k)) - dwdt(i,j,kc,na)= dwdt(i,j,kc,na)-irho*(fw(i,j,k)-fw(i,jb,k)) - end do - end do - -end do ! k - - -else - -j=1 - -do k = 1,nzm - kc= k+1 - kcu =min(kc, nzm) - irho = 1./(rhow(kc)*adzw(kc)) - - do i = 0, nx - ic = i+1 - fu(i,j,k)=dx25*(u(ic,j,k)+u(i,j,k))*(u(i,j,k)+u(ic,j,k)) - fv(i,j,k)=dx25*(u(ic,j,k)+u(i,j,k))*(v(i,j,k)+v(ic,j,k)) - fw(i,j,k)=dx25*(u(ic,j,k)*rho(k)*adz(k)+ & - u(ic,j,kcu)*rho(kcu)*adz(kcu))*(w(i,j,kc)+w(ic,j,kc)) - end do - do i = 1, nx - ib = i-1 - dudt(i,j,k,na) = dudt(i,j,k,na) - (fu(i,j,k)-fu(ib,j,k)) - dvdt(i,j,k,na) = dvdt(i,j,k,na) - (fv(i,j,k)-fv(ib,j,k)) - dwdt(i,j,kc,na) = dwdt(i,j,kc,na)-irho*(fw(i,j,k)-fw(ib,j,k)) - end do - -end do ! k - -endif - -end subroutine advect2_mom_xy - diff --git a/src/physics/spcam/crm/crmx_advect2_mom_z.F90 b/src/physics/spcam/crm/crmx_advect2_mom_z.F90 deleted file mode 100644 index be5d42734a..0000000000 --- a/src/physics/spcam/crm/crmx_advect2_mom_z.F90 +++ /dev/null @@ -1,93 +0,0 @@ - -subroutine advect2_mom_z - -! momentum tendency due to the 2nd-order-central vertical advection - -use crmx_vars - -implicit none - - -real fuz(nx,ny,nz),fvz(nx,ny,nz),fwz(nx,ny,nzm) -integer i, j, k, kc, kb -real dz2, dz25, www, rhoi - -dz25=1./(4.*dz) -dz2=dz25*2. - -do j=1,ny - do i=1,nx - fuz(i,j,1) = 0. - fvz(i,j,1) = 0. - fuz(i,j,nz) = 0. - fvz(i,j,nz) = 0. - fwz(i,j,1) = 0. - fwz(i,j,nzm) = 0. - end do -end do - -uwle(1) = 0. -vwle(1) = 0. - -if(RUN3D) then - -do k=2,nzm - kb = k-1 - rhoi = dz25 * rhow(k) - uwle(k) = 0. - vwle(k) = 0. - do j=1,ny - do i=1,nx - fuz(i,j,k) = rhoi*(w(i,j,k)+w(i-1,j,k))*(u(i,j,k)+u(i,j,kb)) - fvz(i,j,k) = rhoi*(w(i,j,k)+w(i,j-1,k))*(v(i,j,k)+v(i,j,kb)) - uwle(k) = uwle(k)+fuz(i,j,k) - vwle(k) = vwle(k)+fvz(i,j,k) - end do - end do -end do - -else - -do k=2,nzm - kb = k-1 - rhoi = dz25 * rhow(k) - uwle(k) = 0. - vwle(k) = 0. - do j=1,ny - do i=1,nx - www = rhoi*(w(i,j,k)+w(i-1,j,k)) - fuz(i,j,k) = www*(u(i,j,k)+u(i,j,kb)) - fvz(i,j,k) = www*(v(i,j,k)+v(i,j,kb)) - uwle(k) = uwle(k)+fuz(i,j,k) - vwle(k) = vwle(k)+fvz(i,j,k) - end do - end do -end do - - -endif - -do k=1,nzm - kc = k+1 - rhoi = 1./(rho(k)*adz(k)) - do j=1,ny - do i=1,nx - dudt(i,j,k,na)=dudt(i,j,k,na)-(fuz(i,j,kc)-fuz(i,j,k))*rhoi - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(fvz(i,j,kc)-fvz(i,j,k))*rhoi - fwz(i,j,k)=dz25*(w(i,j,kc)*rhow(kc)+w(i,j,k)*rhow(k))*(w(i,j,kc)+w(i,j,k)) - end do - end do -end do - -do k=2,nzm - kb=k-1 - rhoi = 1./(rhow(k)*adzw(k)) - do j=1,ny - do i=1,nx - dwdt(i,j,k,na)=dwdt(i,j,k,na)-(fwz(i,j,k)-fwz(i,j,kb))*rhoi - end do - end do -end do ! k - -end subroutine advect2_mom_z - diff --git a/src/physics/spcam/crm/crmx_advect_all_scalars.F90 b/src/physics/spcam/crm/crmx_advect_all_scalars.F90 deleted file mode 100644 index f6eb9e0915..0000000000 --- a/src/physics/spcam/crm/crmx_advect_all_scalars.F90 +++ /dev/null @@ -1,73 +0,0 @@ -subroutine advect_all_scalars() - - use crmx_vars - use crmx_microphysics - use crmx_sgs - use crmx_crmtracers -#ifdef CLUBB_CRM - use crmx_params, only: dotracers, doclubb, doclubbnoninter -#else - use crmx_params, only: dotracers -#endif - implicit none - real dummy(nz) - integer k - - -!--------------------------------------------------------- -! advection of scalars : - - call advect_scalar(t,tadv,twle,t2leadv,t2legrad,twleadv,.true.) - -! -! Advection of microphysics prognostics: -! - - do k = 1,nmicro_fields - if( k.eq.index_water_vapor &! transport water-vapor variable no metter what -#ifdef CLUBB_CRM -!Added preprocessor directives. - nielsenb UWM 30 July 2008 - .or. ( docloud .or. doclubb .or. doclubbnoninter ) .and.flag_precip(k).ne.1 & ! transport non-precipitation vars -#else - .or. docloud.and.flag_precip(k).ne.1 & ! transport non-precipitation vars -#endif - .or. doprecip.and.flag_precip(k).eq.1 ) & - call advect_scalar(micro_field(:,:,:,k),mkadv(:,k),mkwle(:,k),dummy,dummy,dummy,.false.) - end do - -! -! Advection of sgs prognostics: -! - - if(dosgs.and.advect_sgs) then - do k = 1,nsgs_fields - call advect_scalar(sgs_field(:,:,:,k),sgsadv(:,k),sgswle(:,k),dummy,dummy,dummy,.false.) - end do - end if - - -! -! Precipitation fallout: -! - if(doprecip) then - - total_water_prec = total_water_prec + total_water() - - call micro_precip_fall() - - total_water_prec = total_water_prec - total_water() - - - end if - - ! advection of tracers: - - if(dotracers) then - - do k = 1,ntracers - call advect_scalar(tracer(:,:,:,k),tradv(:,k),trwle(:,k),dummy,dummy,dummy,.false.) - end do - - end if - -end subroutine advect_all_scalars diff --git a/src/physics/spcam/crm/crmx_advect_mom.F90 b/src/physics/spcam/crm/crmx_advect_mom.F90 deleted file mode 100644 index b1562a09a3..0000000000 --- a/src/physics/spcam/crm/crmx_advect_mom.F90 +++ /dev/null @@ -1,19 +0,0 @@ -subroutine advect_mom - -use crmx_vars -use crmx_params, only: docolumn - -implicit none -integer i,j,k - -if(docolumn) return - -!call t_startf ('advect_mom') - -call advect2_mom_xy() -call advect2_mom_z() - -!call t_stopf ('advect_mom') - -end subroutine advect_mom - diff --git a/src/physics/spcam/crm/crmx_atmosphere.F90 b/src/physics/spcam/crm/crmx_atmosphere.F90 deleted file mode 100644 index 5f9623b931..0000000000 --- a/src/physics/spcam/crm/crmx_atmosphere.F90 +++ /dev/null @@ -1,71 +0,0 @@ - - SUBROUTINE Atmosphere(alt, sigma, delta, theta) -! ------------------------------------------------------------------------- -! PURPOSE - Compute the properties of the 1976 standard atmosphere to 86 km. -! AUTHOR - Ralph Carmichael, Public Domain Aeronautical Software -! NOTE - If alt > 86, the values returned will not be correct, but they will -! not be too far removed from the correct values for density. -! The reference document does not use the terms pressure and temperature -! above 86 km. - IMPLICIT NONE -!============================================================================ -! A R G U M E N T S | -!============================================================================ - REAL,INTENT(IN):: alt ! geometric altitude, km. - REAL,INTENT(OUT):: sigma! density/sea-level standard density - REAL,INTENT(OUT):: delta! pressure/sea-level standard pressure - REAL,INTENT(OUT):: theta! temperature/sea-level standard temperature -!============================================================================ -! L O C A L C O N S T A N T S | -!============================================================================ - REAL,PARAMETER:: REARTH = 6369.0 ! radius of the Earth (km) - REAL,PARAMETER:: GMR = 34.163195 ! gas constant - INTEGER,PARAMETER:: NTAB=8! number of entries in the defining tables -!============================================================================ -! L O C A L V A R I A B L E S | -!============================================================================ - INTEGER:: i,j,k ! counters - REAL:: h ! geopotential altitude (km) - REAL:: tgrad, tbase! temperature gradient and base temp of this layer - REAL:: tlocal ! local temperature - REAL:: deltah ! height above base of this layer -!============================================================================ -! L O C A L A R R A Y S ( 1 9 7 6 S T D. A T M O S P H E R E ) | -!============================================================================ - REAL,DIMENSION(NTAB),PARAMETER:: htab= (/0.0, 11.0, 20.0, 32.0, 47.0, 51.0, 71.0,84.852/) - REAL,DIMENSION(NTAB),PARAMETER:: ttab= (/288.15, 216.65, 216.65, 228.65, 270.65, 270.65, 214.65, 186.946/) - REAL,DIMENSION(NTAB),PARAMETER:: ptab= (/1.0, 2.233611e-1, & -5.403295e-2, 8.5666784e-3, 1.0945601e-3, 6.6063531e-4, 3.9046834e-5, 3.68501e-6/) - REAL,DIMENSION(NTAB),PARAMETER:: gtab= (/-6.5, 0.0, 1.0, 2.8, 0.0, -2.8, -2.0, 0.0/) -!---------------------------------------------------------------------------- - h=alt*REARTH/(alt+REARTH)! convert geometric to geopotential altitude - - i=1 - j=NTAB ! setting up for=binary search - DO - k=(i+j)/2 - IF (h < htab(k)) THEN - j=k - ELSE - i=k - END IF - IF (j <= i+1) EXIT - END DO - - tgrad=gtab(i) ! i will be in 1...NTAB-1 - tbase=ttab(i) - deltah=h-htab(i) - tlocal=tbase+tgrad*deltah - theta=tlocal/ttab(1) ! temperature ratio - - IF (tgrad == 0.0) THEN ! pressure ratio - delta=ptab(i)*EXP(-GMR*deltah/tbase) - ELSE - delta=ptab(i)*(tbase/tlocal)**(GMR/tgrad) - END IF - - sigma=delta/theta ! density ratio - RETURN - END Subroutine Atmosphere - - diff --git a/src/physics/spcam/crm/crmx_bound_duvdt.F90 b/src/physics/spcam/crm/crmx_bound_duvdt.F90 deleted file mode 100644 index ff96184761..0000000000 --- a/src/physics/spcam/crm/crmx_bound_duvdt.F90 +++ /dev/null @@ -1,28 +0,0 @@ - - -subroutine bound_duvdt - -! Periodic boundary exchange - -use crmx_vars -implicit none - -integer i,j,k - - do k=1,nzm - do j=1,ny - dudt(nxp1,j,k,na) = dudt(1,j,k,na) - end do - end do - - if(RUN3D) then - - do k=1,nzm - do i=1,nx - dvdt(i,nyp1,k,na) = dvdt(i,1,k,na) - end do - end do - - endif - -end subroutine bound_duvdt diff --git a/src/physics/spcam/crm/crmx_bound_exchange.F90 b/src/physics/spcam/crm/crmx_bound_exchange.F90 deleted file mode 100644 index c327a0f13f..0000000000 --- a/src/physics/spcam/crm/crmx_bound_exchange.F90 +++ /dev/null @@ -1,206 +0,0 @@ -subroutine bound_exchange(f,dimx1,dimx2,dimy1,dimy2,dimz,i_1, i_2, j_1, j_2, id) - -! periodic boundary exchange - - -use crmx_grid -implicit none - -integer dimx1, dimx2, dimy1, dimy2, dimz -integer i_1, i_2, j_1, j_2 -real f(dimx1:dimx2, dimy1:dimy2, dimz) -integer id ! id of the sent field (dummy variable) - -real buffer((nx+ny)*3*nz) ! buffer for sending data - -integer i, j, k, n -integer i1, i2, j1, j2 - -i1 = i_1 - 1 -i2 = i_2 - 1 -j1 = j_1 - 1 -j2 = j_2 - 1 - -!---------------------------------------------------------------------- -! Send buffers to neighbors -!---------------------------------------------------------------------- - - - if(RUN3D) then - -! "North" -> "South": - - n=0 - do k=1,dimz - do j=ny-j1,ny - do i=1,nx - n = n+1 - buffer(n) = f(i,j,k) - end do - end do - end do - n=0 - do k=1,dimz - do j=-j1,0 - do i=1,nx - n = n+1 - f(i,j,k) = buffer(n) - end do - end do - end do - -! "North-East" -> "South-West": - - n=0 - do k=1,dimz - do j=ny-j1,ny - do i=nx-i1,nx - n = n+1 - buffer(n) = f(i,j,k) - end do - end do - end do - n=0 - do k=1,dimz - do j=-j1,0 - do i=-i1,0 - n = n+1 - f(i,j,k) = buffer(n) - end do - end do - end do - -! "South-East" -> "North-West": - - n=0 - do k=1,dimz - do j=1,1+j2 - do i=nx-i1,nx - n = n+1 - buffer(n) = f(i,j,k) - end do - end do - end do - n=0 - do k=1,dimz - do j=nyp1,nyp1+j2 - do i=-i1,0 - n = n+1 - f(i,j,k) = buffer(n) - end do - end do - end do - -! "South" -> "North": - - n=0 - do k=1,dimz - do j=1,1+j2 - do i=1,nx - n = n+1 - buffer(n) = f(i,j,k) - end do - end do - end do - n=0 - do k=1,dimz - do j=nyp1,nyp1+j2 - do i=1,nx - n = n+1 - f(i,j,k) = buffer(n) - end do - end do - end do - -! "South-West" -> "North-East": - - n=0 - do k=1,dimz - do j=1,1+j2 - do i=1,1+i2 - n = n+1 - buffer(n) = f(i,j,k) - end do - end do - end do - n=0 - do k=1,dimz - do j=nyp1,nyp1+j2 - do i=nxp1,nxp1+i2 - n = n+1 - f(i,j,k) = buffer(n) - end do - end do - end do - - -! To "North-West" -> "South-East": - - n=0 - do k=1,dimz - do j=ny-j1,ny - do i=1,1+i2 - n = n+1 - buffer(n) = f(i,j,k) - end do - end do - end do - n=0 - do k=1,dimz - do j=-j1,0 - do i=nxp1,nxp1+i2 - n = n+1 - f(i,j,k) = buffer(n) - end do - end do - end do - - - endif - -! "East" -> "West": - - n=0 - do k=1,dimz - do j=1,ny - do i=nx-i1,nx - n = n+1 - buffer(n) = f(i,j,k) - end do - end do - end do - n=0 - do k=1,dimz - do j=1,ny - do i=-i1,0 - n = n+1 - f(i,j,k) = buffer(n) - end do - end do - end do - -! "West" -> "East": - - n=0 - do k=1,dimz - do j=1,ny - do i=1,1+i2 - n = n+1 - buffer(n) = f(i,j,k) - end do - end do - end do - n=0 - do k=1,dimz - do j=1,ny - do i=nxp1,nxp1+i2 - n = n+1 - f(i,j,k) = buffer(n) - end do - end do - end do - - -end subroutine bound_exchange - - diff --git a/src/physics/spcam/crm/crmx_boundaries.F90 b/src/physics/spcam/crm/crmx_boundaries.F90 deleted file mode 100644 index 0a642daab1..0000000000 --- a/src/physics/spcam/crm/crmx_boundaries.F90 +++ /dev/null @@ -1,20 +0,0 @@ - -subroutine boundaries(flag) - -use crmx_grid, only: dompi - - -implicit none -integer flag - -!call t_startf ('boundaries') - -if(dompi) then - call task_boundaries(flag) -else - call periodic(flag) -end if - -!call t_stopf ('boundaries') - -end subroutine boundaries diff --git a/src/physics/spcam/crm/crmx_buoyancy.F90 b/src/physics/spcam/crm/crmx_buoyancy.F90 deleted file mode 100644 index 8d8ff6a739..0000000000 --- a/src/physics/spcam/crm/crmx_buoyancy.F90 +++ /dev/null @@ -1,34 +0,0 @@ - -subroutine buoyancy() - -use crmx_vars -use crmx_params -implicit none - -integer i,j,k,kb -real betu, betd - -if(docolumn) return - -do k=2,nzm - kb=k-1 - betu=adz(kb)/(adz(k)+adz(kb)) - betd=adz(k)/(adz(k)+adz(kb)) - do j=1,ny - do i=1,nx - - dwdt(i,j,k,na)=dwdt(i,j,k,na) + & - bet(k)*betu* & - ( tabs0(k)*(epsv*(qv(i,j,k)-qv0(k))-(qcl(i,j,k)+qci(i,j,k)-qn0(k)+qpl(i,j,k)+qpi(i,j,k)-qp0(k))) & - +(tabs(i,j,k)-tabs0(k))*(1.+epsv*qv0(k)-qn0(k)-qp0(k)) ) & - + bet(kb)*betd* & - ( tabs0(kb)*(epsv*(qv(i,j,kb)-qv0(kb))-(qcl(i,j,kb)+qci(i,j,kb)-qn0(kb)+qpl(i,j,kb)+qpi(i,j,kb)-qp0(kb))) & - +(tabs(i,j,kb)-tabs0(kb))*(1.+epsv*qv0(kb)-qn0(kb)-qp0(kb)) ) - - end do ! i - end do ! j -end do ! k - -end subroutine buoyancy - - diff --git a/src/physics/spcam/crm/crmx_compress3D.F90 b/src/physics/spcam/crm/crmx_compress3D.F90 deleted file mode 100644 index a7686880f0..0000000000 --- a/src/physics/spcam/crm/crmx_compress3D.F90 +++ /dev/null @@ -1,165 +0,0 @@ -subroutine compress3D (f,nx,ny,nz,name, long_name, units, & - savebin, dompi, rank, nsubdomains) - - -! Compress3D: Compresses a given 3D array into the byte-array -! and writes the latter into a file. - -use crmx_grid, only: output_sep - implicit none -! Input: - -integer nx,ny,nz -real f(nx,ny,nz) -character*(*) name,long_name,units -integer rank,rrr,ttt,irank,nsubdomains -logical savebin, dompi - -! Local: - -integer(2), allocatable :: byte(:) -real(kind=selected_real_kind(6)), allocatable :: byte4(:) -integer size,count - -character(10) value_min(nz), value_max(nz) -character(7) form -integer int_fac, integer_max, integer_min -parameter (int_fac=2,integer_min=-32000, integer_max=32000) -! parameter (int_fac=1,integer_min=-127, integer_max=127) -real f_max,f_min, f_max1, f_min1, scale -integer i,j,k,req - - -! Allocate byte array: - -size=nx*ny*nz -if(savebin) then - allocate (byte4(size)) -else - allocate (byte(size)) -end if -count = 0 - -if(savebin) then - - do k=1,nz - do j=1,ny - do i=1,nx - count = count+1 - byte4(count) = f(i,j,k) - end do - end do - end do - - if(rank.eq.0) then - write(46) name,' ',long_name,' ',units - write(46) (byte4(k),k=1,count) - end if - - if(output_sep) then - if(rank.ne.0) write(46) (byte4(k),k=1,count) - else - do irank = 1, nsubdomains-1 - call task_barrier() - if(irank.eq.rank) then - call task_bsend_float(0,byte4,count,irank) - end if - if(rank.eq.0) then - call task_receive_float(byte4,count,req) - call task_wait(req,rrr,ttt) - write(46) (byte4(k),k=1,count) - end if - end do - end if - - deallocate(byte4) - - -else - - - do k=1,nz - - f_max=-1.e30 - f_min= 1.e30 - do j=1,ny - do i=1,nx - f_max = max(f_max,f(i,j,k)) - f_min = min(f_min,f(i,j,k)) - end do - end do - if(dompi) then - f_max1=f_max - f_min1=f_min - call task_max_real(f_max1,f_max,1) - call task_min_real(f_min1,f_min,1) - endif - - if(abs(f_max).lt.10..and.abs(f_min).lt.10.) then - form='(f10.7)' - else if(abs(f_max).lt.100..and.abs(f_min).lt.100.) then - form='(f10.6)' - else if(abs(f_max).lt.1000..and.abs(f_min).lt.1000.) then - form='(f10.5)' - else if(abs(f_max).lt.10000..and.abs(f_min).lt.10000.) then - form='(f10.4)' - else if(abs(f_max).lt.100000..and.abs(f_min).lt.100000.) then - form='(f10.3)' - else if(abs(f_max).lt.1000000..and.abs(f_min).lt.1000000.) then - form='(f10.2)' - else if(abs(f_max).lt.10000000..and.abs(f_min).lt.10000000.) then - form='(f10.1)' - else if(abs(f_max).lt.100000000..and.abs(f_min).lt.100000000.) then - form='(f10.0)' - else - form='(f10.0)' - f_min=-999. - f_max= 999. - end if - - write(value_max(k),form) f_max - write(value_min(k),form) f_min - - scale = float(integer_max-integer_min)/(f_max-f_min+1.e-20) - - do j=1,ny - do i=1,nx - count=count+1 - byte(count)= integer_min+scale*(f(i,j,k)-f_min) - end do - end do - - end do ! k - - if(rank.eq.0) then - write(46) name,' ',long_name,' ',units,' ',value_max,value_min - write(46) (byte(k),k=1,count) - end if - - if(output_sep) then - if(rank.ne.0) write(46) (byte(k),k=1,count) - else - do irank = 1, nsubdomains-1 - call task_barrier() - if(irank.eq.rank) then - call task_send_character(0,byte,int_fac*count,irank,req) - call task_wait(req,rrr,ttt) - end if - if(rank.eq.0) then - call task_receive_character(byte,int_fac*count,req) - call task_wait(req,rrr,ttt) - write(46) (byte(k),k=1,count) - end if - end do - end if - - deallocate(byte) - - -end if ! savebin - - -call task_barrier() - -end subroutine compress3D - diff --git a/src/physics/spcam/crm/crmx_coriolis.F90 b/src/physics/spcam/crm/crmx_coriolis.F90 deleted file mode 100644 index 13b1707b3e..0000000000 --- a/src/physics/spcam/crm/crmx_coriolis.F90 +++ /dev/null @@ -1,48 +0,0 @@ - -subroutine coriolis - -use crmx_vars - -implicit none - -real u_av, v_av, w_av -integer i,j,k,ib,ic,jb,jc,kc - -if(RUN3D) then - -do k=1,nzm - kc=k+1 - do j=1,ny - jb=j-1 - jc=j+1 - do i=1,nx - ib=i-1 - ic=i+1 - v_av=0.25*(v(i,j,k)+v(i,jc,k)+v(ib,j,k)+v(ib,jc,k)) - w_av=0.25*(w(i,j,kc)+w(ib,j,kc)+w(i,j,k)+w(ib,j,k)) - dudt(i,j,k,na)=dudt(i,j,k,na)+fcory(j)*(v_av-vg0(k))-fcorzy(j)*w_av - u_av=0.25*(u(i,j,k)+u(ic,j,k)+u(i,jb,k)+u(ic,jb,k)) - dvdt(i,j,k,na)=dvdt(i,j,k,na)-0.5*(fcory(j)+fcory(jb))*(u_av-ug0(k)) - end do ! i - end do ! j -end do ! k - -else - -do k=1,nzm - kc=k+1 - do j=1,ny - do i=1,nx - ib=i-1 - ic=i+1 - w_av=0.25*(w(i,j,kc)+w(ib,j,kc)+w(i,j,k)+w(ib,j,k)) - dudt(i,j,k,na)=dudt(i,j,k,na)+fcory(j)*(v(i,j,k)-vg0(k))-fcorzy(j)*w_av - dvdt(i,j,k,na)=dvdt(i,j,k,na)-fcory(j)*(u(i,j,k)-ug0(k)) - end do ! i - end do ! i -end do ! k - -endif - -end subroutine coriolis - diff --git a/src/physics/spcam/crm/crmx_crm_module.F90 b/src/physics/spcam/crm/crmx_crm_module.F90 deleted file mode 100644 index 8e7ea7b3aa..0000000000 --- a/src/physics/spcam/crm/crmx_crm_module.F90 +++ /dev/null @@ -1,1792 +0,0 @@ -module crmx_crm_module -!--------------------------------------------------------------- -! Super-parameterization's main driver -! Marat Khairoutdinov, 2001-2009 -!--------------------------------------------------------------- - -use crmx_setparm_mod, only : setparm - -contains - -subroutine crm (lchnk, icol, & - tl, ql, qccl, qiil, ul, vl, & - ps, pmid, pdel, phis, & - zmid, zint, dt_gl, plev, & - qltend, qcltend, qiltend, sltend, & - u_crm, v_crm, w_crm, t_crm, micro_fields_crm, & - qrad_crm, & - qc_crm, qi_crm, qpc_crm, qpi_crm, prec_crm, & - t_rad, qv_rad, qc_rad, qi_rad, cld_rad, cld3d_crm, & -#ifdef m2005 - nc_rad, ni_rad, qs_rad, ns_rad, wvar_crm, & -! hm 7/26/11 new output - aut_crm, acc_crm, evpc_crm, evpr_crm, mlt_crm, & - sub_crm, dep_crm, con_crm, & -! hm 8/31/11 new output for gcm-grid and time-step avg process rates - aut_crm_a, acc_crm_a, evpc_crm_a, evpr_crm_a, mlt_crm_a, & - sub_crm_a, dep_crm_a, con_crm_a, & -#endif - precc, precl, precsc, precsl, & - cltot, clhgh, clmed, cllow, cld, cldtop, & - gicewp, gliqwp, & - mc, mcup, mcdn, mcuup, mcudn, & - crm_qc, crm_qi, crm_qs, crm_qg, crm_qr, & -#ifdef m2005 - crm_nc, crm_ni, crm_ns, crm_ng, crm_nr, & -#ifdef MODAL_AERO - naermod, vaerosol, hygro, & -#endif -#endif -#ifdef SPCAM_CLUBB_SGS - clubb_buffer, & - crm_cld, & - clubb_tk, clubb_tkh, & - relvar, accre_enhan, qclvar, & -#endif - crm_tk, crm_tkh, & - mu_crm, md_crm, du_crm, eu_crm, ed_crm, jt_crm, mx_crm, & -#ifdef ECPP - abnd, abnd_tf, massflxbnd, acen, acen_tf, & - rhcen, qcloudcen, qicecen, qlsinkcen, precrcen, precsolidcen, & - qlsink_bfcen, qlsink_avgcen, praincen, & - wupthresh_bnd, wdownthresh_bnd, & - wwqui_cen, wwqui_bnd, wwqui_cloudy_cen, wwqui_cloudy_bnd, & -#endif - tkez, tkesgsz, tkz, flux_u, flux_v, flux_qt, fluxsgs_qt,flux_qp, & - pflx, qt_ls, qt_trans, qp_trans, qp_fall, & - qp_evp, qp_src, t_ls, prectend, precstend, & - ocnfrac, wndls, tau00, bflxls, & - fluxu00, fluxv00, fluxt00, fluxq00, & - taux_crm, tauy_crm, z0m, timing_factor, qtot) - -! dolong, doshort, nrad0, & -! latitude00, longitude00, day00, pres00, tabs_s0, case0, & -! radlwup0, radlwdn0, radswup0, radswdn0, radqrlw0, radqrsw0, & -! lwnsxy,swnsxy,lwntxy,swntxy,solinxy,lwnscxy,swnscxy,lwntcxy,swntcxy,lwdsxy,swdsxy) - - -!--------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 -#ifdef SPCAM_CLUBB_SGS - use crmdims, only: nclubbvars -#endif - use phys_grid, only: get_rlon_p, get_rlat_p, get_gcol_all_p - use ppgrid, only: pcols - use crmx_vars - use crmx_params - use crmx_microphysics - use crmx_sgs - use crmx_crmtracers -#ifdef MODAL_AERO - use modal_aero_data, only: ntot_amode -#endif -#ifdef SPCAM_CLUBB_SGS - use crmx_clubb_sgs, only: advance_clubb_sgs, clubb_sgs_setup, clubb_sgs_cleanup, & - apply_clubb_sgs_tndcy, apply_clubb_sgs_tndcy_scalars, apply_clubb_sgs_tndcy_mom, & ! Subroutines - t2thetal ! Functions - use crmx_clubb_sgs, only: total_energy - use crmx_clubbvars, only: edsclr_dim, sclr_dim, rho_ds_zt, rho_ds_zm, & - rtm_spurious_source, thlm_spurious_source - use crmx_clubb_precision, only: time_precision - use crmx_clubbvars, only: up2, vp2, wprtp, wpthlp, wp2, wp3, rtp2, thlp2, rtpthlp, & - upwp, vpwp, cloud_frac, t_tndcy, qc_tndcy, qv_tndcy, u_tndcy, v_tndcy, lrestart_clubb - use crmx_clubbvars, only: rho_ds_zt, rho_ds_zm, thv_ds_zt, thv_ds_zm, & - invrs_rho_ds_zt, invrs_rho_ds_zm - use crmx_clubbvars, only: tracer_tndcy, sclrp2, sclrprtp, sclrpthlp, wpsclrp - use crmx_fill_holes, only: vertical_integral ! Function - use crmx_numerical_check, only: calculate_spurious_source - use crmx_grid_class, only: gr ! Variable - use crmx_clubb_precision, only: core_rknd ! Constants - use crmx_clubbvars, only: relvarg, accre_enhang, qclvarg -#endif /*CLUBB_SGS*/ -#ifdef ECPP - use crmx_ecppvars, only: qlsink, precr, precsolid, & - area_bnd_final, area_bnd_sum, area_cen_final, area_cen_sum, & - mass_bnd_final, mass_bnd_sum, rh_cen_sum, qcloud_cen_sum, qice_cen_sum, & - qlsink_cen_sum, precr_cen_sum, precsolid_cen_sum, xkhvsum, wup_thresh, wdown_thresh, & - wwqui_cen_sum, wwqui_bnd_sum, wwqui_cloudy_cen_sum, wwqui_cloudy_bnd_sum, & - qlsink_bf_cen_sum, qlsink_avg_cen_sum, prain_cen_sum, qlsink_bf, prain - use crmx_module_ecpp_crm_driver, only: ecpp_crm_stat, ecpp_crm_init, ecpp_crm_cleanup, ntavg1_ss, ntavg2_ss - use crmx_ecppvars, only: NCLASS_CL, ncls_ecpp_in, NCLASS_PR -#endif /*ECPP*/ - - use cam_abortutils, only: endrun - use time_manager, only: get_nstep - - implicit none - -! integer, parameter :: r8 = 8 - -! Input: - - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: icol ! column identifier - integer, intent(in) :: plev ! number of levels - real(r8), intent(in) :: ps ! Global grid surface pressure (Pa) - real(r8), intent(in) :: pmid(plev) ! Global grid pressure (Pa) - real(r8), intent(in) :: pdel(plev) ! Layer's pressure thickness (Pa) - real(r8), intent(in) :: phis ! Global grid surface geopotential (m2/s2) - real(r8), intent(in) :: zmid(plev) ! Global grid height (m) - real(r8), intent(in) :: zint(plev+1)! Global grid interface height (m) - real(r8), intent(in) :: qrad_crm(crm_nx, crm_ny, crm_nz) ! CRM rad. heating - real(r8), intent(in) :: dt_gl ! global model's time step - real(r8), intent(in) :: ocnfrac ! area fraction of the ocean - real(r8), intent(in) :: tau00 ! large-scale surface stress (N/m2) - real(r8), intent(in) :: wndls ! large-scale surface wind (m/s) - real(r8), intent(in) :: bflxls ! large-scale surface buoyancy flux (K m/s) - real(r8), intent(in) :: fluxu00 ! surface momenent fluxes [N/m2] - real(r8), intent(in) :: fluxv00 ! surface momenent fluxes [N/m2] - real(r8), intent(in) :: fluxt00 ! surface sensible heat fluxes [K Kg/ (m2 s)] - real(r8), intent(in) :: fluxq00 ! surface latent heat fluxes [ kg/(m2 s)] -! logical, intent(in) :: doshort ! compute shortwave radiation -! logical, intent(in) :: dolong ! compute longwave radiation -! real(r8), intent(in) :: day00 ! initial day -! real(r8), intent(in) :: latitude00 -! real(r8), intent(in) :: longitude00 -! real(r8), intent(in) :: pres00 -! real(r8), intent(in) :: tabs_s0 -! integer , intent(in) :: nrad0 -! character *40 case0 ! 8-symbol id-string to identify a case-name - - -! tl, ql, qccl, qiil, ul, vl are not updated in this subroutine, and set to intent(in), but -! not intent(inout). +++mhwang - real(r8), intent(in) :: tl(plev) ! Global grid temperature (K) - real(r8), intent(in) :: ql(plev) ! Global grid water vapor (g/g) - real(r8), intent(in) :: qccl(plev)! Global grid cloud liquid water (g/g) - real(r8), intent(in) :: qiil(plev)! Global grid cloud ice (g/g) - real(r8), intent(in) :: ul(plev) ! Global grid u (m/s) - real(r8), intent(in) :: vl(plev) ! Global grid v (m/s) - -! Input/Output: -#ifdef SPCAM_CLUBB_SGS - real(r8), intent(inout), target :: clubb_buffer(crm_nx, crm_ny, crm_nz+1,1:nclubbvars) - real(r8), intent(inout) :: crm_cld(crm_nx, crm_ny, crm_nz+1) - real(r8), intent(inout) :: clubb_tk(crm_nx, crm_ny, crm_nz) - real(r8), intent(inout) :: clubb_tkh(crm_nx, crm_ny, crm_nz) - real(r8), intent(inout) :: relvar(crm_nx, crm_ny, crm_nz) - real(r8), intent(inout) :: accre_enhan(crm_nx, crm_ny, crm_nz) - real(r8), intent(inout) :: qclvar(crm_nx, crm_ny, crm_nz) -#endif - real(r8), intent(inout) :: crm_tk(crm_nx, crm_ny, crm_nz) - real(r8), intent(inout) :: crm_tkh(crm_nx, crm_ny, crm_nz) - - real(r8), intent(inout) :: cltot ! shaded cloud fraction - real(r8), intent(inout) :: clhgh ! shaded cloud fraction - real(r8), intent(inout) :: clmed ! shaded cloud fraction - real(r8), intent(inout) :: cllow ! shaded cloud fraction - - -! Output - - real(r8), intent(inout) :: sltend(plev) ! tendency of static energy -! real(r8), intent(inout) :: u_crm (:,:,:) ! CRM v-wind component -! real(r8), intent(inout) :: v_crm (:,:,:) ! CRM v-wind component -! real(r8), intent(inout) :: w_crm (:,:,:) ! CRM w-wind component -! real(r8), intent(inout) :: t_crm (:,:,:) ! CRM temperuture - real(r8), intent(inout) :: u_crm (crm_nx,crm_ny,crm_nz) ! CRM v-wind component - real(r8), intent(inout) :: v_crm (crm_nx,crm_ny,crm_nz) ! CRM v-wind component - real(r8), intent(inout) :: w_crm (crm_nx,crm_ny,crm_nz) ! CRM w-wind component - real(r8), intent(inout) :: t_crm (crm_nx,crm_ny,crm_nz) ! CRM temperuture -! real(r8), intent(inout) :: micro_fields_crm (:,:,:,:) ! CRM total water - real(r8), intent(inout) :: micro_fields_crm (crm_nx,crm_ny,crm_nz,nmicro_fields+1) ! CRM total water - real(r8), intent(inout) :: qltend(plev) ! tendency of water vapor - real(r8), intent(inout) :: qcltend(plev)! tendency of cloud liquid water - real(r8), intent(inout) :: qiltend(plev)! tendency of cloud ice - real(r8), intent(inout) :: t_rad (crm_nx, crm_ny, crm_nz) ! rad temperuture - real(r8), intent(inout) :: qv_rad(crm_nx, crm_ny, crm_nz) ! rad vapor - real(r8), intent(inout) :: qc_rad(crm_nx, crm_ny, crm_nz) ! rad cloud water - real(r8), intent(inout) :: qi_rad(crm_nx, crm_ny, crm_nz) ! rad cloud ice - real(r8), intent(inout) :: cld_rad(crm_nx, crm_ny, crm_nz) ! rad cloud fraction - real(r8), intent(inout) :: cld3d_crm(crm_nx, crm_ny, crm_nz) ! instant 3D cloud fraction -#ifdef m2005 - real(r8), intent(inout) :: nc_rad(crm_nx, crm_ny, crm_nz) ! rad cloud droplet number (#/kg) - real(r8), intent(inout) :: ni_rad(crm_nx, crm_ny, crm_nz) ! rad cloud ice crystal number (#/kg) - real(r8), intent(inout) :: qs_rad(crm_nx, crm_ny, crm_nz) ! rad cloud snow (kg/kg) - real(r8), intent(inout) :: ns_rad(crm_nx, crm_ny, crm_nz) ! rad cloud snow crystal number (#/kg) - real(r8), intent(inout) :: wvar_crm(crm_nx, crm_ny, crm_nz) ! vertical velocity variance (m/s) -! hm 7/26/11 new output - real(r8), intent(inout) :: aut_crm(crm_nx, crm_ny, crm_nz) ! cloud water autoconversion (1/s) - real(r8), intent(inout) :: acc_crm(crm_nx, crm_ny, crm_nz) ! cloud water accretion (1/s) - real(r8), intent(inout) :: evpc_crm(crm_nx, crm_ny, crm_nz) ! cloud water evaporation (1/s) - real(r8), intent(inout) :: evpr_crm(crm_nx, crm_ny, crm_nz) ! rain evaporation (1/s) - real(r8), intent(inout) :: mlt_crm(crm_nx, crm_ny, crm_nz) ! ice, snow, graupel melting (1/s) - real(r8), intent(inout) :: sub_crm(crm_nx, crm_ny, crm_nz) ! ice, snow, graupel sublimation (1/s) - real(r8), intent(inout) :: dep_crm(crm_nx, crm_ny, crm_nz) ! ice, snow, graupel deposition (1/s) - real(r8), intent(inout) :: con_crm(crm_nx, crm_ny, crm_nz) ! cloud water condensation(1/s) -! hm 8/31/11 new output, gcm-grid and time step-avg - real(r8), intent(inout) :: aut_crm_a(plev) ! cloud water autoconversion (1/s) - real(r8), intent(inout) :: acc_crm_a(plev) ! cloud water accretion (1/s) - real(r8), intent(inout) :: evpc_crm_a(plev) ! cloud water evaporation (1/s) - real(r8), intent(inout) :: evpr_crm_a(plev) ! rain evaporation (1/s) - real(r8), intent(inout) :: mlt_crm_a(plev) ! ice, snow, graupel melting (1/s) - real(r8), intent(inout) :: sub_crm_a(plev) ! ice, snow, graupel sublimation (1/s) - real(r8), intent(inout) :: dep_crm_a(plev) ! ice, snow, graupel deposition (1/s) - real(r8), intent(inout) :: con_crm_a(plev) ! cloud water condensation(1/s) -#endif - real(r8), intent(inout) :: precc ! convective precip rate (m/s) - real(r8), intent(inout) :: precl ! stratiform precip rate (m/s) - real(r8), intent(inout) :: cld(plev) ! cloud fraction - real(r8), intent(inout) :: cldtop(plev) ! cloud top pdf - real(r8), intent(inout) :: gicewp(plev) ! ice water path - real(r8), intent(inout) :: gliqwp(plev) ! ice water path - real(r8), intent(inout) :: mc(plev) ! cloud mass flux - real(r8), intent(inout) :: mcup(plev) ! updraft cloud mass flux - real(r8), intent(inout) :: mcdn(plev) ! downdraft cloud mass flux - real(r8), intent(inout) :: mcuup(plev) ! unsat updraft cloud mass flux - real(r8), intent(inout) :: mcudn(plev) ! unsat downdraft cloud mass flux - real(r8), intent(inout) :: crm_qc(plev) ! mean cloud water - real(r8), intent(inout) :: crm_qi(plev) ! mean cloud ice - real(r8), intent(inout) :: crm_qs(plev) ! mean snow - real(r8), intent(inout) :: crm_qg(plev) ! mean graupel - real(r8), intent(inout) :: crm_qr(plev) ! mean rain -#ifdef m2005 - real(r8), intent(inout) :: crm_nc(plev) ! mean cloud water (#/kg) - real(r8), intent(inout) :: crm_ni(plev) ! mean cloud ice (#/kg) - real(r8), intent(inout) :: crm_ns(plev) ! mean snow (#/kg) - real(r8), intent(inout) :: crm_ng(plev) ! mean graupel (#/kg) - real(r8), intent(inout) :: crm_nr(plev) ! mean rain (#/kg) -#ifdef MODAL_AERO - real(r8), intent(in) :: naermod(plev, ntot_amode) ! Aerosol number concentration [/m3] - real(r8), intent(in) :: vaerosol(plev, ntot_amode) ! aerosol volume concentration [m3/m3] - real(r8), intent(in) :: hygro(plev, ntot_amode) ! hygroscopicity of aerosol mode -#endif -#endif - real(r8), intent(inout) :: mu_crm (plev) ! mass flux up - real(r8), intent(inout) :: md_crm (plev) ! mass flux down - real(r8), intent(inout) :: du_crm (plev) ! mass detrainment from updraft - real(r8), intent(inout) :: eu_crm (plev) ! mass entrainment from updraft - real(r8), intent(inout) :: ed_crm (plev) ! mass detrainment from downdraft - real(r8) :: dd_crm (plev) ! mass entraiment from downdraft - real(r8), intent(inout) :: jt_crm ! index of cloud (convection) top - real(r8), intent(inout) :: mx_crm ! index of cloud (convection) bottom - real(r8) :: mui_crm (plev+1) ! mass flux up at the interface - real(r8) :: mdi_crm (plev+1) ! mass flux down at the interface - - real(r8), intent(inout) :: flux_qt(plev) ! nonprecipitating water flux [kg/m2/s] - real(r8), intent(inout) :: fluxsgs_qt(plev) ! sgs nonprecipitating water flux [kg/m2/s] - real(r8), intent(inout) :: tkez(plev) ! tke profile [kg/m/s2] - real(r8), intent(inout) :: tkesgsz(plev) ! sgs tke profile [kg/m/s2] - real(r8), intent(inout) :: tkz(plev) ! tk profile [m2/s] - real(r8), intent(inout) :: flux_u(plev) ! x-momentum flux [m2/s2] - real(r8), intent(inout) :: flux_v(plev) ! y-momentum flux [m2/s2] - real(r8), intent(inout) :: flux_qp(plev) ! precipitating water flux [kg/m2/s or mm/s] - real(r8), intent(inout) :: pflx(plev) ! precipitation flux [m/s] - real(r8), intent(inout) :: qt_ls(plev) ! tendency of nonprec water due to large-scale [kg/kg/s] - real(r8), intent(inout) :: qt_trans(plev)! tendency of nonprec water due to transport [kg/kg/s] - real(r8), intent(inout) :: qp_trans(plev) ! tendency of prec water due to transport [kg/kg/s] - real(r8), intent(inout) :: qp_fall(plev) ! tendency of prec water due to fall-out [kg/kg/s] - real(r8), intent(inout) :: qp_src(plev) ! tendency of prec water due to conversion [kg/kg/s] - real(r8), intent(inout) :: qp_evp(plev) ! tendency of prec water due to evp [kg/kg/s] - real(r8), intent(inout) :: t_ls(plev) ! tendency of lwse due to large-scale [kg/kg/s] ??? - real(r8), intent(inout) :: prectend ! column integrated tendency in precipitating water+ice (kg/m2/s) - real(r8), intent(inout) :: precstend ! column integrated tendency in precipitating ice (kg/m2/s) - real(r8), intent(inout) :: precsc ! convective snow rate (m/s) - real(r8), intent(inout) :: precsl ! stratiform snow rate (m/s) - real(r8), intent(inout):: taux_crm ! zonal CRM surface stress perturbation (N/m2) - real(r8), intent(inout):: tauy_crm ! merid CRM surface stress perturbation (N/m2) - real(r8), intent(inout):: z0m ! surface stress (N/m2) - real(r8), intent(inout):: timing_factor ! crm cpu efficiency - real(r8), intent(inout) :: qc_crm (crm_nx, crm_ny, crm_nz)! CRM cloud water - real(r8), intent(inout) :: qi_crm (crm_nx, crm_ny, crm_nz)! CRM cloud ice - real(r8), intent(inout) :: qpc_crm(crm_nx, crm_ny, crm_nz)! CRM precip water - real(r8), intent(inout) :: qpi_crm(crm_nx, crm_ny, crm_nz)! CRM precip ice - real(r8), intent(inout) :: prec_crm(crm_nx, crm_ny)! CRM precipiation rate -#ifdef ECPP -! at layer center - real(r8), intent(inout) :: acen(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! cloud fraction for each sub-sub class for full time period - real(r8), intent(inout) :: acen_tf(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! cloud fraction for end-portion of time period - real(r8), intent(inout) :: rhcen(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! relative humidity (0-1) - real(r8), intent(inout) :: qcloudcen(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! cloud water (kg/kg) - real(r8), intent(inout) :: qicecen(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! cloud ice (kg/kg) - real(r8), intent(inout) :: qlsinkcen(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! cloud water loss rate from precipitation (/s??) - real(r8), intent(inout) :: precrcen(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! liquid (rain) precipitation rate (kg/m2/s) - real(r8), intent(inout) :: precsolidcen(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! solid (rain) precipitation rate (kg/m2/s) - real(r8), intent(inout) :: qlsink_bfcen(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! cloud water loss rate from precipitation calculated - ! cloud water before precipitatinog (/s) - real(r8), intent(inout) :: qlsink_avgcen(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! cloud water loss rate from precipitation calculated - ! from praincen and qlcoudcen averaged over - ! ntavg1_ss time step (/s??) - real(r8), intent(inout) :: praincen(plev,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! cloud water loss rate from precipitation (kg/kg/s) - real(r8), intent(inout) :: wwqui_cen(plev) ! vertical velocity variance in quiescent class (m2/s2) - real(r8), intent(inout) :: wwqui_cloudy_cen(plev) ! vertical velocity variance in quiescent, and cloudy class (m2/s2) -! at layer boundary - real(r8), intent(inout) :: abnd(plev+1,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! cloud fraction for each sub-sub class for full time period - real(r8), intent(inout) :: abnd_tf(plev+1,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! cloud fraction for end-portion of time period - real(r8), intent(inout) :: massflxbnd(plev+1,NCLASS_CL,ncls_ecpp_in,NCLASS_PR) ! sub-class vertical mass flux (kg/m2/s) at layer bottom boundary. - real(r8), intent(inout) :: wupthresh_bnd(plev+1) ! vertical velocity threshold for updraft (m/s) - real(r8), intent(inout) :: wdownthresh_bnd(plev+1) ! vertical velocity threshold for downdraft (m/s) - real(r8), intent(inout) :: wwqui_bnd(plev+1) ! vertical velocity variance in quiescent class (m2/s2) - real(r8), intent(inout) :: wwqui_cloudy_bnd(plev+1) ! vertical velocity variance in quiescent, and cloudy class (m2/s2) -#endif - -! Local space: - real dummy(nz), t00(nz) - real fluxbtmp(nx,ny), fluxttmp(nx,ny) !bloss - real tln(plev), qln(plev), qccln(plev), qiiln(plev), uln(plev), vln(plev) - real cwp(nx,ny), cwph(nx,ny), cwpm(nx,ny), cwpl(nx,ny) - real(r8) factor_xy, idt_gl - real tmp1, tmp2 - real u2z,v2z,w2z - integer i,j,k,l,ptop,nn,icyc, nstatsteps - integer kx - real(r8), parameter :: umax = 0.5*crm_dx/crm_dt ! maxumum ampitude of the l.s. wind - real(r8), parameter :: wmin = 2. ! minimum up/downdraft velocity for stat - real, parameter :: cwp_threshold = 0.001 ! threshold for cloud condensate for shaded fraction calculation - logical flag_top(nx,ny) - real ustar, bflx, wnd, z0_est, qsat, omg - real colprec,colprecs - real(r8) zs ! surface elevation - integer igstep ! GCM time steps - integer iseed ! seed for random perturbation - integer gcolindex(pcols) ! array of global latitude indices - -#ifdef SPCAM_CLUBB_SGS -!Array indicies for spurious RTM check - -real(kind=core_rknd) :: & - rtm_integral_before(nx,ny), rtm_integral_after(nx,ny), rtm_flux_top, rtm_flux_sfc -real(kind=core_rknd) :: & - thlm_integral_before(nx,ny), thlm_integral_after(nx,ny), thlm_before(nzm), thlm_after(nzm), & - thlm_flux_top, thlm_flux_sfc - -real(kind=core_rknd), dimension(nzm) :: & - rtm_column ! Total water (vapor + liquid) [kg/kg] -#endif - - real cltemp(nx,ny), cmtemp(nx,ny), chtemp(nx, ny), cttemp(nx, ny) - - real(r8), intent(inout) :: qtot(20) - real ntotal_step - -!----------------------------------------------- - - dostatis = .false. ! no statistics are collected. - idt_gl = 1._r8/dt_gl - ptop = plev-nzm+1 - factor_xy = 1._r8/dble(nx*ny) - dummy = 0. - t_rad = 0. - qv_rad = 0. - qc_rad = 0. - qi_rad = 0. - cld_rad = 0. -#ifdef m2005 - nc_rad = 0.0 - ni_rad = 0.0 - qs_rad = 0.0 - ns_rad = 0.0 -#endif - zs=phis/ggr - bflx = bflxls - wnd = wndls - -!----------------------------------------- - igstep = get_nstep() - -#ifdef SPCAM_CLUBB_SGS - if(igstep == 1) then - lrestart_clubb = .false. - else - lrestart_clubb = .true. - endif -#endif - - call task_init () - - call setparm() - -! doshortwave = doshort -! dolongwave = dolong -! day0 = day00-dt_gl/86400. -! latitude = latitude00 -! longitude = longitude00 -! pres0 = pres00 -! tabs_s = tabs_s0 -! case = case0 - - latitude0 = get_rlat_p(lchnk, icol)*57.296_r8 - longitude0 = get_rlon_p(lchnk, icol)*57.296_r8 -! pi = acos(-1.) - if(fcor.eq.-999.) fcor= 4*pi/86400.*sin(latitude0*pi/180.) - fcorz = sqrt(4.*(2*pi/(3600.*24.))**2-fcor**2) - fcory(:) = fcor - fcorzy(:) = fcorz - do j=1,ny - do i=1,nx - latitude(i,j) = latitude0 - longitude(i,j) = longitude0 - end do - end do - - if(ocnfrac.gt.0.5) then - OCEAN = .true. - else - LAND = .true. - end if - -! create CRM vertical grid and initialize some vertical reference arrays: -! - do k = 1, nzm - - z(k) = zmid(plev-k+1) - zint(plev+1) - zi(k) = zint(plev-k+2)- zint(plev+1) - pres(k) = pmid(plev-k+1)/100. - prespot(k)=(1000./pres(k))**(rgas/cp) - bet(k) = ggr/tl(plev-k+1) - gamaz(k)=ggr/cp*z(k) - - end do ! k -! zi(nz) = zint(plev-nz+2) - zi(nz) = zint(plev-nz+2)-zint(plev+1) !+++mhwang, 2012-02-04 - - dz = 0.5*(z(1)+z(2)) - do k=2,nzm - adzw(k) = (z(k)-z(k-1))/dz - end do - adzw(1) = 1. - adzw(nz) = adzw(nzm) -! adz(1) = 1. -! do k=2,nzm-1 -! adz(k) = 0.5*(z(k+1)-z(k-1))/dz -! end do -! adz(nzm) = adzw(nzm) -!+++mhwang fix the adz bug. (adz needs to be consistent with zi) -!2012-02-04 Minghuai Wang (minghuai.wang@pnnl.gov) - do k=1, nzm - adz(k)=(zi(k+1)-zi(k))/dz - end do - - do k = 1,nzm - rho(k) = pdel(plev-k+1)/ggr/(adz(k)*dz) - end do - do k=2,nzm -! rhow(k) = 0.5*(rho(k)+rho(k-1)) -!+++mhwang fix the rhow bug (rhow needes to be consistent with pmid) -!2012-02-04 Minghuai Wang (minghuai.wang@pnnl.gov) - rhow(k) = (pmid(plev-k+2)-pmid(plev-k+1))/ggr/(adzw(k)*dz) - end do - rhow(1) = 2*rhow(2) - rhow(3) -#ifdef SPCAM_CLUBB_SGS /* Fix extropolation for 30 point grid */ - if ( 2*rhow(nzm) - rhow(nzm-1) > 0. ) then - rhow(nz)= 2*rhow(nzm) - rhow(nzm-1) - else - rhow(nz)= sqrt( rhow(nzm) ) - endif -#else - rhow(nz)= 2*rhow(nzm) - rhow(nzm-1) -#endif /*CLUBB_SGS*/ - colprec=0 - colprecs=0 - -! -! Initialize: -! - - -! limit the velocity at the very first step: - - if(u_crm(1,1,1).eq.u_crm(2,1,1).and.u_crm(3,1,2).eq.u_crm(4,1,2)) then - do k=1,nzm - do j=1,ny - do i=1,nx - u_crm(i,j,k) = min( umax, max(-umax,u_crm(i,j,k)) ) - v_crm(i,j,k) = min( umax, max(-umax,v_crm(i,j,k)) )*YES3D - end do - end do - end do - - end if - - u(1:nx,1:ny,1:nzm) = u_crm(1:nx,1:ny,1:nzm) - v(1:nx,1:ny,1:nzm) = v_crm(1:nx,1:ny,1:nzm)*YES3D - w(1:nx,1:ny,1:nzm) = w_crm(1:nx,1:ny,1:nzm) - tabs(1:nx,1:ny,1:nzm) = t_crm(1:nx,1:ny,1:nzm) - micro_field(1:nx,1:ny,1:nzm,1:nmicro_fields) = micro_fields_crm(1:nx,1:ny,1:nzm,1:nmicro_fields) -#ifdef sam1mom - qn(1:nx,1:ny,1:nzm) = micro_fields_crm(1:nx,1:ny,1:nzm,3) -#endif - -#ifdef m2005 - cloudliq(1:nx,1:ny,1:nzm) = micro_fields_crm(1:nx,1:ny,1:nzm,11) -#endif - -#ifdef m2005 - do k=1, nzm -#ifdef MODAL_AERO -! set aerosol data - l=plev-k+1 - naer(k, 1:ntot_amode) = naermod(l, 1:ntot_amode) - vaer(k, 1:ntot_amode) = vaerosol(l, 1:ntot_amode) - hgaer(k, 1:ntot_amode) = hygro(l, 1:ntot_amode) -#endif - do j=1, ny - do i=1, nx -! if(micro_field(i,j,k,iqcl).gt.0) then - if(cloudliq(i,j,k).gt.0) then - if(dopredictNc) then - if( micro_field(i,j,k,incl).eq.0) micro_field(i,j,k,incl) = 1.0e6*Nc0/rho(k) - endif - end if - enddo - enddo - enddo -#endif - - w(:,:,nz)=0. - wsub (:) = 0. !used in clubb, +++mhwang - dudt(:,:,:,1:3) = 0. - dvdt(:,:,:,1:3) = 0. - dwdt(1:nx,1:ny,1:nz,1:3) = 0. - tke(1:nx,1:ny,1:nzm) = 0. - tk(1:nx,1:ny,1:nzm) = 0. - tkh(1:nx,1:ny,1:nzm) = 0. - p(1:nx,1:ny,1:nzm) = 0. - - CF3D(1:nx,1:ny,1:nzm) = 1. - - call micro_init - -! initialize sgs fields - call sgs_init - - do k=1,nzm - - u0(k)=0. - v0(k)=0. - t0(k)=0. - t00(k)=0. - tabs0(k)=0. - q0(k)=0. - qv0(k)=0. -!+++mhwang these are not initialized ?? - qn0(k) = 0.0 - qp0(k) = 0.0 - tke0(k) = 0.0 -!---mhwang - do j=1,ny - do i=1,nx - - t(i,j,k) = tabs(i,j,k)+gamaz(k) & - -fac_cond*qcl(i,j,k)-fac_sub*qci(i,j,k) & - -fac_cond*qpl(i,j,k)-fac_sub*qpi(i,j,k) - - colprec=colprec+(qpl(i,j,k)+qpi(i,j,k))*pdel(plev-k+1) - colprecs=colprecs+qpi(i,j,k)*pdel(plev-k+1) - u0(k)=u0(k)+u(i,j,k) - v0(k)=v0(k)+v(i,j,k) - t0(k)=t0(k)+t(i,j,k) - t00(k)=t00(k)+t(i,j,k)+fac_cond*qpl(i,j,k)+fac_sub*qpi(i,j,k) - tabs0(k)=tabs0(k)+tabs(i,j,k) - q0(k)=q0(k)+qv(i,j,k)+qcl(i,j,k)+qci(i,j,k) - qv0(k) = qv0(k) + qv(i,j,k) - qn0(k) = qn0(k) + qcl(i,j,k) + qci(i,j,k) - qp0(k) = qp0(k) + qpl(i,j,k) + qpi(i,j,k) - tke0(k)=tke0(k)+tke(i,j,k) - - end do - end do - - u0(k) = u0(k) * factor_xy - v0(k) = v0(k) * factor_xy - t0(k) = t0(k) * factor_xy - t00(k) = t00(k) * factor_xy - tabs0(k) = tabs0(k) * factor_xy - q0(k) = q0(k) * factor_xy - qv0(k) = qv0(k) * factor_xy - qn0(k) = qn0(k) * factor_xy - qp0(k) = qp0(k) * factor_xy - tke0(k) = tke0(k) * factor_xy - -#ifdef SPCAM_CLUBB_SGS - ! Update thetav for CLUBB. This is needed when we have a higher model top - ! than is in the sounding, because we subsequently use tv0 to initialize - ! thv_ds_zt/zm, which appear in CLUBB's anelastic buoyancy terms. - ! -dschanen UWM 11 Feb 2010 - tv0(k) = tabs0(k)*prespot(k)*(1.+epsv*q0(k)) -#endif - - l = plev-k+1 - uln(l) = min( umax, max(-umax,ul(l)) ) - vln(l) = min( umax, max(-umax,vl(l)) )*YES3D - ttend(k) = (tl(l)+gamaz(k)- & - fac_cond*(qccl(l)+qiil(l))-fac_fus*qiil(l)-t00(k))*idt_gl - qtend(k) = (ql(l)+qccl(l)+qiil(l)-q0(k))*idt_gl - utend(k) = (uln(l)-u0(k))*idt_gl - vtend(k) = (vln(l)-v0(k))*idt_gl - ug0(k) = uln(l) - vg0(k) = vln(l) - tg0(k) = tl(l)+gamaz(k)-fac_cond*qccl(l)-fac_sub*qiil(l) - qg0(k) = ql(l)+qccl(l)+qiil(l) - - end do ! k - - uhl = u0(1) - vhl = v0(1) - -! estimate roughness length assuming logarithmic profile of velocity near the surface: - - ustar = sqrt(tau00/rho(1)) - z0 = z0_est(z(1),bflx,wnd,ustar) - z0 = max(0.00001,min(1.,z0)) - - timing_factor = 0. - - prectend=colprec - precstend=colprecs - -#ifdef SPCAM_CLUBB_SGS - if(doclubb) then - fluxbu(:, :) = fluxu00/rhow(1) - fluxbv(:, :) = fluxv00/rhow(1) - fluxbt(:, :) = fluxt00/rhow(1) - fluxbq(:, :) = fluxq00/rhow(1) - else - fluxbu(:, :) = 0. - fluxbv(:, :) = 0. - fluxbt(:, :) = 0. - fluxbq(:, :) = 0. - end if -#else - fluxbu=0. - fluxbv=0. - fluxbt=0. - fluxbq=0. -#endif /*CLUBB_SGS*/ - - fluxtu=0. - fluxtv=0. - fluxtt=0. - fluxtq=0. - fzero =0. - precsfc=0. - precssfc=0. - -!--------------------------------------------------- - cld = 0. - cldtop = 0. - gicewp=0 - gliqwp=0 - mc = 0. - mcup = 0. - mcdn = 0. - mcuup = 0. - mcudn = 0. - crm_qc = 0. - crm_qi = 0. - crm_qs = 0. - crm_qg = 0. - crm_qr = 0. -#ifdef m2005 - crm_nc = 0. - crm_ni = 0. - crm_ns = 0. - crm_ng = 0. - crm_nr = 0. -! hm 8/31/11 add new variables - aut_crm_a = 0. - acc_crm_a = 0. - evpc_crm_a = 0. - evpr_crm_a = 0. - mlt_crm_a = 0. - sub_crm_a = 0. - dep_crm_a = 0. - con_crm_a = 0. - -! hm 8/31/11 add new output -! these are increments added to calculate gcm-grid and time-step avg -! note - these values are also averaged over the icycle loop following -! the approach for precsfc - aut1a = 0. - acc1a = 0. - evpc1a = 0. - evpr1a = 0. - mlt1a = 0. - sub1a = 0. - dep1a = 0. - con1a = 0. - -#endif - - mu_crm = 0. - md_crm = 0. - eu_crm = 0. - du_crm = 0. - ed_crm = 0. - dd_crm = 0. - jt_crm = 0. - mx_crm = 0. - - mui_crm = 0. - mdi_crm = 0. - - flux_qt = 0. - flux_u = 0. - flux_v = 0. - fluxsgs_qt = 0. - tkez = 0. - tkesgsz = 0. - tkz = 0. - flux_qp = 0. - pflx = 0. - qt_trans = 0. - qp_trans = 0. - qp_fall = 0. - qp_evp = 0. - qp_src = 0. - qt_ls = 0. - t_ls = 0. - - uwle = 0. - uwsb = 0. - vwle = 0. - vwsb = 0. - qpsrc = 0. - qpevp = 0. - qpfall = 0. - precflux = 0. - - prec_xy = 0.0 - total_water_evap = 0.0 - total_water_prec = 0.0 - tlat = 0.0 - pw_xy = 0.0; cw_xy=0.0; iw_xy = 0.0 - usfc_xy = 0.0; vsfc_xy =0.0; u200_xy =0.0; v200_xy = 0.0; w500_xy = 0.0 - swvp_xy = 0.0; psfc_xy = 0.0; u850_xy = 0.0; v850_xy = 0.0 - -!-------------------------------------------------- -#ifdef sam1mom - if(doprecip) call precip_init() -#endif - - call get_gcol_all_p(lchnk, pcols, gcolindex) - iseed = gcolindex(icol) - if(u(1,1,1).eq.u(2,1,1).and.u(3,1,2).eq.u(4,1,2)) & - call setperturb(iseed) - -#ifndef SPCAM_CLUBB_SGS -!-------------------------- -! do a CLUBB sanity check - if ( doclubb .or. doclubbnoninter ) then - write(0,*) "Cannot call CLUBB if -DCLUBB is not in FFLAGS" - call endrun('crm main') - end if -#endif /*CLUBB_SGS*/ -#ifdef SPCAM_CLUBB_SGS -!------------------------------------------------------------------ -! Do initialization for UWM CLUBB -!------------------------------------------------------------------ - up2(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 1) - vp2(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 2) - wprtp(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 3) - wpthlp(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 4) - wp2(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 5) - wp3(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 6) - rtp2(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 7) - thlp2(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 8) - rtpthlp(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 9) - upwp(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 10) - vpwp(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 11) - cloud_frac(1:nx, 1:ny, 1:nz) = clubb_buffer(1:nx, 1:ny, 1:nz, 12) - t_tndcy(1:nx, 1:ny, 1:nzm) = clubb_buffer(1:nx, 1:ny, 1:nzm, 13) - qc_tndcy(1:nx, 1:ny, 1:nzm) = clubb_buffer(1:nx, 1:ny, 1:nzm, 14) - qv_tndcy(1:nx, 1:ny, 1:nzm) = clubb_buffer(1:nx, 1:ny, 1:nzm, 15) - u_tndcy(1:nx, 1:ny, 1:nzm) = clubb_buffer(1:nx, 1:ny, 1:nzm, 16) - v_tndcy(1:nx, 1:ny, 1:nzm) = clubb_buffer(1:nx, 1:ny, 1:nzm, 17) - -! -! since no tracer is carried in the current version of MMF, these -! tracer-related restart varialbes are set to zero. +++mhwang, 2011-08 - tracer_tndcy = 0.0 - sclrp2 = 0.0 - sclrprtp = 0.0 - sclrpthlp = 0.0 - wpsclrp =0.0 - - if((doclubb.and.docloud).or.(.not.doclubb .and. .not.docloud)) then - write(0, *) 'doclubb and docloud can not both be true or be false' - call endrun('crm_clubb2') - end if - if((doclubb_sfc_fluxes.and.docam_sfc_fluxes)) then - write(0, *) 'doclubb_sfc_fluxes and dosam_sfc_fluxes can not both be true' - call endrun('crm_clubb_fluxes') - end if - - if ( doclubb .or. doclubbnoninter ) then - call clubb_sgs_setup( real( dt*real( nclubb ), kind=time_precision), & - latitude, longitude, z, rho, zi, rhow, tv0, tke ) - end if -#endif /*CLUBB_SGS*/ - -#ifdef ECPP -! ntavg1_ss = dt_gl/3 ! one third of GCM time step, 10 minutes - ntavg1_ss = min(600._r8, dt_gl) ! 10 minutes or the GCM timestep, whichever smaller - ! ntavg1_ss = number of seconds to average between computing categories. - ntavg2_ss = dt_gl ! GCM time step - ! ntavg2_ss = number of seconds to average between outputs. - ! This must be a multiple of ntavgt1_ss. -! -! ecpp_crm_init has to be called after ntavg1_ss and ntavg2_ss are set for -! their values are used in ecpp_crm_init. - call ecpp_crm_init() - - qlsink = 0.0 - qlsink_bf = 0.0 - prain = 0.0 - precr = 0.0 - precsolid = 0.0 -#endif /*ECPP*/ - -!+++mhwangtest -! test water conservtion problem - ntotal_step = 0.0 - qtot(:) = 0.0 - qtotmicro(:) = 0.0 - do k=1, nzm - l=plev-k+1 - do j=1, ny - do i=1, nx -#ifdef m2005 - qtot(1) = qtot(1)+((micro_field(i,j,k,iqr)+micro_field(i,j,k,iqs)+micro_field(i,j,k,iqg)) * pdel(l)/ggr)/(nx*ny) -#endif -#ifdef sam1mom - qtot(1) = qtot(1)+(qpl(i,j,k)+qpi(i,j,k)) * pdel(l)/ggr/(nx*ny) -#endif - enddo - enddo - qtot(1) = qtot(1) + (ql(l)+qccl(l)+qiil(l)) * pdel(l)/ggr - enddo -!---mhwangtest - - nstop = dt_gl/dt - dt = dt_gl/nstop - nsave3D = nint(60/dt) -! if(nint(nsave3D*dt).ne.60)then -! print *,'CRM: time step=',dt,' is not divisible by 60 seconds' -! print *,'this is needed for output every 60 seconds' -! stop -! endif - nstep = 0 - nprint = 1 - ncycle = 0 -! nrad = nstop/nrad0 - day=day0 - -!------------------------------------------------------------------ -! Main time loop -!------------------------------------------------------------------ - -do while(nstep.lt.nstop) - - nstep = nstep + 1 - time = time + dt - day = day0 + time/86400. - timing_factor = timing_factor+1 -!------------------------------------------------------------------ -! Check if the dynamical time step should be decreased -! to handle the cases when the flow being locally linearly unstable -!------------------------------------------------------------------ - - ncycle = 1 - - call kurant() - - do icyc=1,ncycle - - icycle = icyc - dtn = dt/ncycle - dt3(na) = dtn - dtfactor = dtn/dt - -!--------------------------------------------- -! the Adams-Bashforth scheme in time - - call abcoefs() - -!--------------------------------------------- -! initialize stuff: - - call zero() - -!----------------------------------------------------------- -! Buoyancy term: - - call buoyancy() - -!+++mhwangtest -! test water conservtion problem - ntotal_step = ntotal_step + 1. -!---mhwangtest - -!------------------------------------------------------------ -! Large-scale and surface forcing: - - call forcing() - - do k=1,nzm - do j=1,ny - do i=1,nx - t(i,j,k) = t(i,j,k) + qrad_crm(i,j,k)*dtn - end do - end do - end do - -!---------------------------------------------------------- -! suppress turbulence near the upper boundary (spange): - - if(dodamping) call damping() - -!--------------------------------------------------------- -! Ice fall-out - -#ifdef SPCAM_CLUBB_SGS - if ( docloud .or. doclubb ) then - call ice_fall() - end if -#else - if(docloud) then - call ice_fall() - end if -#endif /*CLUBB_SGS*/ - -!---------------------------------------------------------- -! Update scalar boundaries after large-scale processes: - - call boundaries(3) - -!--------------------------------------------------------- -! Update boundaries for velocities: - - call boundaries(0) - -!----------------------------------------------- -! surface fluxes: - - if(dosurface) call crmsurface(bflx) - -!----------------------------------------------------------- -! SGS physics: - - if (dosgs) call sgs_proc() - -#ifdef CLUBB_CRM_OLD -!---------------------------------------------------------- -! Do a timestep with CLUBB if enabled: -! -dschanen UWM 16 May 2008 - - if ( doclubb .or. doclubbnoninter ) then - ! In case of ice fall, we recompute qci here for the - ! single-moment scheme. Also, subsidence, diffusion and advection have - ! been applied to micro_field but not qv/qcl so they must be updated. - call micro_update() - end if ! doclubb .or. doclubbnoninter - - if ( doclubb ) then - ! Calculate the vertical integrals for RTM and THLM so we can later - ! calculate whether CLUBB is a spurious source or sink of either. - ! - nielsenb UWM 4 Jun 2010 - do i = 1,nx - do j = 1,ny - rtm_column = qv(i,j,1:nzm) + qcl(i,j,1:nzm) - rtm_integral_before(i,j) = vertical_integral( (nz - 2 + 1), rho_ds_zt(2:nz), & - rtm_column, gr%invrs_dzt(2:nz) ) - - thlm_before = t2thetal( t(i,j,1:nzm), gamaz(1:nzm), & - qcl(i,j,1:nzm), qpl(i,j,1:nzm), & - qci(i,j,1:nzm), qpi(i,j,1:nzm), & - prespot(1:nzm) ) - - thlm_integral_before(i,j) = vertical_integral( (nz - 2 + 1), rho_ds_zt(2:nz), & - thlm_before(1:nzm), gr%invrs_dzt(2:nz) ) - end do - end do - ! End vertical integral - - end if ! doclubb - - if ( doclubb .or. doclubbnoninter ) then - - ! We call CLUBB here because adjustments to the wind - ! must occur prior to adams() -dschanen 26 Aug 2008 - ! Here we call clubb only if nstep divides the current timestep, - ! or we're on the very first timestep - if ( nstep == 1 .or. mod( nstep, nclubb ) == 0 ) then - - call advance_clubb_sgs & - ( real( dtn*real( nclubb ), kind=time_precision), & ! in - real( 0., kind=time_precision ), & ! in - real( time, kind=time_precision ), & ! in - rho, rhow, wsub, u, v, w, qpl, qci, qpi, & ! in - t, qv, qcl ) ! in - end if ! nstep == 1 .or. mod( nstep, nclubb) == 0 - - end if ! doclubb .or. doclubbnoninter - -#endif /*CLUBB_CRM_OLD*/ -!---------------------------------------------------------- -! Fill boundaries for SGS diagnostic fields: - - call boundaries(4) -!----------------------------------------------- -! advection of momentum: - - call advect_mom() - -!---------------------------------------------------------- -! SGS effects on momentum: - - if(dosgs) call sgs_mom() -#ifdef CLUBB_CRM_OLD - if ( doclubb ) then -! call apply_clubb_sgs_tndcy_mom & -! ( dudt, dvdt ) ! in/out - endif -#endif /*CLUBB_CRM_OLD*/ - -!----------------------------------------------------------- -! Coriolis force: - - if(docoriolis) call coriolis() - -!--------------------------------------------------------- -! compute rhs of the Poisson equation and solve it for pressure. - - call pressure() - -!--------------------------------------------------------- -! find velocity field at n+1/2 timestep needed for advection of scalars: -! Note that at the end of the call, the velocities are in nondimensional form. - - call adams() - -!---------------------------------------------------------- -! Update boundaries for all prognostic scalar fields for advection: - - call boundaries(2) - -!--------------------------------------------------------- -! advection of scalars : - - call advect_all_scalars() - -!----------------------------------------------------------- -! Convert velocity back from nondimensional form: - - call uvw() - -!---------------------------------------------------------- -! Update boundaries for scalars to prepare for SGS effects: - - call boundaries(3) - -!--------------------------------------------------------- -! SGS effects on scalars : - - if (dosgs) call sgs_scalars() - -#ifdef CLUBB_CRM_OLD - ! Re-compute q/qv/qcl based on values computed in CLUBB - if ( doclubb ) then - - ! Recalculate q, qv, qcl based on new micro_fields (updated by horizontal - ! diffusion) - call micro_update() - - ! Then Re-compute q/qv/qcl based on values computed in CLUBB - call apply_clubb_sgs_tndcy_scalars & - ( real( dtn, kind=time_precision), & ! in - t, qv, qcl) ! in/out - - call micro_adjust( qv, qcl ) ! in - - ! Calculate the vertical integrals for RTM and THLM again so - ! calculate whether CLUBB is a spurious source or sink of either. - ! - nielsenb UWM 4 Jun 2010 - do i = 1,nx - do j = 1,ny - rtm_flux_top = rho_ds_zm(nz) * wprtp(i,j,nz) - rtm_flux_sfc = rho_ds_zm(1) * fluxbq(i,j) - rtm_column = qv(i,j,1:nzm) + qcl(i,j,1:nzm) - rtm_integral_after(i,j) = vertical_integral( (nz - 2 + 1), rho_ds_zt(2:nz), & - rtm_column, gr%invrs_dzt(2:nz) ) - - rtm_spurious_source(i,j) = calculate_spurious_source( rtm_integral_after(i,j), & - rtm_integral_before(i,j), & - rtm_flux_top, rtm_flux_sfc, & - 0.0_core_rknd, real( dtn, kind=core_rknd) ) - - thlm_flux_top = rho_ds_zm(nz) * wpthlp(i,j,nz) - thlm_flux_sfc = rho_ds_zm(1) * fluxbt(i,j) - - thlm_after = t2thetal( t(i,j,1:nzm), gamaz(1:nzm), & - qcl(i,j,1:nzm), qpl(i,j,1:nzm), & - qci(i,j,1:nzm), qpi(i,j,1:nzm), & - prespot(1:nzm) ) - - thlm_integral_after(i,j) = vertical_integral( (nz - 2 + 1), rho_ds_zt(2:nz), & - thlm_after(1:nzm), gr%invrs_dzt(2:nz)) - - thlm_spurious_source(i,j) = calculate_spurious_source( thlm_integral_after(i,j), & - thlm_integral_before(i,j), & - thlm_flux_top, thlm_flux_sfc, & - 0.0_core_rknd, real( dtn, kind=core_rknd )) - end do - end do - ! End spurious source calculation - - end if! doclubb -#endif /*CLUBB_CRM_OLD*/ - -!----------------------------------------------------------- -! Cloud condensation/evaporation and precipitation processes: -#ifdef SPCAM_CLUBB_SGS - if(docloud.or.dosmoke.or.doclubb) call micro_proc() -#else - if(docloud.or.dosmoke) call micro_proc() -#endif /*CLUBB_SGS*/ - -!----------------------------------------------------------- -! Compute diagnostics fields: - - call diagnose() - -!---------------------------------------------------------- -! Rotate the dynamic tendency arrays for Adams-bashforth scheme: - - nn=na - na=nc - nc=nb - nb=nn - - end do ! icycle - -!---------------------------------------------------------- -!---------------------------------------------------------- -#ifdef ECPP -! Here ecpp_crm_stat is called every CRM time step (dt), not every subcycle time step (dtn). -! This is what the original MMF model did (t_rad, qv_rad, ...). Do we want to call ecpp_crm_stat -! every subcycle time step??? +++mhwang - call ecpp_crm_stat() -#endif /*ECPP*/ - - cwp = 0. - cwph = 0. - cwpm = 0. - cwpl = 0. - - flag_top(:,:) = .true. - - cltemp = 0.0; cmtemp = 0.0 - chtemp = 0.0; cttemp = 0.0 - - do k=1,nzm - l = plev-k+1 - do j=1,ny - do i=1,nx - -! hm modify 9/7/11 for end of timestep, GCM-grid scale hydrometeor output -! instead of time-step-averaged -! I also modified this for all q and N variables as well as for sam1mom -! for consistency -!hm crm_qc(l) = crm_qc(l) + qcl(i,j,k) -!hm crm_qi(l) = crm_qi(l) + qci(i,j,k) -!hm crm_qr(l) = crm_qr(l) + qpl(i,j,k) -!hm#ifdef sam1mom -!hm omg = max(0.,min(1.,(tabs(i,j,k)-tgrmin)*a_gr)) -!hm crm_qg(l) = crm_qg(l) + qpi(i,j,k)*omg -!hm crm_qs(l) = crm_qs(l) + qpi(i,j,k)*(1.-omg) -!hm#else -! crm_qg(l) = crm_qg(l) + qpi(i,j,k) -! crm_qs(l) = crm_qs(l) + 0. ! temporerary solution -!hm crm_qg(l) = crm_qg(l) + micro_field(i,j,k,iqg) -!hm crm_qs(l) = crm_qs(l) + micro_field(i,j,k,iqs) - -!hm crm_nc(l) = crm_nc(l) + micro_field(i,j,k,incl) -!hm crm_ni(l) = crm_ni(l) + micro_field(i,j,k,inci) -!hm crm_nr(l) = crm_nr(l) + micro_field(i,j,k,inr) -!hm crm_ng(l) = crm_ng(l) + micro_field(i,j,k,ing) -!hm crm_ns(l) = crm_ns(l) + micro_field(i,j,k,ins) - -!hm#endif - - tmp1 = rho(nz-k)*adz(nz-k)*dz*(qcl(i,j,nz-k)+qci(i,j,nz-k)) - cwp(i,j) = cwp(i,j)+tmp1 - cttemp(i,j) = max(CF3D(i,j,nz-k), cttemp(i,j)) - if(cwp(i,j).gt.cwp_threshold.and.flag_top(i,j)) then - cldtop(k) = cldtop(k) + 1 - flag_top(i,j) = .false. - end if - if(pres(nz-k).ge.700.) then - cwpl(i,j) = cwpl(i,j)+tmp1 - cltemp(i,j) = max(CF3D(i,j,nz-k), cltemp(i,j)) - else if(pres(nz-k).lt.400.) then - cwph(i,j) = cwph(i,j)+tmp1 - chtemp(i,j) = max(CF3D(i,j,nz-k), chtemp(i,j)) - else - cwpm(i,j) = cwpm(i,j)+tmp1 - cmtemp(i,j) = max(CF3D(i,j,nz-k), cmtemp(i,j)) - end if - - ! qsat = qsatw_crm(tabs(i,j,k),pres(k)) - ! if(qcl(i,j,k)+qci(i,j,k).gt.min(1.e-5,0.01*qsat)) then - tmp1 = rho(k)*adz(k)*dz - if(tmp1*(qcl(i,j,k)+qci(i,j,k)).gt.cwp_threshold) then - cld(l) = cld(l) + CF3D(i,j,k) - if(w(i,j,k+1)+w(i,j,k).gt.2*wmin) then - mcup(l) = mcup(l) + rho(k)*0.5*(w(i,j,k+1)+w(i,j,k)) * CF3D(i,j,k) - mcuup(l) = mcuup(l) + rho(k)*0.5*(w(i,j,k+1)+w(i,j,k)) * (1.0 - CF3D(i,j,k)) - end if - if(w(i,j,k+1)+w(i,j,k).lt.-2*wmin) then - mcdn(l) = mcdn(l) + rho(k)*0.5*(w(i,j,k+1)+w(i,j,k)) * CF3D(i,j,k) - mcudn(l) = mcudn(l) + rho(k)*0.5*(w(i,j,k+1)+w(i,j,k)) * (1. - CF3D(i,j,k)) - end if - else - if(w(i,j,k+1)+w(i,j,k).gt.2*wmin) then - mcuup(l) = mcuup(l) + rho(k)*0.5*(w(i,j,k+1)+w(i,j,k)) - end if - if(w(i,j,k+1)+w(i,j,k).lt.-2*wmin) then - mcudn(l) = mcudn(l) + rho(k)*0.5*(w(i,j,k+1)+w(i,j,k)) - end if - end if - - t_rad (i,j,k) = t_rad (i,j,k)+tabs(i,j,k) - qv_rad(i,j,k) = qv_rad(i,j,k)+max(0.,qv(i,j,k)) - qc_rad(i,j,k) = qc_rad(i,j,k)+qcl(i,j,k) - qi_rad(i,j,k) = qi_rad(i,j,k)+qci(i,j,k) - cld_rad(i,j,k) = cld_rad(i,j,k) + CF3D(i,j,k) -#ifdef m2005 - nc_rad(i,j,k) = nc_rad(i,j,k)+micro_field(i,j,k,incl) - ni_rad(i,j,k) = ni_rad(i,j,k)+micro_field(i,j,k,inci) - qs_rad(i,j,k) = qs_rad(i,j,k)+micro_field(i,j,k,iqs) - ns_rad(i,j,k) = ns_rad(i,j,k)+micro_field(i,j,k,ins) -#endif - gliqwp(l)=gliqwp(l)+qcl(i,j,k) - gicewp(l)=gicewp(l)+qci(i,j,k) - - end do - end do - end do - -! Diagnose mass fluxes to drive CAM's convective transport of tracers. -! definition of mass fluxes is taken from Xu et al., 2002, QJRMS. - do k=1, nzm+1 - l=plev+1-k+1 - do j=1, ny - do i=1, nx - if(w(i,j,k).gt.0.) then - kx=max(1, k-1) - qsat = qsatw_crm(tabs(i,j,kx),pres(kx)) - if(qcl(i,j,kx)+qci(i,j,kx).gt.min(1.e-5,0.01*qsat)) then - mui_crm(l) = mui_crm(l)+rhow(k)*w(i,j,k) - end if - else if (w(i,j,k).lt.0.) then - kx=min(k+1, nzm) - qsat = qsatw_crm(tabs(i,j,kx),pres(kx)) - if(qcl(i,j,kx)+qci(i,j,kx).gt.min(1.e-5,0.01*qsat)) then - mdi_crm(l) = mdi_crm(l)+rhow(k)*w(i,j,k) - else if(qpl(i,j,kx)+qpi(i,j,kx).gt.1.0e-4) then - mdi_crm(l) = mdi_crm(l)+rhow(k)*w(i,j,k) - end if - end if - end do - end do - end do - -! do k=1,nzm -! radlwup0(k)=radlwup0(k)+radlwup(k) -! radlwdn0(k)=radlwdn0(k)+radlwdn(k) -! radqrlw0(k)=radqrlw0(k)+radqrlw(k) -! radswup0(k)=radswup0(k)+radswup(k) -! radswdn0(k)=radswdn0(k)+radswdn(k) -! radqrsw0(k)=radqrsw0(k)+radqrsw(k) -! end do - - do j=1,ny - do i=1,nx -! if(cwp(i,j).gt.cwp_threshold) cltot = cltot + 1. -! if(cwph(i,j).gt.cwp_threshold) clhgh = clhgh + 1. -! if(cwpm(i,j).gt.cwp_threshold) clmed = clmed + 1. -! if(cwpl(i,j).gt.cwp_threshold) cllow = cllow + 1. -! use maxmimum cloud overlap to calcluate cltot, clhgh, -! cldmed, and cldlow +++ mhwang - if(cwp(i,j).gt.cwp_threshold) cltot = cltot + cttemp(i,j) - if(cwph(i,j).gt.cwp_threshold) clhgh = clhgh + chtemp(i,j) - if(cwpm(i,j).gt.cwp_threshold) clmed = clmed + cmtemp(i,j) - if(cwpl(i,j).gt.cwp_threshold) cllow = cllow + cltemp(i,j) - end do - end do - -! call stepout() -!---------------------------------------------------------- - end do ! main loop -!---------------------------------------------------------- - - tmp1 = 1._r8/ dble(nstop) - t_rad = t_rad * tmp1 - qv_rad = qv_rad * tmp1 - qc_rad = qc_rad * tmp1 - qi_rad = qi_rad * tmp1 - cld_rad = cld_rad * tmp1 -#ifdef m2005 - nc_rad = nc_rad * tmp1 - ni_rad = ni_rad * tmp1 - qs_rad = qs_rad * tmp1 - ns_rad = ns_rad * tmp1 -#endif - -! no CRM tendencies above its top - - tln(1:ptop-1) = tl(1:ptop-1) - qln(1:ptop-1) = ql(1:ptop-1) - qccln(1:ptop-1)= qccl(1:ptop-1) - qiiln(1:ptop-1)= qiil(1:ptop-1) - uln(1:ptop-1) = ul(1:ptop-1) - vln(1:ptop-1) = vl(1:ptop-1) - -! Compute tendencies due to CRM: - - tln(ptop:plev) = 0. - qln(ptop:plev) = 0. - qccln(ptop:plev)= 0. - qiiln(ptop:plev)= 0. - uln(ptop:plev) = 0. - vln(ptop:plev) = 0. - - colprec=0 - colprecs=0 - do k = 1,nzm - l = plev-k+1 - do i=1,nx - do j=1,ny - colprec=colprec+(qpl(i,j,k)+qpi(i,j,k))*pdel(plev-k+1) - colprecs=colprecs+qpi(i,j,k)*pdel(plev-k+1) - tln(l) = tln(l)+tabs(i,j,k) - qln(l) = qln(l)+qv(i,j,k) - qccln(l)= qccln(l)+qcl(i,j,k) - qiiln(l)= qiiln(l)+qci(i,j,k) - uln(l) = uln(l)+u(i,j,k) - vln(l) = vln(l)+v(i,j,k) - end do ! k - end do - end do ! i - - - tln(ptop:plev) = tln(ptop:plev) * factor_xy - qln(ptop:plev) = qln(ptop:plev) * factor_xy - qccln(ptop:plev) = qccln(ptop:plev) * factor_xy - qiiln(ptop:plev) = qiiln(ptop:plev) * factor_xy - uln(ptop:plev) = uln(ptop:plev) * factor_xy - vln(ptop:plev) = vln(ptop:plev) * factor_xy - - sltend = cp * (tln - tl) * idt_gl - qltend = (qln - ql) * idt_gl - qcltend = (qccln - qccl) * idt_gl - qiltend = (qiiln - qiil) * idt_gl - prectend=(colprec-prectend)/ggr*factor_xy * idt_gl - precstend=(colprecs-precstend)/ggr*factor_xy * idt_gl - -! don't use CRM tendencies from two crm top levels - sltend(ptop:ptop+1) = 0. - qltend(ptop:ptop+1) = 0. - qcltend(ptop:ptop+1) = 0. - qiltend(ptop:ptop+1) = 0. -!------------------------------------------------------------- -! -! Save the last step to the permanent core: - - u_crm (1:nx,1:ny,1:nzm) = u (1:nx,1:ny,1:nzm) - v_crm (1:nx,1:ny,1:nzm) = v (1:nx,1:ny,1:nzm) - w_crm (1:nx,1:ny,1:nzm) = w (1:nx,1:ny,1:nzm) - t_crm (1:nx,1:ny,1:nzm) = tabs(1:nx,1:ny,1:nzm) - micro_fields_crm(1:nx,1:ny,1:nzm,1:nmicro_fields) = micro_field(1:nx,1:ny,1:nzm,1:nmicro_fields) -#ifdef sam1mom - micro_fields_crm(1:nx,1:ny,1:nzm,3) = qn(1:nx,1:ny,1:nzm) -#endif -#ifdef m2005 - micro_fields_crm(1:nx,1:ny,1:nzm,11) = cloudliq(1:nx,1:ny,1:nzm) -#endif - crm_tk(1:nx,1:ny,1:nzm) = tk(1:nx, 1:ny, 1:nzm) - crm_tkh(1:nx,1:ny,1:nzm) = tkh(1:nx, 1:ny, 1:nzm) - cld3d_crm(1:nx, 1:ny, 1:nzm) = CF3D(1:nx, 1:ny, 1:nzm) -#ifdef SPCAM_CLUBB_SGS - clubb_buffer(1:nx, 1:ny, 1:nz, 1) = up2(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 2) = vp2(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 3) = wprtp(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 4) = wpthlp(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 5) = wp2(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 6) = wp3(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 7) = rtp2(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 8) = thlp2(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 9) = rtpthlp(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 10) = upwp(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 11) = vpwp(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nz, 12) = cloud_frac(1:nx, 1:ny, 1:nz) - clubb_buffer(1:nx, 1:ny, 1:nzm, 13) = t_tndcy(1:nx, 1:ny, 1:nzm) - clubb_buffer(1:nx, 1:ny, 1:nzm, 14) = qc_tndcy(1:nx, 1:ny, 1:nzm) - clubb_buffer(1:nx, 1:ny, 1:nzm, 15) = qv_tndcy(1:nx, 1:ny, 1:nzm) - clubb_buffer(1:nx, 1:ny, 1:nzm, 16) = u_tndcy(1:nx, 1:ny, 1:nzm) - clubb_buffer(1:nx, 1:ny, 1:nzm, 17) = v_tndcy(1:nx, 1:ny, 1:nzm) - - crm_cld(1:nx, 1:ny, 1:nz) = cloud_frac(1:nx, 1:ny, 1:nz) - clubb_tk(1:nx,1:ny,1:nzm) = tk_clubb(1:nx, 1:ny, 1:nzm) - clubb_tkh(1:nx,1:ny,1:nzm) = tkh_clubb(1:nx, 1:ny, 1:nzm) - relvar(1:nx, 1:ny, 1:nzm) = relvarg(1:nx, 1:ny, 1:nzm) - accre_enhan(1:nx, 1:ny, 1:nzm) = accre_enhang(1:nx, 1:ny, 1:nzm) - qclvar(1:nx, 1:ny, 1:nzm) = qclvarg(1:nx, 1:ny, 1:nzm) -#endif - - do k=1,nzm - do j=1,ny - do i=1,nx - qc_crm(i,j,k) = qcl(i,j,k) - qi_crm(i,j,k) = qci(i,j,k) - qpc_crm(i,j,k) = qpl(i,j,k) - qpi_crm(i,j,k) = qpi(i,j,k) -#ifdef m2005 - wvar_crm(i,j,k) = wvar(i,j,k) -! hm 7/26/11, new output - aut_crm(i,j,k) = aut1(i,j,k) - acc_crm(i,j,k) = acc1(i,j,k) - evpc_crm(i,j,k) = evpc1(i,j,k) - evpr_crm(i,j,k) = evpr1(i,j,k) - mlt_crm(i,j,k) = mlt1(i,j,k) - sub_crm(i,j,k) = sub1(i,j,k) - dep_crm(i,j,k) = dep1(i,j,k) - con_crm(i,j,k) = con1(i,j,k) -#endif - end do - end do - end do - z0m = z0 - taux_crm = taux0 / dble(nstop) - tauy_crm = tauy0 / dble(nstop) - -!--------------------------------------------------------------- -! -! Diagnostics: - -! hm add 9/7/11, change from GCM-time step avg to end-of-timestep - - do k=1,nzm - l = plev-k+1 - do j=1,ny - do i=1,nx - - crm_qc(l) = crm_qc(l) + qcl(i,j,k) - crm_qi(l) = crm_qi(l) + qci(i,j,k) - crm_qr(l) = crm_qr(l) + qpl(i,j,k) -#ifdef sam1mom - omg = max(0.,min(1.,(tabs(i,j,k)-tgrmin)*a_gr)) - crm_qg(l) = crm_qg(l) + qpi(i,j,k)*omg - crm_qs(l) = crm_qs(l) + qpi(i,j,k)*(1.-omg) -#else -! crm_qg(l) = crm_qg(l) + qpi(i,j,k) -! crm_qs(l) = crm_qs(l) + 0. ! temporerary solution - crm_qg(l) = crm_qg(l) + micro_field(i,j,k,iqg) - crm_qs(l) = crm_qs(l) + micro_field(i,j,k,iqs) - - crm_nc(l) = crm_nc(l) + micro_field(i,j,k,incl) - crm_ni(l) = crm_ni(l) + micro_field(i,j,k,inci) - crm_nr(l) = crm_nr(l) + micro_field(i,j,k,inr) - crm_ng(l) = crm_ng(l) + micro_field(i,j,k,ing) - crm_ns(l) = crm_ns(l) + micro_field(i,j,k,ins) -#endif - - end do - end do - end do - - cld = min(1._r8,cld/float(nstop)*factor_xy) - cldtop = min(1._r8,cldtop/float(nstop)*factor_xy) - gicewp(:)=gicewp*pdel(:)*1000./ggr/float(nstop)*factor_xy - gliqwp(:)=gliqwp*pdel(:)*1000./ggr/float(nstop)*factor_xy - mcup = mcup / float(nstop) * factor_xy - mcdn = mcdn / float(nstop) * factor_xy - mcuup = mcuup / float(nstop) * factor_xy - mcudn = mcudn / float(nstop) * factor_xy - mc = mcup + mcdn + mcuup + mcudn -! hm 9/7/11 modify for end-of-timestep instead of timestep-avg output -!hm crm_qc = crm_qc / float(nstop) * factor_xy -!hm crm_qi = crm_qi / float(nstop) * factor_xy -!hm crm_qs = crm_qs / float(nstop) * factor_xy -!hm crm_qg = crm_qg / float(nstop) * factor_xy -!hm crm_qr = crm_qr / float(nstop) * factor_xy -!hm#ifdef m2005 -!hm crm_nc = crm_nc / float(nstop) * factor_xy -!hm crm_ni = crm_ni / float(nstop) * factor_xy -!hm crm_ns = crm_ns / float(nstop) * factor_xy -!hm crm_ng = crm_ng / float(nstop) * factor_xy -!hm crm_nr = crm_nr / float(nstop) * factor_xy - - crm_qc = crm_qc * factor_xy - crm_qi = crm_qi * factor_xy - crm_qs = crm_qs * factor_xy - crm_qg = crm_qg * factor_xy - crm_qr = crm_qr * factor_xy -#ifdef m2005 - crm_nc = crm_nc * factor_xy - crm_ni = crm_ni * factor_xy - crm_ns = crm_ns * factor_xy - crm_ng = crm_ng * factor_xy - crm_nr = crm_nr * factor_xy - - -! hm 8/31/11 new output, gcm-grid- and time-step avg -! add loop over i,j do get horizontal avg, and flip vertical array - do k=1,nzm - l = plev-k+1 - do j=1,ny - do i=1,nx - aut_crm_a(l) = aut_crm_a(l) + aut1a(i,j,k) - acc_crm_a(l) = acc_crm_a(l) + acc1a(i,j,k) - evpc_crm_a(l) = evpc_crm_a(l) + evpc1a(i,j,k) - evpr_crm_a(l) = evpr_crm_a(l) + evpr1a(i,j,k) - mlt_crm_a(l) = mlt_crm_a(l) + mlt1a(i,j,k) - sub_crm_a(l) = sub_crm_a(l) + sub1a(i,j,k) - dep_crm_a(l) = dep_crm_a(l) + dep1a(i,j,k) - con_crm_a(l) = con_crm_a(l) + con1a(i,j,k) - end do - end do - end do - -! note, rates are divded by dt to get mean rate over step - aut_crm_a = aut_crm_a / dble(nstop) * factor_xy / dt - acc_crm_a = acc_crm_a / dble(nstop) * factor_xy / dt - evpc_crm_a = evpc_crm_a / dble(nstop) * factor_xy / dt - evpr_crm_a = evpr_crm_a / dble(nstop) * factor_xy / dt - mlt_crm_a = mlt_crm_a / dble(nstop) * factor_xy / dt - sub_crm_a = sub_crm_a / dble(nstop) * factor_xy / dt - dep_crm_a = dep_crm_a / dble(nstop) * factor_xy / dt - con_crm_a = con_crm_a / dble(nstop) * factor_xy / dt - -#endif - precc = 0. - precl = 0. - precsc = 0. - precsl = 0. - do j=1,ny - do i=1,nx -#ifdef sam1mom - precsfc(i,j) = precsfc(i,j)*dz/dt/dble(nstop) - precssfc(i,j) = precssfc(i,j)*dz/dt/dble(nstop) -#endif -#ifdef m2005 -! precsfc and precssfc from the subroutine of micro_proc in M2005 have a unit mm/s/dz -! precsfc(i,j) = precsfc(i,j)*dz/dble(nstop) !mm/s/dz --> mm/s -! precssfc(i,j) = precssfc(i,j)*dz/dble(nstop) !mm/s/dz --> mm/s -! precsfc and precssfc from the subroutine of micro_proc in M2005 have a unit mm/dz - precsfc(i,j) = precsfc(i,j)*dz/dt/dble(nstop) !mm/s/dz --> mm/s - precssfc(i,j) = precssfc(i,j)*dz/dt/dble(nstop) !mm/s/dz --> mm/s - -#endif - if(precsfc(i,j).gt.10./86400.) then - precc = precc + precsfc(i,j) - precsc = precsc + precssfc(i,j) - else - precl = precl + precsfc(i,j) - precsl = precsl + precssfc(i,j) - end if - end do - end do - prec_crm = precsfc/1000. !mm/s --> m/s - precc = precc*factor_xy/1000. - precl = precl*factor_xy/1000. - precsc = precsc*factor_xy/1000. - precsl = precsl*factor_xy/1000. - -!+++mhwangtest -! test water conservtion problem - do k=1, nzm - l=plev-k+1 - do j=1, ny - do i=1, nx -#ifdef m2005 - qtot(9) = qtot(9)+((micro_field(i,j,k,iqr)+micro_field(i,j,k,iqs)+micro_field(i,j,k,iqg)) * pdel(l)/ggr)/(nx*ny) - qtot(9) = qtot(9)+((micro_field(i,j,k,iqv)+micro_field(i,j,k,iqci)) * pdel(l)/ggr)/(nx*ny) -#endif -#ifdef sam1mom - qtot(9) = qtot(9)+((micro_field(i,j,k,1)+micro_field(i,j,k,2)) * pdel(l)/ggr)/(nx*ny) -#endif - enddo - enddo - enddo - qtot(9) = qtot(9) + (precc+precl)*1000 * dt_gl - - if(abs(qtot(9)-qtot(1))/qtot(1).gt.1.0e-6) then -! write(0, *) 'in crm water middle ', igstep, lchnk, icol, qtot(2:8)/ntotal_step, (qtot(5)-qtot(4)) * ntotal_step/qtot(4), & -! (qtot(6)+(precc+precl)*1000 * dt_gl-qtot(5))*ntotal_step/qtot(5) -! write(0, *) 'in crm water middle2 ', igstep, lchnk, icol, qtot(2:8)/ntotal_step, (qtot(8)-qtot(7)) * ntotal_step/qtot(7) -! write(0, *) 'total water (liquid+vapor)', qtot(16:19)/nstop, (qtot(17)-qtot(16)) * ntotal_step/qtot(16), & -! (qtot(18)-qtot(19)) * ntotal_step/qtot(19), -! call endrun('water conservation in crm.F90') - end if -!---mhwangtest - - cltot = cltot *factor_xy/nstop - clhgh = clhgh *factor_xy/nstop - clmed = clmed *factor_xy/nstop - cllow = cllow *factor_xy/nstop - - jt_crm = plev * 1.0 - mx_crm = 1.0 - do k=1, plev - mu_crm(k)=0.5*(mui_crm(k)+mui_crm(k+1)) - md_crm(k)=0.5*(mdi_crm(k)+mdi_crm(k+1)) - mu_crm(k)=mu_crm(k)*ggr/100. !kg/m2/s --> mb/s - md_crm(k)=md_crm(k)*ggr/100. !kg/m2/s --> mb/s - eu_crm(k) = 0. - if(mui_crm(k)-mui_crm(k+1).gt.0) then - eu_crm(k)=(mui_crm(k)-mui_crm(k+1))*ggr/pdel(k) !/s - else - du_crm(k)=-1.0*(mui_crm(k)-mui_crm(k+1))*ggr/pdel(k) !/s - end if - if(mdi_crm(k+1)-mdi_crm(k).lt.0) then - ed_crm(k)=(mdi_crm(k)-mdi_crm(k+1))*ggr/pdel(k) ! /s - else - dd_crm(k)=-1.*(mdi_crm(k)-mdi_crm(k+1))*ggr/pdel(k) !/s - end if - if(abs(mu_crm(k)).gt.1.0e-15.or.abs(md_crm(k)).gt.1.0e-15) then - jt_crm = min(k*1.0_r8, jt_crm) - mx_crm = max(k*1.0_r8, mx_crm) - end if - end do - -!------------------------------------------------------------- -! Fluxes and other stat: -!------------------------------------------------------------- - do k=1,nzm - u2z = 0. - v2z = 0. - w2z = 0. - do j=1,ny - do i=1,nx - u2z = u2z+(u(i,j,k)-u0(k))**2 - v2z = v2z+(v(i,j,k)-v0(k))**2 - w2z = w2z+0.5*(w(i,j,k+1)**2+w(i,j,k)**2) - end do - end do - -!+++mhwang -! mkwsb, mkle, mkadv, mkdiff (also flux_u, flux_v) seem not calculted correclty in the spcam3.5 codes. -! Only values at the last time step are calculated, but is averaged over the entire GCM -! time step. -!---mhwang - - tmp1 = dz/rhow(k) - tmp2 = tmp1/dtn ! dtn is calculated inside of the icyc loop. - ! It seems wrong to use it here ???? +++mhwang - mkwsb(k,:) = mkwsb(k,:) * tmp1*rhow(k) * factor_xy/nstop !kg/m3/s --> kg/m2/s - mkwle(k,:) = mkwle(k,:) * tmp2*rhow(k) * factor_xy/nstop !kg/m3 --> kg/m2/s - mkadv(k,:) = mkadv(k,:) * factor_xy*idt_gl ! kg/kg --> kg/kg/s - mkdiff(k,:) = mkdiff(k,:) * factor_xy*idt_gl ! kg/kg --> kg/kg/s - -! qpsrc, qpevp, qpfall in M2005 are calculated in micro_flux. - qpsrc(k) = qpsrc(k) * factor_xy*idt_gl - qpevp(k) = qpevp(k) * factor_xy*idt_gl - qpfall(k) = qpfall(k) * factor_xy*idt_gl ! kg/kg in M2005 ---> kg/kg/s - precflux(k) = precflux(k) * factor_xy*dz/dt/nstop !kg/m2/dz in M2005 -->kg/m2/s or mm/s (idt_gl=1/dt/nstop) - - l = plev-k+1 - flux_u(l) = (uwle(k) + uwsb(k))*tmp1*factor_xy/nstop - flux_v(l) = (vwle(k) + vwsb(k))*tmp1*factor_xy/nstop -#ifdef sam1mom - flux_qt(l) = mkwle(k,1) + mkwsb(k,1) - fluxsgs_qt(l) = mkwsb(k,1) - flux_qp(l) = mkwle(k,2) + mkwsb(k,2) - qt_trans(l) = mkadv(k,1) + mkdiff(k,1) - qp_trans(l) = mkadv(k,2) + mkdiff(k,2) -#endif -#ifdef m2005 - flux_qt(l) = mkwle(k,1) + mkwsb(k,1) + & - mkwle(k,iqci) + mkwsb(k,iqci) - fluxsgs_qt(l) = mkwsb(k,1) + mkwsb(k,iqci) - flux_qp(l) = mkwle(k,iqr) + mkwsb(k,iqr) + & - mkwle(k,iqs) + mkwsb(k,iqs) + mkwle(k,iqg) + mkwsb(k,iqg) - qt_trans(l) = mkadv(k,1) + mkadv(k,iqci) + & - mkdiff(k,1) + mkdiff(k,iqci) - qp_trans(l) = mkadv(k,iqr) + mkadv(k,iqs) + mkadv(k,iqg) + & - mkdiff(k,iqr) + mkdiff(k,iqs) + mkdiff(k,iqg) -#endif - tkesgsz(l)= rho(k)*sum(tke(1:nx,1:ny,k))*factor_xy - tkez(l)= rho(k)*0.5*(u2z+v2z*YES3D+w2z)*factor_xy + tkesgsz(l) - tkz(l) = sum(tk(1:nx, 1:ny, k)) * factor_xy - pflx(l) = precflux(k)/1000. !mm/s -->m/s - - qp_fall(l) = qpfall(k) - qp_evp(l) = qpevp(k) - qp_src(l) = qpsrc(k) - - qt_ls(l) = qtend(k) - t_ls(l) = ttend(k) - end do - -#ifdef ECPP - abnd=0.0 - abnd_tf=0.0 - massflxbnd=0.0 - acen=0.0 - acen_tf=0.0 - rhcen=0.0 - qcloudcen=0.0 - qicecen=0.0 - qlsinkcen=0.0 - precrcen=0.0 - precsolidcen=0.0 - wupthresh_bnd = 0.0 - wdownthresh_bnd = 0.0 - wwqui_cen = 0.0 - wwqui_bnd = 0.0 - wwqui_cloudy_cen = 0.0 - wwqui_cloudy_bnd = 0.0 - qlsink_bfcen = 0.0 - qlsink_avgcen = 0.0 - praincen = 0.0 -! default is clear, non-precipitating, and quiescent class - abnd(:,1,1,1)=1.0 - abnd_tf(:,1,1,1)=1.0 - acen(:,1,1,1)=1.0 - acen_tf(:,1,1,1)=1.0 - - do k=1, nzm - l=plev-k+1 - acen(l,:,:,:)=area_cen_sum(k,:,1:ncls_ecpp_in,:) - acen_tf(l,:,:,:)=area_cen_final(k,:,1:ncls_ecpp_in,:) - rhcen(l,:,:,:)=rh_cen_sum(k,:,1:ncls_ecpp_in,:) - qcloudcen(l,:,:,:)=qcloud_cen_sum(k,:,1:ncls_ecpp_in,:) - qicecen(l,:,:,:)=qice_cen_sum(k,:,1:ncls_ecpp_in,:) - qlsinkcen(l,:,:,:)=qlsink_cen_sum(k,:,1:ncls_ecpp_in,:) - precrcen(l,:,:,:)=precr_cen_sum(k,:,1:ncls_ecpp_in,:) - precsolidcen(l,:,:,:)=precsolid_cen_sum(k,:,1:ncls_ecpp_in,:) - wwqui_cen(l) = wwqui_cen_sum(k) - wwqui_cloudy_cen(l) = wwqui_cloudy_cen_sum(k) - qlsink_bfcen(l,:,:,:)=qlsink_bf_cen_sum(k,:,1:ncls_ecpp_in,:) - qlsink_avgcen(l,:,:,:)=qlsink_avg_cen_sum(k,:,1:ncls_ecpp_in,:) - praincen(l,:,:,:)=prain_cen_sum(k,:,1:ncls_ecpp_in,:) - end do - do k=1, nzm+1 - l=plev+1-k+1 - abnd(l,:,:,:)=area_bnd_sum(k,:,1:ncls_ecpp_in,:) - abnd_tf(l,:,:,:)=area_bnd_final(k,:,1:ncls_ecpp_in,:) - massflxbnd(l,:,:,:)=mass_bnd_sum(k,:,1:ncls_ecpp_in,:) - wupthresh_bnd(l)=wup_thresh(k) - wdownthresh_bnd(l)=wdown_thresh(k) - wwqui_bnd(l) = wwqui_bnd_sum(k) - wwqui_cloudy_bnd(l) = wwqui_cloudy_bnd_sum(k) - end do -#endif /*ECPP*/ - - timing_factor = timing_factor / nstop - -#ifdef SPCAM_CLUBB_SGS -! Deallocate CLUBB variables, etc. -! -UWM - if ( doclubb .or. doclubbnoninter ) call clubb_sgs_cleanup( ) -#endif -#ifdef ECPP -! Deallocate ECPP variables - call ecpp_crm_cleanup () -#endif /*ECPP*/ - -end subroutine crm -end module crmx_crm_module diff --git a/src/physics/spcam/crm/crmx_crmsurface.F90 b/src/physics/spcam/crm/crmx_crmsurface.F90 deleted file mode 100644 index f5e3ae17f4..0000000000 --- a/src/physics/spcam/crm/crmx_crmsurface.F90 +++ /dev/null @@ -1,155 +0,0 @@ - subroutine crmsurface(bflx) - - - use crmx_vars - use crmx_params - - implicit none - - real, intent (in) :: bflx - real u_h0, tau00, tauxm, tauym - real diag_ustar - integer i,j - -!-------------------------------------------------------- - - - if(SFC_FLX_FXD.and..not.SFC_TAU_FXD) then - - uhl = uhl + dtn*utend(1) - vhl = vhl + dtn*vtend(1) - - tauxm = 0. - tauym = 0. - - do j=1,ny - do i=1,nx - u_h0 = max(1.,sqrt((0.5*(u(i+1,j,1)+u(i,j,1))+ug)**2+ & - (0.5*(v(i,j+YES3D,1)+v(i,j,1))+vg)**2)) - tau00 = rho(1) * diag_ustar(z(1),bflx,u_h0,z0)**2 - fluxbu(i,j) = -(0.5*(u(i+1,j,1)+u(i,j,1))+ug-uhl)/u_h0*tau00 - fluxbv(i,j) = -(0.5*(v(i,j+YES3D,1)+v(i,j,1))+vg-vhl)/u_h0*tau00 - tauxm = tauxm + fluxbu(i,j) - tauym = tauym + fluxbv(i,j) - end do - end do - - taux0 = taux0 + tauxm/dble(nx*ny) - tauy0 = tauy0 + tauym/dble(nx*ny) - - end if ! SFC_FLX_FXD - - return - end - - - - - -! ---------------------------------------------------------------------- -! -! 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 -! -! Code corrected 8th June 1999 (obukhov length was wrong way up, -! so now used as reciprocal of obukhov length) - - real function diag_ustar(z,bflx,wnd,z0) - - implicit none - real, parameter :: vonk = 0.4 ! von Karmans constant - real, parameter :: g = 9.81 ! gravitational acceleration - real, parameter :: am = 4.8 ! " " " - real, parameter :: bm = 19.3 ! " " " - real, parameter :: eps = 1.e-10 ! non-zero, small number - - real, intent (in) :: z ! height where u locates - real, intent (in) :: bflx ! surface buoyancy flux (m^2/s^3) - real, intent (in) :: wnd ! wind speed at z - real, intent (in) :: z0 ! momentum roughness height - - integer :: iterate - real :: lnz, klnz, c1, x, psi1, zeta, rlmo, ustar - - lnz = log(z/z0) - klnz = vonk/lnz - c1 = 3.14159/2. - 3.*log(2.) - - ustar = wnd*klnz - if (bflx /= 0.0) then - do iterate=1,8 - rlmo = -bflx * vonk/(ustar**3 + eps) !reciprocal of - !obukhov length - zeta = min(1.,z*rlmo) - if (zeta > 0.) then - ustar = vonk*wnd /(lnz + am*zeta) - else - x = sqrt( sqrt( 1.0 - bm*zeta ) ) - psi1 = 2.*log(1.0+x) + log(1.0+x*x) - 2.*atan(x) + c1 - ustar = wnd*vonk/(lnz - psi1) - end if - end do - end if - - diag_ustar = ustar - - return - end function diag_ustar -! ---------------------------------------------------------------------- - - - - real function z0_est(z,bflx,wnd,ustar) - -! -! Compute z0 from buoyancy flux, wind, and friction velocity -! -! 2004, Marat Khairoutdinov -! - - implicit none - real, parameter :: vonk = 0.4 ! von Karmans constant - real, parameter :: g = 9.81 ! gravitational acceleration - real, parameter :: am = 4.8 ! " " " - real, parameter :: bm = 19.3 ! " " " - real, parameter :: eps = 1.e-10 ! non-zero, small number - - real, intent (in) :: z ! height where u locates - real, intent (in) :: bflx ! surface buoyancy flux (m^2/s^3) - real, intent (in) :: wnd ! wind speed at z - real, intent (in) :: ustar ! friction velocity - - real :: lnz, klnz, c1, x, psi1, zeta, rlmo - - c1 = 3.14159/2. - 3.*log(2.) - rlmo = -bflx*vonk/(ustar**3+eps) !reciprocal of - zeta = min(1.,z*rlmo) - if (zeta >= 0.) then - psi1 = -am*zeta - else - x = sqrt( sqrt( 1.0 - bm*zeta ) ) - psi1 = 2.*log(1.0+x) + log(1.0+x*x) - 2.*atan(x) + c1 - end if - lnz = max(0.,vonk*wnd/(ustar + eps) + psi1) - z0_est = z*exp(-lnz) - - return - end function z0_est -! ---------------------------------------------------------------------- - diff --git a/src/physics/spcam/crm/crmx_crmtracers.F90 b/src/physics/spcam/crm/crmx_crmtracers.F90 deleted file mode 100644 index 62322267c3..0000000000 --- a/src/physics/spcam/crm/crmx_crmtracers.F90 +++ /dev/null @@ -1,142 +0,0 @@ -module crmx_crmtracers - - -! This module serves as a template for adding tracer transport in the model. The tracers can be -! chemical tracers, or bin microphysics drop/ice categories, etc. -! The number of tracers is set by the parameter ntracers which is set in domain.f90. -! Also, the logical flag dotracers should be set to .true. in namelist (default is .false.). -! The model will transport the tracers around automatically (advection and SGS diffusion). -! The user must supply the initialization in the subroutine tracers_init() in this module. -! By default, the surface flux of all tracers is zero. Nonzero values can be set in tracers_flux(). -! The local sinks/sources of tracers should be supplied in tracers_physics(). - - - - use crmx_grid - implicit none - - real tracer (dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm, 0:ntracers) - real fluxbtr (nx, ny, 0:ntracers) ! surface flux of tracers - real fluxttr (nx, ny, 0:ntracers) ! top boundary flux of tracers - real trwle(nz,0:ntracers) ! resolved vertical flux - real trwsb(nz,0:ntracers) ! SGS vertical flux - real tradv(nz,0:ntracers) ! tendency due to vertical advection - real trdiff(nz,0:ntracers) ! tendency due to vertical diffusion - real trphys(nz,0:ntracers) ! tendency due to physics - character *4 tracername(0:ntracers) - character *10 tracerunits(0:ntracers) - -CONTAINS - - subroutine tracers_init() - - integer k,ntr - character *2 ntrchar - integer, external :: lenstr - - tracer = 0. - fluxbtr = 0. - fluxttr = 0. - -! Add your initialization code here. Default is to set to 0 in setdata.f90. - - if(nrestart.eq.0) then - -! here .... - - end if - -! Specify te tracers' default names: - - ! Default names are TRACER01, TRACER02, etc: - - do ntr = 1,ntracers - write(ntrchar,'(i2)') ntr - do k=1,3-lenstr(ntrchar)-1 - ntrchar(k:k)='0' - end do - tracername(ntr) = 'TR'//ntrchar(1:2) - tracerunits(ntr) = '[TR]' - end do - - end subroutine tracers_init - - - - subroutine tracers_flux() - -! Set surface and top fluxes of tracers. Default is 0 set in setdata.f90 - - end subroutine tracers_flux - - - - subroutine tracers_physics() - - ! add here a call to a subroutine that does something to tracers besides advection and diffusion. - ! The transport is done automatically. - - trphys = 0. ! Default tendency due to physics. You code should compute this to output statistics. - - end subroutine tracers_physics - - - - subroutine tracers_hbuf_init(namelist,deflist,unitlist,status,average_type,count,trcount) - -! Initialize the list of tracers statistics variables written in statistics.f90 - - character(*) namelist(*), deflist(*), unitlist(*) - integer status(*),average_type(*),count,trcount - integer ntr - - - do ntr=1,ntracers - - count = count + 1 - trcount = trcount + 1 - namelist(count) = trim(tracername(ntr)) - deflist(count) = trim(tracername(ntr)) - unitlist(count) = trim(tracerunits(ntr)) - status(count) = 1 - average_type(count) = 0 - count = count + 1 - trcount = trcount + 1 - namelist(count) = trim(tracername(ntr))//'FLX' - deflist(count) = 'Total flux of '//trim(tracername(ntr)) - unitlist(count) = trim(tracerunits(ntr))//' kg/m2/s' - status(count) = 1 - average_type(count) = 0 - count = count + 1 - trcount = trcount + 1 - namelist(count) = trim(tracername(ntr))//'FLXS' - deflist(count) = 'SGS flux of '//trim(tracername(ntr)) - unitlist(count) = trim(tracerunits(ntr))//' kg/m2/s' - status(count) = 1 - average_type(count) = 0 - count = count + 1 - trcount = trcount + 1 - namelist(count) = trim(tracername(ntr))//'ADV' - deflist(count) = 'Tendency of '//trim(tracername(ntr)//'due to vertical advection') - unitlist(count) = trim(tracerunits(ntr))//'/day' - status(count) = 1 - average_type(count) = 0 - count = count + 1 - trcount = trcount + 1 - namelist(count) = trim(tracername(ntr))//'DIFF' - deflist(count) = 'Tendency of '//trim(tracername(ntr)//'due to vertical SGS transport') - unitlist(count) = trim(tracername(ntr))//'/day' - status(count) = 1 - average_type(count) = 0 - count = count + 1 - trcount = trcount + 1 - namelist(count) = trim(tracername(ntr))//'PHYS' - deflist(count) = 'Tendency of '//trim(tracername(ntr)//'due to physics') - unitlist(count) = trim(tracername(ntr))//'/day' - status(count) = 1 - average_type(count) = 0 - end do - - end subroutine tracers_hbuf_init - -end module crmx_crmtracers diff --git a/src/physics/spcam/crm/crmx_damping.F90 b/src/physics/spcam/crm/crmx_damping.F90 deleted file mode 100644 index 6d47ecbe4f..0000000000 --- a/src/physics/spcam/crm/crmx_damping.F90 +++ /dev/null @@ -1,68 +0,0 @@ - -subroutine damping - -! "Spange"-layer damping at the domain top region - -use crmx_vars -use crmx_microphysics, only: micro_field, index_water_vapor -implicit none - -real tau_min ! minimum damping time-scale (at the top) -real tau_max ! maxim damping time-scale (base of damping layer) -real damp_depth ! damping depth as a fraction of the domain height -parameter(tau_min=60., tau_max=450., damp_depth=0.4) -real tau(nzm) -integer i, j, k, n_damp - -if(tau_min.lt.2*dt) then - print*,'Error: in damping() tau_min is too small!' - call task_abort() -end if - -do k=nzm,1,-1 - if(z(nzm)-z(k).lt.damp_depth*z(nzm)) then - n_damp=nzm-k+1 - endif -end do - -do k=nzm,nzm-n_damp,-1 - tau(k) = tau_min *(tau_max/tau_min)**((z(nzm)-z(k))/(z(nzm)-z(nzm-n_damp))) - tau(k)=1./tau(k) -end do - -!+++mhwang recalculate grid-mean u0, v0, t0 first, -! as t have been updated. No need for qv0, as -! qv has not been updated yet the calculation of qv0. -do k=1, nzm - u0(k)=0.0 - v0(k)=0.0 - t0(k)=0.0 - do j=1, ny - do i=1, nx - u0(k) = u0(k) + u(i,j,k)/(nx*ny) - v0(k) = v0(k) + v(i,j,k)/(nx*ny) - t0(k) = t0(k) + t(i,j,k)/(nx*ny) - end do - end do -end do -!---mhwang - -do k = nzm, nzm-n_damp, -1 - do j=1,ny - do i=1,nx - dudt(i,j,k,na)= dudt(i,j,k,na)-(u(i,j,k)-u0(k)) * tau(k) - dvdt(i,j,k,na)= dvdt(i,j,k,na)-(v(i,j,k)-v0(k)) * tau(k) - dwdt(i,j,k,na)= dwdt(i,j,k,na)-w(i,j,k) * tau(k) - t(i,j,k)= t(i,j,k)-dtn*(t(i,j,k)-t0(k)) * tau(k) -! In the old version (SAM7.5?) of SAM, water vapor is the prognostic variable for the two-moment microphyscs. -! So the following damping approach can lead to the negative water vapor. -! micro_field(i,j,k,index_water_vapor)= micro_field(i,j,k,index_water_vapor)- & -! dtn*(qv(i,j,k)+qcl(i,j,k)+qci(i,j,k)-q0(k)) * tau(k) -! a simple fix (Minghuai Wang, 2011-08): - micro_field(i,j,k,index_water_vapor)= micro_field(i,j,k,index_water_vapor)- & - dtn*(qv(i,j,k)-qv0(k)) * tau(k) - end do! i - end do! j -end do ! k - -end subroutine damping diff --git a/src/physics/spcam/crm/crmx_diagnose.F90 b/src/physics/spcam/crm/crmx_diagnose.F90 deleted file mode 100644 index e169eb6aff..0000000000 --- a/src/physics/spcam/crm/crmx_diagnose.F90 +++ /dev/null @@ -1,197 +0,0 @@ -subroutine diagnose - -! Diagnose some useful stuff - -use crmx_vars -use crmx_params -use crmx_sgs, only: sgs_diagnose -implicit none - -integer i,j,k,kb,kc,k200,k500,k850 -real(kind=selected_real_kind(12)) coef, coef1, buffer(nzm,9), buffer1(nzm,8) -real omn, omp, tmp_lwp - -coef = 1./float(nx*ny) - - -k200 = nzm - -do k=1,nzm - u0(k)=0. - v0(k)=0. - t01(k) = tabs0(k) - q01(k) = q0(k) - t0(k)=0. - tabs0(k)=0. - q0(k)=0. - qn0(k)=0. - qp0(k)=0. - p0(k)=0. - kc=min(nzm,k+1) - kb=max(1,k-1) - if(pres(kc).le.200..and.pres(kb).gt.200.) k200=k - coef1 = rho(k)*dz*adz(k)*dtfactor - do j=1,ny - do i=1,nx - tabs(i,j,k) = t(i,j,k)-gamaz(k)+ fac_cond * (qcl(i,j,k)+qpl(i,j,k)) +& - fac_sub *(qci(i,j,k) + qpi(i,j,k)) - u0(k)=u0(k)+u(i,j,k) - v0(k)=v0(k)+v(i,j,k) - p0(k)=p0(k)+p(i,j,k) - t0(k)=t0(k)+t(i,j,k) - tabs0(k)=tabs0(k)+tabs(i,j,k) - q0(k)=q0(k)+qv(i,j,k)+qcl(i,j,k)+qci(i,j,k) - qn0(k) = qn0(k) + qcl(i,j,k) + qci(i,j,k) - qp0(k) = qp0(k) + qpl(i,j,k) + qpi(i,j,k) - - pw_xy(i,j) = pw_xy(i,j)+qv(i,j,k)*coef1 - cw_xy(i,j) = cw_xy(i,j)+qcl(i,j,k)*coef1 - iw_xy(i,j) = iw_xy(i,j)+qci(i,j,k)*coef1 - - end do - end do - u0(k)=u0(k)*coef - v0(k)=v0(k)*coef - t0(k)=t0(k)*coef - tabs0(k)=tabs0(k)*coef - q0(k)=q0(k)*coef - qn0(k)=qn0(k)*coef - qp0(k)=qp0(k)*coef - p0(k)=p0(k)*coef - -end do ! k - -k500 = nzm -do k = 1,nzm - kc=min(nzm,k+1) - if((pres(kc).le.500.).and.(pres(k).gt.500.)) then - if ((500.-pres(kc)).lt.(pres(k)-500.))then - k500=kc - else - k500=k - end if - end if -end do - - -do j=1,ny - do i=1,nx - usfc_xy(i,j) = usfc_xy(i,j) + u(i,j,1)*dtfactor - vsfc_xy(i,j) = vsfc_xy(i,j) + v(i,j,1)*dtfactor - u200_xy(i,j) = u200_xy(i,j) + u(i,j,k200)*dtfactor - v200_xy(i,j) = v200_xy(i,j) + v(i,j,k200)*dtfactor - w500_xy(i,j) = w500_xy(i,j) + w(i,j,k500)*dtfactor - end do -end do - -if(dompi) then - - coef1 = 1./float(nsubdomains) - do k=1,nzm - buffer(k,1) = u0(k) - buffer(k,2) = v0(k) - buffer(k,3) = t0(k) - buffer(k,4) = q0(k) - buffer(k,5) = p0(k) - buffer(k,6) = tabs0(k) - buffer(k,7) = qn0(k) - buffer(k,8) = qp0(k) - end do - call task_sum_real8(buffer,buffer1,nzm*8) - do k=1,nzm - u0(k)=buffer1(k,1)*coef1 - v0(k)=buffer1(k,2)*coef1 - t0(k)=buffer1(k,3)*coef1 - q0(k)=buffer1(k,4)*coef1 - p0(k)=buffer1(k,5)*coef1 - tabs0(k)=buffer1(k,6)*coef1 - qn0(k)=buffer1(k,7)*coef1 - qp0(k)=buffer1(k,8)*coef1 - end do - -end if ! dompi - -qv0 = q0 - qn0 - -!===================================================== -! UW ADDITIONS - -! FIND VERTICAL INDICES OF 850MB, COMPUTE SWVP -k850 = 1 -do k = 1,nzm - if(pres(k).le.850.) then - k850 = k - EXIT - end if -end do - -do k=1,nzm - coef1 = rho(k)*dz*adz(k)*dtfactor - do j=1,ny - do i=1,nx - - ! Saturated water vapor path with respect to water. Can be used - ! with water vapor path (= pw) to compute column-average - ! relative humidity. - swvp_xy(i,j) = swvp_xy(i,j)+qsatw_crm(tabs(i,j,k),pres(k))*coef1 - end do - end do -end do ! k - -! ACCUMULATE AVERAGES OF TWO-DIMENSIONAL STATISTICS -do j=1,ny - do i=1,nx - psfc_xy(i,j) = psfc_xy(i,j) + (100.*pres(1) + p(i,j,1))*dtfactor - - ! 850 mbar horizontal winds - u850_xy(i,j) = u850_xy(i,j) + u(i,j,k850)*dtfactor - v850_xy(i,j) = v850_xy(i,j) + v(i,j,k850)*dtfactor - - end do -end do - -! COMPUTE CLOUD/ECHO HEIGHTS AS WELL AS CLOUD TOP TEMPERATURE -! WHERE CLOUD TOP IS DEFINED AS THE HIGHEST MODEL LEVEL WITH A -! CONDENSATE PATH OF 0.01 kg/m2 ABOVE. ECHO TOP IS THE HIGHEST LEVEL -! WHERE THE PRECIPITATE MIXING RATIO > 0.001 G/KG. - -! initially, zero out heights and set cloudtoptemp to SST -cloudtopheight = 0. -cloudtoptemp = sstxy(1:nx,1:ny) -echotopheight = 0. -do j = 1,ny - do i = 1,nx - ! FIND CLOUD TOP HEIGHT - tmp_lwp = 0. - do k = nzm,1,-1 - tmp_lwp = tmp_lwp + (qcl(i,j,k)+qci(i,j,k))*rho(k)*dz*adz(k) - if (tmp_lwp.gt.0.01) then - cloudtopheight(i,j) = z(k) - cloudtoptemp(i,j) = tabs(i,j,k) - EXIT - end if - end do - ! FIND ECHO TOP HEIGHT - do k = nzm,1,-1 - if (qpl(i,j,k)+qpi(i,j,k).gt.1.e-6) then - echotopheight(i,j) = z(k) - EXIT - end if - end do - end do -end do - -! END UW ADDITIONS -!===================================================== - -!----------------- -! compute some sgs diagnostics: - -call sgs_diagnose() - -!----------------- - -! recompute pressure levels, except at restart (saved levels are used). -!if(dtfactor.ge.0.) call pressz() ! recompute pressure levels - -end subroutine diagnose diff --git a/src/physics/spcam/crm/crmx_domain.F90 b/src/physics/spcam/crm/crmx_domain.F90 deleted file mode 100644 index 4de3be44a6..0000000000 --- a/src/physics/spcam/crm/crmx_domain.F90 +++ /dev/null @@ -1,33 +0,0 @@ -! Set the domain dimensionality, size and number of subdomains. - -module crmx_domain - - use crmdims - implicit none - - integer, parameter :: YES3D = YES3DVAL ! Domain dimensionality: 1 - 3D, 0 - 2D - integer, parameter :: nx_gl = crm_nx ! Number of grid points in X - integer, parameter :: ny_gl = crm_ny ! Number of grid points in Y - integer, parameter :: nz_gl = crm_nz ! Number of pressure (scalar) levels - integer, parameter :: nsubdomains_x = 1 ! No of subdomains in x - integer, parameter :: nsubdomains_y = 1 ! No of subdomains in y - - - ! define # of points in x and y direction to average for - ! output relating to statistical moments. - ! For example, navgmom_x = 8 means the output will be an 8 times coarser grid than the original. - ! If don't wanna such output, just set them to -1 in both directions. - ! See Changes_log/README.UUmods for more details. - integer, parameter :: navgmom_x = -1 - integer, parameter :: navgmom_y = -1 - - integer, parameter :: ntracers = 0 ! number of transported tracers (dotracers=.true.) - -! Note: -! * nx_gl and ny_gl should be a factor of 2,3, or 5 (see User's Guide) -! * if 2D case, ny_gl = nsubdomains_y = 1 ; -! * nsubdomains_x*nsubdomains_y = total number of processors -! * if one processor is used, than nsubdomains_x = nsubdomains_y = 1; -! * if ntracers is > 0, don't forget to set dotracers to .true. in namelist - -end module crmx_domain diff --git a/src/physics/spcam/crm/crmx_ecppvars.F90 b/src/physics/spcam/crm/crmx_ecppvars.F90 deleted file mode 100644 index 8b45ed4897..0000000000 --- a/src/physics/spcam/crm/crmx_ecppvars.F90 +++ /dev/null @@ -1,52 +0,0 @@ -module crmx_ecppvars -#ifdef ECPP - implicit none - - public - - integer, public, parameter :: nupdraft_in = 1 ! Number of updraft class - integer, public, parameter :: ndndraft_in = 1 ! Number of dndraft class - integer, public, parameter :: ncls_ecpp_in = 3 ! Number of total number of ecpp transport class - ! = nupdraft_in+1+ndndraft_in - integer, public, parameter :: ncc_in = 2 ! number of clear/cloudy sub-calsses - integer, public, parameter :: nprcp_in = 2 ! Number of non-precipitating/precipitating sub-classes. - - integer, public, parameter :: QUI = 1, & !Quiescent class - UP1 = 2 !First index for upward classes - - integer, public :: DN1, & !First index of downward classes - NCLASS_TR !Num. of transport classes - !Both initialized based on - !runtime settings - - integer, public :: NCLASS_CL = ncc_in, & !Number of cloud classes - CLR = 1, & !Clear sub-class - CLD = 2 !Cloudy sub-class - - integer, public :: NCLASS_PR = nprcp_in, & !Number of precipitaion classes - PRN = 1, & !Not precipitating sub-class - PRY = 2 !Is precipitating sub-class - - - real,dimension(:,:,:), allocatable :: qlsink, precr, precsolid, rh, qlsink_bf, prain, qcloud_bf, qvs - - real,dimension(:,:,:),allocatable :: & - qcloudsum1, qcloud_bfsum1, qrainsum1, qicesum1, qsnowsum1, qgraupsum1, & - qlsinksum1, qlsink_bfsum1, prainsum1, precrsum1, precsolidsum1, precallsum1, & - altsum1, rhsum1, cf3dsum1, wwsum1, wwsqsum1, tkesgssum1, qvssum1 - -! dim1 = z - real,dimension(:),allocatable :: & - xkhvsum, wup_thresh, wdown_thresh, wwqui_cen_sum, wwqui_bnd_sum, wwqui_cloudy_cen_sum, wwqui_cloudy_bnd_sum - -! dims = (z, cloud sub-class, transport-class, precip sub-class) - real, dimension(:,:,:,:), allocatable :: & - area_bnd_final, area_bnd_sum, area_cen_final, area_cen_sum, & - mass_bnd_final, mass_bnd_sum, mass_cen_final, mass_cen_sum, & - ent_bnd_sum, rh_cen_sum, & - qcloud_cen_sum, qcloud_bf_cen_sum, qrain_cen_sum, & - qice_cen_sum, qsnow_cen_sum, qgraup_cen_sum, & - qlsink_cen_sum, precr_cen_sum, precsolid_cen_sum, precall_cen_sum, & - qlsink_bf_cen_sum, prain_cen_sum, qlsink_avg_cen_sum -#endif /*ECPP*/ -end module crmx_ecppvars diff --git a/src/physics/spcam/crm/crmx_forcing.F90 b/src/physics/spcam/crm/crmx_forcing.F90 deleted file mode 100644 index ebcca7e22f..0000000000 --- a/src/physics/spcam/crm/crmx_forcing.F90 +++ /dev/null @@ -1,48 +0,0 @@ - -subroutine forcing - - use crmx_vars - use crmx_params - use crmx_microphysics, only: micro_field, index_water_vapor, total_water - - implicit none - - real coef,qneg,qpoz, factor - integer i,j,k,nneg - - coef = 1./3600. - - do k=1,nzm - - qpoz = 0. - qneg = 0. - nneg = 0 - - do j=1,ny - do i=1,nx - t(i,j,k)=t(i,j,k) + ttend(k) * dtn - micro_field(i,j,k,index_water_vapor)=micro_field(i,j,k,index_water_vapor) + qtend(k) * dtn - if(micro_field(i,j,k,index_water_vapor).lt.0.) then - nneg = nneg + 1 - qneg = qneg + micro_field(i,j,k,index_water_vapor) - else - qpoz = qpoz + micro_field(i,j,k,index_water_vapor) - end if - dudt(i,j,k,na)=dudt(i,j,k,na) + utend(k) - dvdt(i,j,k,na)=dvdt(i,j,k,na) + vtend(k) - end do - end do - - if(nneg.gt.0.and.qpoz+qneg.gt.0.) then - factor = 1. + qneg/qpoz - do j=1,ny - do i=1,nx - micro_field(i,j,k,index_water_vapor) = max(0.,micro_field(i,j,k,index_water_vapor)*factor) - end do - end do - end if - - end do - -end - diff --git a/src/physics/spcam/crm/crmx_grid.F90 b/src/physics/spcam/crm/crmx_grid.F90 deleted file mode 100644 index ab8cad1d63..0000000000 --- a/src/physics/spcam/crm/crmx_grid.F90 +++ /dev/null @@ -1,167 +0,0 @@ -module crmx_grid - -use crmx_domain -use crmx_advection, only: NADV, NADVS - -implicit none - -character(6), parameter :: version = '6.10.4' -character(8), parameter :: version_date = 'Feb 2013' - -integer, parameter :: nx = nx_gl/nsubdomains_x -integer, parameter :: ny = ny_gl/nsubdomains_y -integer, parameter :: nz = nz_gl+1 -integer, parameter :: nzm = nz-1 - -integer, parameter :: nsubdomains = nsubdomains_x * nsubdomains_y - -logical, parameter :: RUN3D = ny_gl.gt.1 -logical, parameter :: RUN2D = .not.RUN3D - -integer, parameter :: nxp1 = nx + 1 -integer, parameter :: nyp1 = ny + 1 * YES3D -integer, parameter :: nxp2 = nx + 2 -integer, parameter :: nyp2 = ny + 2 * YES3D -integer, parameter :: nxp3 = nx + 3 -integer, parameter :: nyp3 = ny + 3 * YES3D -integer, parameter :: nxp4 = nx + 4 -integer, parameter :: nyp4 = ny + 4 * YES3D - -integer, parameter :: dimx1_u = -1 !!-1 -1 -1 -1 -integer, parameter :: dimx2_u = nxp3 !!nxp3 nxp3 nxp3 nxp3 -integer, parameter :: dimy1_u = 1-(2+NADV)*YES3D !!1-5*YES3D 1-4*YES3D 1-3*YES3D 1-2*YES3D -integer, parameter :: dimy2_u = nyp2+NADV !!nyp5 nyp4 nyp3 nyp2 -integer, parameter :: dimx1_v = -1-NADV !!-4 -3 -2 -1 -integer, parameter :: dimx2_v = nxp2+NADV !!nxp5 nxp4 nxp3 nxp2 -integer, parameter :: dimy1_v = 1-2*YES3D !!1-2*YES3D 1-2*YES3D 1-2*YES3D 1-2*YES3D -integer, parameter :: dimy2_v = nyp3 !!nyp3 nyp3 nyp3 nyp3 -integer, parameter :: dimx1_w = -1-NADV !!-4 -3 -2 -1 -integer, parameter :: dimx2_w = nxp2+NADV !!nxp5 nxp4 nxp3 nxp2 -integer, parameter :: dimy1_w = 1-(2+NADV)*YES3D !!1-5*YES3D 1-4*YES3D 1-3*YES3D 1-2*YES3D -integer, parameter :: dimy2_w = nyp2+NADV !!nyp5 nyp4 nyp3 nyp2 -integer, parameter :: dimx1_s = -2-NADVS !!-4 -3 -2 -2 -integer, parameter :: dimx2_s = nxp3+NADVS !!nxp5 nxp4 nxp3 nxp3 -integer, parameter :: dimy1_s = 1-(3+NADVS)*YES3D !!1-5*YES3D 1-4*YES3D 1-3*YES3D 1-3*YES3D -integer, parameter :: dimy2_s = nyp3+NADVS !!nyp5 nyp4 nyp3 nyp3 - -integer, parameter :: ncols = nx*ny -integer, parameter :: nadams = 3 - -! Vertical grid parameters: -real z(nz) ! height of the pressure levels above surface,m -real pres(nzm) ! pressure,mb at scalar levels -real zi(nz) ! height of the interface levels -real presi(nz) ! pressure,mb at interface levels -real adz(nzm) ! ratio of the thickness of scalar levels to dz -real adzw(nz) ! ratio of the thinckness of w levels to dz -real pres0 ! Reference surface pressure, Pa - -integer:: nstep =0! current number of performed time steps -integer ncycle ! number of subcycles over the dynamical timestep -integer icycle ! current subcycle -integer:: na=1, nb=2, nc=3 ! indeces for swapping the rhs arrays for AB scheme -real at, bt, ct ! coefficients for the Adams-Bashforth scheme -real dtn ! current dynamical timestep (can be smaller than dt) -real dt3(3) ! dynamical timesteps for three most recent time steps -real(kind=selected_real_kind(12)):: time=0. ! current time in sec. -real day ! current day (including fraction) -real dtfactor ! dtn/dt - -! MPI staff: -integer rank ! rank of the current subdomain task (default 0) -integer ranknn ! rank of the "northern" subdomain task -integer rankss ! rank of the "southern" subdomain task -integer rankee ! rank of the "eastern" subdomain task -integer rankww ! rank of the "western" subdomain task -integer rankne ! rank of the "north-eastern" subdomain task -integer ranknw ! rank of the "north-western" subdomain task -integer rankse ! rank of the "south-eastern" subdomain task -integer ranksw ! rank of the "south-western" subdomain task -logical dompi ! logical switch to do multitasking -logical masterproc ! .true. if rank.eq.0 - -character(80) case ! id-string to identify a case-name(set in CaseName file) - -logical dostatis ! flag to permit the gathering of statistics -logical dostatisrad ! flag to permit the gathering of radiation statistics -integer nstatis ! the interval between substeps to compute statistics - -logical :: compute_reffc = .false. -logical :: compute_reffi = .false. - -logical notopened2D ! flag to see if the 2D output datafile is opened -logical notopened3D ! flag to see if the 3D output datafile is opened -logical notopenedmom ! flag to see if the statistical moment file is opened - -!----------------------------------------- -! Parameters controled by namelist PARAMETERS - -real:: dx =0. ! grid spacing in x direction -real:: dy =0. ! grid spacing in y direction -real:: dz =0. ! constant grid spacing in z direction (when dz_constant=.true.) -logical:: doconstdz = .false. ! do constant vertical grid spacing set by dz - -integer:: nstop =0 ! time step number to stop the integration -integer:: nelapse =999999999! time step number to elapse before stoping - -real:: dt=0. ! dynamical timestep -real:: day0=0. ! starting day (including fraction) - -integer:: nrad =1 ! frequency of calling the radiation routines -integer:: nprint =1000 ! frequency of printing a listing (steps) -integer:: nrestart =0 ! switch to control starting/restarting of the model -integer:: nstat =1000 ! the interval in time steps to compute statistics -integer:: nstatfrq =50 ! frequency of computing statistics - -logical:: restart_sep =.false. ! write separate restart files for sub-domains -integer:: nrestart_skip =0 ! number of skips of writing restart (default 0) -logical:: output_sep =.false. ! write separate 3D and 2D files for sub-domains - -character(80):: caseid =''! id-string to identify a run -character(80):: caseid_restart =''! id-string for branch restart file -character(80):: case_restart =''! id-string for branch restart file - -logical:: doisccp = .false. -logical:: domodis = .false. -logical:: domisr = .false. -logical:: dosimfilesout = .false. - -logical:: doSAMconditionals = .false. !core updraft,downdraft conditional statistics -logical:: dosatupdnconditionals = .false.!cloudy updrafts,downdrafts and cloud-free -logical:: doscamiopdata = .false.! initialize the case from a SCAM IOP netcdf input file -logical:: dozero_out_day0 = .false. -character(len=120):: iopfile='' -character(256):: rundatadir ='./RUNDATA' ! path to data directory - -integer:: nsave3D =1000 ! frequency of writting 3D fields (steps) -integer:: nsave3Dstart =99999999! timestep to start writting 3D fields -integer:: nsave3Dend =99999999 ! timestep to end writting 3D fields -logical:: save3Dbin =.false. ! save 3D data in binary format(no 2-byte compression) -logical:: save3Dsep =.false. ! use separate file for each time point for2-model -real :: qnsave3D =0. !threshold manimum cloud water(kg/kg) to save 3D fields -logical:: dogzip3D =.false. ! gzip compress a 3D output file -logical:: rad3Dout = .false. ! output additional 3D radiation foelds (like reff) - -integer:: nsave2D =1000 ! frequency of writting 2D fields (steps) -integer:: nsave2Dstart =99999999! timestep to start writting 2D fields -integer:: nsave2Dend =99999999 ! timestep to end writting 2D fields -logical:: save2Dbin =.false. ! save 2D data in binary format, rather than compressed -logical:: save2Dsep =.false. ! write separate file for each time point for 2D output -logical:: save2Davg =.false. ! flag to time-average 2D output fields (default .false.) -logical:: dogzip2D =.false. ! gzip compress a 2D output file if save2Dsep=.true. - -integer:: nstatmom =1000! frequency of writting statistical moment fields (steps) -integer:: nstatmomstart =99999999! timestep to start writting statistical moment fields -integer:: nstatmomend =99999999 ! timestep to end writting statistical moment fields -logical:: savemomsep =.false.! use one file with stat moments for each time point -logical:: savemombin =.false.! save statistical moment data in binary format - -integer:: nmovie =1000! frequency of writting movie fields (steps) -integer:: nmoviestart =99999999! timestep to start writting statistical moment fields -integer:: nmovieend =99999999 ! timestep to end writting statistical moment fields - -logical :: isInitialized_scamiopdata = .false. -logical :: wgls_holds_omega = .false. - -!----------------------------------------- -end module crmx_grid diff --git a/src/physics/spcam/crm/crmx_ice_fall.F90 b/src/physics/spcam/crm/crmx_ice_fall.F90 deleted file mode 100644 index f16a90ea15..0000000000 --- a/src/physics/spcam/crm/crmx_ice_fall.F90 +++ /dev/null @@ -1,124 +0,0 @@ - -subroutine ice_fall() - - -! Sedimentation of ice: - -use crmx_vars -use crmx_microphysics, only: micro_field, index_cloud_ice -!use micro_params -use crmx_params - -implicit none - -integer i,j,k, kb, kc, kmax, kmin, ici -real coef,dqi,lat_heat,vt_ice -real omnu, omnc, omnd, qiu, qic, qid, tmp_theta, tmp_phi -real fz(nx,ny,nz) - -kmax=0 -kmin=nzm+1 - -do k = 1,nzm - do j = 1, ny - do i = 1, nx - if(qcl(i,j,k)+qci(i,j,k).gt.0..and. tabs(i,j,k).lt.273.15) then - kmin = min(kmin,k) - kmax = max(kmax,k) - end if - end do - end do -end do - -do k = 1,nzm - qifall(k) = 0. - tlatqi(k) = 0. -end do - -if(index_cloud_ice.eq.-1) return - -!call t_startf ('ice_fall') - -fz = 0. - -! Compute cloud ice flux (using flux limited advection scheme, as in -! chapter 6 of Finite Volume Methods for Hyperbolic Problems by R.J. -! LeVeque, Cambridge University Press, 2002). -do k = max(1,kmin-1),kmax - ! Set up indices for x-y planes above and below current plane. - kc = min(nzm,k+1) - kb = max(1,k-1) - ! CFL number based on grid spacing interpolated to interface i,j,k-1/2 - coef = dtn/(0.5*(adz(kb)+adz(k))*dz) - do j = 1,ny - do i = 1,nx - ! Compute cloud ice density in this cell and the ones above/below. - ! Since cloud ice is falling, the above cell is u (upwind), - ! this cell is c (center) and the one below is d (downwind). - - qiu = rho(kc)*qci(i,j,kc) - qic = rho(k) *qci(i,j,k) - qid = rho(kb)*qci(i,j,kb) - - ! Ice sedimentation velocity depends on ice content. The fiting is - ! based on the data by Heymsfield (JAS,2003). -Marat - vt_ice = min(0.4,8.66*(max(0.,qic)+1.e-10)**0.24) ! Heymsfield (JAS, 2003, p.2607) - - ! Use MC flux limiter in computation of flux correction. - ! (MC = monotonized centered difference). -! if (qic.eq.qid) then - if (abs(qic-qid).lt.1.0e-25) then ! when qic, and qid is very small, qic_qid can still be zero - ! even if qic is not equal to qid. so add a fix here +++mhwang - tmp_phi = 0. - else - tmp_theta = (qiu-qic)/(qic-qid) - tmp_phi = max(0.,min(0.5*(1.+tmp_theta),2.,2.*tmp_theta)) - end if - - ! Compute limited flux. - ! Since falling cloud ice is a 1D advection problem, this - ! flux-limited advection scheme is monotonic. - fz(i,j,k) = -vt_ice*(qic - 0.5*(1.-coef*vt_ice)*tmp_phi*(qic-qid)) - end do - end do -end do -fz(:,:,nz) = 0. - -ici = index_cloud_ice - -do k=max(1,kmin-2),kmax - coef=dtn/(dz*adz(k)*rho(k)) - do j=1,ny - do i=1,nx - ! The cloud ice increment is the difference of the fluxes. - dqi=coef*(fz(i,j,k)-fz(i,j,k+1)) - ! Add this increment to both non-precipitating and total water. - micro_field(i,j,k,ici) = micro_field(i,j,k,ici) + dqi - ! Include this effect in the total moisture budget. - qifall(k) = qifall(k) + dqi - - ! The latent heat flux induced by the falling cloud ice enters - ! the liquid-ice static energy budget in the same way as the - ! precipitation. Note: use latent heat of sublimation. - lat_heat = (fac_cond+fac_fus)*dqi - ! Add divergence of latent heat flux to liquid-ice static energy. - t(i,j,k) = t(i,j,k) - lat_heat - ! Add divergence to liquid-ice static energy budget. - tlatqi(k) = tlatqi(k) - lat_heat - end do - end do -end do - -coef=dtn/dz -do j=1,ny - do i=1,nx - dqi=-coef*fz(i,j,1) - precsfc(i,j) = precsfc(i,j)+dqi - precssfc(i,j) = precssfc(i,j)+dqi - end do -end do - -!call t_stopf ('ice_fall') - -end subroutine ice_fall - diff --git a/src/physics/spcam/crm/crmx_kurant.F90 b/src/physics/spcam/crm/crmx_kurant.F90 deleted file mode 100644 index 502843bff8..0000000000 --- a/src/physics/spcam/crm/crmx_kurant.F90 +++ /dev/null @@ -1,56 +0,0 @@ - -subroutine kurant - -use crmx_vars -use crmx_sgs, only: kurant_sgs - -implicit none - -integer i, j, k, ncycle1(1),ncycle2(1) -real wm(nz) ! maximum vertical wind velocity -real uhm(nz) ! maximum horizontal wind velocity -real cfl, cfl_sgs - -ncycle = 1 - -wm(nz)=0. -w_max =0. -u_max =0. -do k = 1,nzm - wm(k) = maxval(abs(w(1:nx,1:ny,k))) - uhm(k) = sqrt(maxval(u(1:nx,1:ny,k)**2+YES3D*v(1:nx,1:ny,k)**2)) -end do -w_max=max(w_max,maxval(w(1:nx,1:ny,1:nz))) -u_max=max(u_max,maxval(uhm(1:nzm))) - -cfl = 0. -do k=1,nzm - cfl = max(cfl,uhm(k)*dt*sqrt((1./dx)**2+YES3D*(1./dy)**2), & - max(wm(k),wm(k+1))*dt/(dz*adzw(k)) ) -end do - -call kurant_sgs(cfl_sgs) -cfl = max(cfl,cfl_sgs) - -ncycle = max(1,ceiling(cfl/0.7)) - -if(dompi) then - ncycle1(1)=ncycle - call task_max_integer(ncycle1,ncycle2,1) - ncycle=ncycle2(1) -end if -if(ncycle.gt.4) then - if(masterproc) print *,'the number of cycles exceeded 4.' -!+++ test +++mhwang - write(0, *) 'cfl', cfl, cfl_sgs, latitude(1, 1), longitude(1,1) - do k=1, nzm - write(0, *) 'k=', k, wm(k), uhm(k) - end do - do i=1, nx - write(0, *) 'i=', i, u(i, 1, 4), v(i, 1, 4), tabs(i,1,4) - end do -!---mhwang - call task_abort() -end if - -end subroutine kurant diff --git a/src/physics/spcam/crm/crmx_module_ecpp_crm_driver.F90 b/src/physics/spcam/crm/crmx_module_ecpp_crm_driver.F90 deleted file mode 100644 index bc1504872b..0000000000 --- a/src/physics/spcam/crm/crmx_module_ecpp_crm_driver.F90 +++ /dev/null @@ -1,773 +0,0 @@ -module crmx_module_ecpp_crm_driver -#ifdef ECPP -!------------------------------------------------------------------------ -! F90 module to prepare CRM output for ECPP module in the MMF model. -! -! This code was written originally by William Gustafson, and is adopted into -! the MMF model by Minghuai Wang (minghuai.wang@pnl.gov), November, 2009. -! -! Assumptiont built into this code: -! -! Open issues: -! - The mask for determining a "moving" or limited spatial average -! is not implemented. -! - The dependencies in Makefile don't work. If a compile fails, -! try "make clean; make" instead to clear out the module files. -! - For uv_in/out, a simple time average is being done and one can -! argue that it should be a weighted average since the number of in -! and out points changes with each time step. The affect is probably -! small for short time averages though. -! - When calculating the standard deviation of vertical velocity, -! each cell is treated equally and the std. dev. is over the 3 dims -! below the cloud tops. We may want to consider weighting each cell -! by either its volume or mass. -! - To get cloud values at vertical cell interface, a simple average -! is being done when an interpolation should technically be done. -! This only affects quiescent cloudy/clear categories. -! - Ditto for getting the density at the vertical cell interface (rho8w). -! -! Differences between the methodology here and in Ferret: -! - When calculating wup_bar and wdown_bar, points with w==0 are ignored -! here and were included in wup in Ferret. -! - Clear fluxes are no longer chopped off at the cloud top. -! - When calculating the std. dev. in and below the cloud, the level -! just above the cloud top is now included so we include w out the -! cloud top. -! - When determining "cloudyother" in Ferret the cloud above the -! interface was used. Now, the average of the cloud above and below -! is used. -! -! William.Gustafson@pnl.gov; 20-Jul-2006 -! v2.0 - Added two-level time averaging, one for the stats and a longer -! period for output. -! v2.1 - 25-Jul-2006; Fixed sign bug with uv_in/out. -! -! v3.0 - aug-sep-2006 - many changes by r.easter and s.ghan -! major change is option for multiple up and downdraft classes -! -! v3.1 - 02-nov-2006 r.easter - replaced uv_in/outsum with u_in/outsum -! & v_in/outsum -! -! v4.0 - 25-Jan-2007, wig; -! - Added areaavgtype switch to output final areas either as -! instantaneous, averaged over the last ntavg1 period of each -! ntavg2 avg, or as averaged over ntavg2. -! - Output areas as average over ntavg2 and also just at end -! of it. -! - Added entrainment averages to output (do not divide by dz). -! -! postproc_wrfout_bb.f90 from postproc_wrfout.f90 - 15-nov-2007, rce; -! - do multiple processings -! -! v5.0 - Nov-2008, wig -! - Major rewrite to include combinations of cloud, precipitation, -! and transport classes -! - Output format changes to multi-dimensional variables based -! on the classes instead of outputting each class separately -! -! 14-Apr-2009, wig: Fixed bug with mode_updnthresh at model top for -! bad calculation of w thresholds. -! -! 16-Apr-2009, wig: Added qcloud weighting to qlsink averages -! -!---------------------------------------------------------------------------------------- - use crmx_ecppvars - use crmx_ecppvars, only: QUI, UP1, DN1, NCLASS_TR, NCLASS_CL, CLR, CLD, NCLASS_PR, PRN, PRY - use cam_abortutils, only: endrun - - public ecpp_crm_stat - public ecpp_crm_init - public ecpp_crm_cleanup - - integer, public :: ntavg1_ss, ntavg2_ss - - private - save - - integer :: nxstag, nystag, nzstag - integer :: itavg1, itavg2, & - ntavg1, ntavg2 - - integer :: mode_updnthresh - integer :: areaavgtype - ! Methodology to compute final area averages: - ! 0 = area categories based on instantaneous - ! values at last time step of ntavg2 - ! 1 = area cat. based on last ntavg1 avgeraging - ! period of each ntavg2 period - ! 2 = area cat. based on average of full ntavg2 - ! period - integer :: plumetype - ! 1 = single plume - ! 2 = two plumes, core and weak - ! 3 = multi-plume, number based on setting of - ! allcomb - logical :: allcomb - ! true if updrafts and downdrafts have all - ! combinations of bases and tops. - real :: cloudthresh, & - prcpthresh, & - downthresh, downthresh2, & - upthresh, upthresh2 - - real :: cloudthresh_trans, & ! the threshold total cloud water for updraft or downdraft - precthresh_trans ! the threshold total rain, snow and graupel for clear, updraft or downdraft - - integer, dimension(:),allocatable :: & - updraftbase, updrafttop, dndrafttop, dndraftbase - integer :: nupdraft, ndndraft - integer :: ndraft_max, nupdraft_max, ndndraft_max - -contains - -!======================================================================================== -subroutine ecpp_crm_init() - - use crmx_grid, only: nx, ny, nzm, dt - use crmx_module_ecpp_stats, only: zero_out_sums1, zero_out_sums2 - use module_ecpp_ppdriver2, only: nupdraft_in, ndndraft_in, ncls_ecpp_in - implicit none - - integer :: kbase, ktop - integer :: m - integer :: nup, ndn - character(len=100) :: msg - - nxstag = nx+1 - nystag = ny+1 - nzstag = nzm+1 - -! ntavg1_ss and ntavg1_ss are defined in crm.F90 in the MMF model. -! ntavg1_ss = dt_gl ! GCM time step -! ntavg1_ss = number of seconds to average between computing categories. -! ntavg2_ss = dt_gl ! GCM time step -! ntavg2_ss = number of seconds to average between outputs. -! This must be a multiple of ntavgt1_ss. - - mode_updnthresh = 16 -! 1 = method originally implemented by Bill G -! wup_thresh = wup_stddev*abs(upthresh) -! wdown_thresh = -wdown_stddev*abs(downthresh) -! 2 = similar to 1, but include the mean wup and wdown -! wup_thresh = wup_bar + wup_stddev*abs(upthresh) -! wdown_thresh = wdown_bar - wdown_stddev*abs(downthresh) -! 3 = user specifies an absolute threshold -! wup_thresh = abs(upthresh) -! wdown_thresh = -abs(downthresh) -! 4 = similar to 1, but do -! wup_thresh = wup_rms*abs(upthresh) -! wdown_thresh = -wdown_rms*abs(downthresh) -! -! 5 = see description in module_ecpp_stats.f90 -! 6, 7 = see descriptions in module_ecpp_stats.f90 -! 8, 9 = see descriptions in module_ecpp_stats.f90 -! 10, 11 = see descriptions in module_ecpp_stats.f90 -! 12, 13 = see descriptions in module_ecpp_stats.f90 - - upthresh = 1. !Multiples of std. dev. to classify as updraft - downthresh = 1. !Multiples of std. dev. to classify as downdraft - upthresh2 = 0.5 ! ...ditto, except for weaker 2nd draft type when plumetype=2 - downthresh2 = 0.5 - -#ifdef CLUBB_CRM - cloudthresh = 2e-7 !Cloud mixing ratio beyond which cell is "cloudy(liquid)" (kg/kg) - ! As now fractional cloudiness is used for classifying cloudy vs. clear, - ! reduce it from 1.0e-6 to 2.0e-7 -#else - cloudthresh = 1e-6 !Cloud mixing ratio beyond which cell is "cloudy(liquid)" (kg/kg) -#endif - - prcpthresh = 1e-6 !Preciptation rate (precr) beyond which cell is raining (kg/m2/s) - ! this is used to classify precipitating vs. nonprecipitating class for wet scavenging. - -!+++mhwang -! high thresholds are used to classify transport classes (following Xu et al., 2002, Q.J.R.M.S. -! - cloudthresh_trans = 1e-5 !Cloud mixing ratio beyond which cell is "cloudy" to classify transport classes (kg/kg) +++mhwang - ! the maxium of cloudthres_trans and 0.01*qvs is used to classify transport class - precthresh_trans = 1e-4 !Preciptation mixing ratio beyond which cell is raining to classify transport classes (kg/kg) !+++mwhang -!---mhwang - - areaavgtype= 1 !final area avg over 0=instantaneous, 1=ntavg1, 2=ntavg2 - plumetype = 1 !1 for single plume, 2 for core and weak plumes, 3 for multiple plumes - allcomb = .false. !true for all combinations of plume bases and tops, false for 1 plume per base - -!---------------------------------------------------------------------------------- -! Sanity check... -!---------------------------------------------------------------------------------- - - if(plumetype>3)then - msg = 'ecpp_crm, plumetype must be <=3' - call endrun(trim(msg)) - endif - - if(plumetype<3 .and. allcomb)then - msg='ecpp_crm, allcomb=true requires plumetype=3' - call endrun(trim(msg)) - endif - - if(areaavgtype>2)then - msg='ecpp_crm, areaavgtype must be <=2' - call endrun(trim(msg)) - endif - - if ((mode_updnthresh < 1) .or. (mode_updnthresh > 17)) then - msg='ecpp_crm, error - must have 1 <= mode_updnthresh <= 17' - call endrun(trim(msg)) - endif - - if( abs(upthresh2) > 0.90*abs(upthresh) ) then - msg='ecpp_crm, error - upthresh2 must be < 0.90*upthresh' - call endrun(trim(msg)) - end if - - if( abs(downthresh2) > 0.90*abs(downthresh) ) then - msg='ecpp_crm, error - downthresh2 must be < 0.90*downthresh' - call endrun(trim(msg)) - end if - -! determine number of updrafts and downdrafts -! -! updraft kbase & ktop definition: -! ww(i,j,k ) > wup_thresh for k=kbase+1:ktop -! <= wup_thresh at k=kbase and k=ktop+1 -! they identify the "T-points" which enclose the updraft "W-points" -! and are affected by the subgrid transport of this updraft -! -! downdraft kbase & ktop definition: -! ww(i,j,k ) < wdown_thresh for k=kbase+1:ktop -! >= wdown_thresh at k=kbase and k=ktop+1 -! they identify the "T-points" which enclose the downdraft "W-points" -! and are affected by the subgrid transport of this downdraft -! -! for both updrafts and downdrafts, -! 1 <= kbase < ktop < nzstag - - nupdraft = 0 - ndndraft = 0 - nupdraft_max = 0 - ndndraft_max = 0 - - select case (plumetype) - case (1) !single plume - nupdraft = 1 - ndndraft = 1 - case (2) !core and weak plumes - nupdraft = 2 - ndndraft = 2 - case (3) - do kbase=1,nzm-1 - if(allcomb)then ! all possible tops - nupdraft=nupdraft+nzm-kbase - else ! one top per base - nupdraft=nupdraft+1 - endif - enddo - do ktop=nzm,2,-1 - if(allcomb)then ! all possible bases - ndndraft=ndndraft+ktop-1 - else ! one base per top - ndndraft=ndndraft+1 - endif - enddo - end select - - nupdraft_max = max( nupdraft_max, nupdraft ) - ndndraft_max = max( ndndraft_max, ndndraft ) - - DN1 = nupdraft + 2 !Setup index of first downdraft class - NCLASS_TR = nupdraft + ndndraft + 1 - - ndraft_max = 1 + nupdraft_max + ndndraft_max - - if(NCLASS_TR.ne.ncls_ecpp_in) then - call endrun('NCLASS_TR should be equal to ncls_ecpp_in') - end if - if((nupdraft.ne.nupdraft_in) .or. (ndndraft.ne.ndndraft_in)) then - call endrun('nupdraft or ndndraft is not set correctly') - end if - - allocate (updraftbase(nupdraft_max), & - updrafttop( nupdraft_max) ) - allocate (dndraftbase(ndndraft_max), & - dndrafttop( ndndraft_max) ) - - select case (plumetype) - case (1) !single plume - updraftbase(1)=1 - updrafttop( 1)=nzm - dndrafttop( 1)=nzm - dndraftbase(1)=1 - case (2) - updraftbase(1:2)=1 - updrafttop( 1:2)=nzm - dndrafttop( 1:2)=nzm - dndraftbase(1:2)=1 - case (3) - m=0 - do kbase=1,nzm-1 - if(allcomb)then ! loop over all possible tops. - do ktop=kbase+1,nzm - m=m+1 - updraftbase(m)=kbase - updrafttop( m)=ktop - enddo - else ! only one top per base - m=m+1 - updraftbase(m)=kbase - updrafttop( m)=nzm - endif - enddo - - m=0 - do ktop=nzm,2,-1 - if(allcomb)then ! loop over all possible bases. - do kbase=ktop-1,1,-1 - m=m+1 - dndrafttop( m)=ktop - dndraftbase(m)=kbase - enddo - else ! only one base per top - m=m+1 - dndrafttop( m)=ktop - dndraftbase(m)=1 - endif - enddo - end select - -!--------------------------------------------------------------------------- -! Allocate arrays -!--------------------------------------------------------------------------- - allocate( qlsink(nx,ny,nzm), precr(nx,ny,nzm), precsolid(nx,ny,nzm), rh(nx, ny, nzm), qvs(nx, ny, nzm)) - - allocate( qlsink_bf(nx, ny, nzm), prain(nx, ny, nzm), qcloud_bf(nx, ny, nzm)) - - allocate( qcloudsum1(nx,ny,nzm), qcloud_bfsum1(nx,ny,nzm), qrainsum1(nx,ny,nzm), & - qicesum1(nx,ny,nzm), qsnowsum1(nx,ny,nzm), qgraupsum1(nx,ny,nzm), & - qlsinksum1(nx,ny,nzm), precrsum1(nx,ny,nzm), & - precsolidsum1(nx,ny,nzm), precallsum1(nx,ny,nzm), & - altsum1(nx,ny,nzm), rhsum1(nx,ny,nzm), cf3dsum1(nx,ny,nzm), & - wwsum1(nx,ny,nzstag), wwsqsum1(nx,ny,nzstag), & - tkesgssum1(nx, ny, nzm), qlsink_bfsum1(nx, ny, nzm), prainsum1(nx, ny, nzm), qvssum1(nx, ny, nzm) ) - - allocate( & - xkhvsum(nzm) ) - - allocate( wwqui_cen_sum(nzm), wwqui_bnd_sum(nzm+1), & - wwqui_cloudy_cen_sum(nzm), wwqui_cloudy_bnd_sum(nzm+1)) - - allocate( wup_thresh(nzm+1), wdown_thresh(nzm+1)) - - allocate( area_bnd_final( nzstag,NCLASS_CL,ndraft_max,NCLASS_PR), & - area_bnd_sum( nzstag,NCLASS_CL,ndraft_max,NCLASS_PR), & - area_cen_final( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - area_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - mass_bnd_final( nzstag,NCLASS_CL,ndraft_max,NCLASS_PR), & - mass_bnd_sum( nzstag,NCLASS_CL,ndraft_max,NCLASS_PR), & - mass_cen_final( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - mass_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - ent_bnd_sum( nzstag,NCLASS_CL,ndraft_max,NCLASS_PR), & - rh_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - qcloud_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - qcloud_bf_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - qrain_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - qice_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - qsnow_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - qgraup_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - qlsink_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - precr_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - precsolid_cen_sum(nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - precall_cen_sum(nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - qlsink_bf_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - qlsink_avg_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR), & - prain_cen_sum( nzm ,NCLASS_CL,ndraft_max,NCLASS_PR) ) - -! Initialize the running sums. - call zero_out_sums1( qcloudsum1(:,:,:), qcloud_bfsum1(:,:,:), qrainsum1(:,:,:), & - qicesum1(:,:,:), qsnowsum1(:,:,:), qgraupsum1(:,:,:), & - qlsinksum1(:,:,:), precrsum1(:,:,:), & - precsolidsum1(:,:,:), precallsum1(:,:,:), & - altsum1(:,:,:), rhsum1(:,:,:), cf3dsum1(:,:,:), & - wwsum1(:,:,:), wwsqsum1(:,:,:), tkesgssum1(:,:,:), & - qlsink_bfsum1(:,:,:), prainsum1(:,:,:), qvssum1(:,:,:) ) - ndn = ndndraft ; nup = nupdraft - call zero_out_sums2( & - xkhvsum(:), & - wwqui_cen_sum(:), wwqui_bnd_sum(:), wwqui_cloudy_cen_sum(:), wwqui_cloudy_bnd_sum(:), & - area_bnd_final(:,:,1:1+nup+ndn,:), area_bnd_sum(:,:,1:1+nup+ndn,:), & - area_cen_final(:,:,1:1+nup+ndn,:), area_cen_sum(:,:,1:1+nup+ndn,:), & - mass_bnd_final(:,:,1:1+nup+ndn,:), mass_bnd_sum(:,:,1:1+nup+ndn,:), & - mass_cen_final(:,:,1:1+nup+ndn,:), mass_cen_sum(:,:,1:1+nup+ndn,:), & - ent_bnd_sum(:,:,1:1+nup+ndn,:), & - rh_cen_sum(:,:,1:1+nup+ndn,:), & - qcloud_cen_sum(:,:,1:1+nup+ndn,:), qcloud_bf_cen_sum(:,:,1:1+nup+ndn,:), qrain_cen_sum(:,:,1:1+nup+ndn,:), & - qice_cen_sum(:,:,1:1+nup+ndn,:), qsnow_cen_sum(:,:,1:1+nup+ndn,:), & - qgraup_cen_sum(:,:,1:1+nup+ndn,:), & - qlsink_cen_sum(:,:,1:1+nup+ndn,:), precr_cen_sum(:,:,1:1+nup+ndn,:), & - precsolid_cen_sum(:,:,1:1+nup+ndn,:), precall_cen_sum(:,:,1:1+nup+ndn,:), & - qlsink_bf_cen_sum(:,:,1:1+nup+ndn,:), qlsink_avg_cen_sum(:,:,1:1+nup+ndn,:), & - prain_cen_sum(:,:,1:1+nup+ndn,:) ) - - wup_thresh(:) = 0.0 - wdown_thresh(:) = 0.0 - - ntavg1 = ntavg1_ss / dt - ntavg2 = ntavg2_ss / dt - itavg1 = 0 - itavg2 = 0 - -end subroutine ecpp_crm_init -!--------------------------------------------------------------------------------------- - -!======================================================================================= -subroutine ecpp_crm_cleanup () - -! deallocate variables - deallocate (updraftbase, & - updrafttop ) - deallocate (dndraftbase, & - dndrafttop ) - - deallocate( qlsink, precr, precsolid, rh, qvs) - - deallocate( qlsink_bf, prain, qcloud_bf) - - deallocate( qcloudsum1, qcloud_bfsum1, qrainsum1, & - qicesum1, qsnowsum1, qgraupsum1, & - qlsinksum1, precrsum1, & - precsolidsum1, precallsum1, & - altsum1, rhsum1, cf3dsum1, & - wwsum1, wwsqsum1, tkesgssum1, & - qlsink_bfsum1, prainsum1, qvssum1 ) - - deallocate( & - xkhvsum, wup_thresh, wdown_thresh ) - - deallocate(wwqui_cen_sum, wwqui_bnd_sum, wwqui_cloudy_cen_sum, wwqui_cloudy_bnd_sum) - - deallocate( area_bnd_final, & - area_bnd_sum, & - area_cen_final, & - area_cen_sum, & - mass_bnd_final, & - mass_bnd_sum, & - mass_cen_final, & - mass_cen_sum, & - ent_bnd_sum, & - rh_cen_sum, & - qcloud_cen_sum, & - qcloud_bf_cen_sum, & - qrain_cen_sum, & - qice_cen_sum, & - qsnow_cen_sum, & - qgraup_cen_sum, & - qlsink_cen_sum, & - precr_cen_sum, & - precsolid_cen_sum, & - precall_cen_sum, & - qlsink_bf_cen_sum, & - qlsink_avg_cen_sum, & - prain_cen_sum ) - -end subroutine ecpp_crm_cleanup -!--------------------------------------------------------------------------------------- - -!======================================================================================== -subroutine ecpp_crm_stat() - - use crmx_module_ecpp_stats - use module_data_ecpp1, only: afrac_cut - use crmx_grid, only: nx, ny, nzm, pres - use crmx_vars, only: w, tabs, p, CF3D - use crmx_sgs, only: tke, tk - use crmx_microphysics, only: micro_field, iqv, iqci, iqr, iqs, iqg, cloudliq - use crmx_module_mp_GRAUPEL, only: POLYSVP -#ifdef CLUBB_CRM - use crmx_clubbvars, only: wp2 - use crmx_sgs, only: tk_clubb -#endif - implicit none - - integer :: i, ierr, i_tidx, j, & - ncnt1, ncnt2 - - integer :: nup, ndn - integer :: kbase, ktop, m - integer :: ii, jj, kk - integer :: icl, icls, ipr - - real,dimension(nx, ny, nzm) :: & - qcloud, qrain, qice, qsnow, qgraup, & - precall, alt, xkhv - real, dimension(nx, ny, nzstag) :: ww, wwsq - - real :: EVS - -!------------------------------------------------------------------------ -! Main code section... -!------------------------------------------------------------------------ - - ndn = ndndraft ; nup = nupdraft - - itavg1 = itavg1 + 1 - itavg2 = itavg2 + 1 - ndn = ndndraft ; nup = nupdraft - -! Get values from SAM cloud fields - qcloud(1:nx,1:ny,1:nzm) = cloudliq(1:nx,1:ny,1:nzm) - qrain(1:nx,1:ny,1:nzm) = micro_field(1:nx,1:ny,1:nzm,iqr) - qice(1:nx,1:ny,1:nzm) = micro_field(1:nx,1:ny,1:nzm,iqci) - qsnow(1:nx,1:ny,1:nzm) = micro_field(1:nx,1:ny,1:nzm,iqs) - qgraup(1:nx,1:ny,1:nzm) = micro_field(1:nx,1:ny,1:nzm,iqg) - - precall(:,:,:)= precr(:,:,:) + precsolid(:,:,:) - - do ii=1, nx - do jj=1, ny - do kk=1, nzm - EVS = POLYSVP(tabs(ii,jj,kk),0) ! saturation water vapor pressure (PA) - qvs(ii,jj,kk) = .622*EVS/(pres(kk)*100.-EVS) ! pres(kk) with unit of hPa -! rh(ii,jj,kk) = micro_field(ii,jj,kk,iqv)/QVS ! unit 0-1 -! rh(ii,jj,kk) = min(1.0, rh(ii,jj,kk)) ! RH is diagnosed in microphysics - alt(ii,jj,kk) = 287.*tabs(ii,jj,kk)/(100.*pres(kk)) - - end do - end do - end do - - ww(:,:,:) = w(1:nx,1:ny,1:nzstag) -#ifdef CLUBB_CRM - wwsq(:,:,:) = sqrt(wp2(1:nx, 1:ny, 1:nzstag)) -#else - wwsq(:,:,:) = 0. ! subgrid vertical velocity is not used in the current version of ECPP. -#endif - -#ifdef CLUBB_CRM - xkhv(:,:,:) = tk_clubb(1:nx,1:ny,1:nzm) ! eddy viscosity m2/s -#else - xkhv(:,:,:) = tk(1:nx,1:ny,1:nzm) ! eddy viscosity m2/s -#endif - -!+++mhwangtest -! do ii=1, nx -! do jj=1, ny -! do kk=1, nzm -! if(prain(ii,jj,kk).gt.1.0e-15) then -! if(qcloud_bf(ii,jj,kk)*qlsink_bf(ii,jj,kk)/prain(ii,jj,kk) .lt. 0.90) then -! write(0, *) 'qcloud_bf*qlsink_bf/prain, qlsink_bf, qlsink, qlcoud_bf, qcloud, prain', qcloud_bf(ii,jj,kk)*qlsink_bf(ii,jj,kk)/prain(ii,jj,kk), & -! qlsink_bf(ii, jj, kk) * 86400, qlsink(ii, jj, kk)*86400, qcloud_bf(ii, jj, kk), qcloud(ii, jj, kk), prain(ii, jj, kk) -! end if -! end if -! end do -! end do -! end do -!---mhwangest - - -! Increment the 3-D running sums for averaging period 1. - call rsums1( qcloud, qcloudsum1(:,:,:), & - qcloud_bf, qcloud_bfsum1(:,:,:), & - qrain, qrainsum1(:,:,:), & - qice, qicesum1(:,:,:), & - qsnow, qsnowsum1(:,:,:), & - qgraup, qgraupsum1(:,:,:), & - qlsink, qlsinksum1(:,:,:), & - precr, precrsum1(:,:,:), & - precsolid, precsolidsum1(:,:,:), & - precall, precallsum1(:,:,:), & - alt, altsum1(:,:,:), & - rh, rhsum1(:,:,:), & - CF3D, cf3dsum1(:,:,:), & - ww, wwsum1(:,:,:), & - wwsq, wwsqsum1(:,:,:), & - tke(1:nx,1:ny,1:nzm), tkesgssum1(:,:,:), & - qlsink_bf, qlsink_bfsum1(:,:,:), & - prain, prainsum1(:,:,:), & - qvs, qvssum1(:,:,:) ) - -! Increment the running sums for the level two variables that are not -! already incremented. Consolidate from 3-D to 1-D columns. - call rsums2( & - nx, ny, nzm, & - xkhv, xkhvsum(:) ) - -! Check if we have reached the end of the level 1 time averaging period. - if( mod(itavg1,ntavg1) == 0 ) then - -! Turn the running sums into averages. - if( itavg1 /= 0 ) then - ncnt1 = ntavg1 - else - ncnt1 = 1 - end if - call rsums1ToAvg( ncnt1, qcloudsum1(:,:,:), qcloud_bfsum1(:,:,:), qrainsum1(:,:,:), & - qicesum1(:,:,:), qsnowsum1(:,:,:), & - qgraupsum1(:,:,:), & - qlsinksum1(:,:,:), precrsum1(:,:,:), & - precsolidsum1(:,:,:), precallsum1(:,:,:), & - altsum1(:,:,:), rhsum1(:,:,:), cf3dsum1(:,:,:), & - wwsum1(:,:,:), wwsqsum1(:,:,:), & - tkesgssum1(:,:,:), qlsink_bfsum1(:,:,:), & - prainsum1(:,:,:), qvssum1(:,:,:) ) - -! Determine draft categories and get running sums of them. - call categorization_stats( .true., & - nx, ny, nzm, nupdraft, ndndraft, ndraft_max, & - mode_updnthresh, upthresh, downthresh, & - upthresh2, downthresh2, cloudthresh, prcpthresh, & - cloudthresh_trans, precthresh_trans, & - qvssum1(:,:,:), & - plumetype, allcomb, & - updraftbase(1:nupdraft), updrafttop(1:nupdraft), & - dndraftbase(1:ndndraft), dndrafttop(1:ndndraft), & - qcloudsum1(:,:,:), qcloud_bfsum1(:,:,:), qrainsum1(:,:,:), & - qicesum1(:,:,:), qsnowsum1(:,:,:), qgraupsum1(:,:,:), & - qlsinksum1(:,:,:), precrsum1(:,:,:), & - precsolidsum1(:,:,:), precallsum1(:,:,:), & - altsum1(:,:,:), rhsum1(:,:,:), cf3dsum1(:,:,:), & - wwsum1(:,:,:), wwsqsum1(:,:,:), tkesgssum1(:,:,:), & - qlsink_bfsum1(:,:,:), prainsum1(:,:,:), & - area_bnd_final(:,:,1:1+ndn+nup,:), area_cen_final(:,:,1:1+ndn+nup,:), & - area_bnd_sum(:,:,1:1+ndn+nup,:), area_cen_sum(:,:,1:1+ndn+nup,:), & - ent_bnd_sum(:,:,1:1+ndn+nup,:), mass_bnd_sum(:,:,1:1+ndn+nup,:), & - rh_cen_sum(:,:,1:1+ndn+nup,:), & - qcloud_cen_sum(:,:,1:1+ndn+nup,:), qcloud_bf_cen_sum(:,:,1:1+ndn+nup,:), qrain_cen_sum(:,:,1:1+ndn+nup,:), & - qice_cen_sum(:,:,1:1+ndn+nup,:), qsnow_cen_sum(:,:,1:1+ndn+nup,:), & - qgraup_cen_sum(:,:,1:1+ndn+nup,:), & - qlsink_cen_sum(:,:,1:1+ndn+nup,:), precr_cen_sum(:,:,1:1+ndn+nup,:), & - precsolid_cen_sum(:,:,1:1+nup+ndn,:), precall_cen_sum(:,:,1:1+nup+ndn,:), & - qlsink_bf_cen_sum(:,:,1:1+nup+ndn,:), prain_cen_sum(:,:,1:1+nup+ndn,:), & - wwqui_cen_sum, wwqui_bnd_sum, wwqui_cloudy_cen_sum, wwqui_cloudy_bnd_sum, & - wup_thresh, wdown_thresh ) - -! If we want final area categories based on the last avg1 period in each -! avg2 then we need to zero out the running sum just created for the areas -! if it is not the last block of time in ntavg2 - if( areaavgtype==1 .and. .not. mod(itavg2,ntavg2)==0 ) then - call zero_out_areas( & - area_bnd_final(:,:,1:1+ndn+nup,:), & - area_cen_final(:,:,1:1+ndn+nup,:) ) - end if - -! Done with time level one averages so zero them out for next period. - call zero_out_sums1( qcloudsum1(:,:,:), qcloud_bfsum1(:,:,:), qrainsum1(:,:,:), & - qicesum1(:,:,:), qsnowsum1(:,:,:), qgraupsum1(:,:,:), & - qlsinksum1(:,:,:), precrsum1(:,:,:), & - precsolidsum1(:,:,:), precallsum1(:,:,:), & - altsum1(:,:,:), rhsum1(:,:,:), cf3dsum1(:,:,:), & - wwsum1(:,:,:), wwsqsum1(:,:,:), tkesgssum1(:,:,:), & - qlsink_bfsum1(:,:,:), prainsum1(:,:,:), qvssum1(:,:,:) ) - - end if !End of time level one averaging period - -! Check if we have reached the end of a level 2 averaging period. - if( mod(itavg2,ntavg2) == 0 ) then - -! Turn the running sums into averages. ncnt1 in this case is the number -! of calls to categorization_stats during the level 2 averaging period, -! which increment the bnd/cen arrays. - if( itavg2 /= 0 ) then - ncnt1 = ntavg2_ss/ntavg1_ss - ncnt2 = ntavg2 - else - ncnt1 = 1 - ncnt2 = 1 - end if - - call rsums2ToAvg( areaavgtype, nx, ny, ncnt1, ncnt2, & - xkhvsum(:), & - wwqui_cen_sum(:), wwqui_bnd_sum(:), wwqui_cloudy_cen_sum(:), wwqui_cloudy_bnd_sum(:), & - area_bnd_final(:,:,1:1+ndn+nup,:), area_bnd_sum(:,:,1:1+ndn+nup,:), & - area_cen_final(:,:,1:1+ndn+nup,:), area_cen_sum(:,:,1:1+ndn+nup,:), & - mass_bnd_final(:,:,1:1+ndn+nup,:), mass_bnd_sum(:,:,1:1+ndn+nup,:), & - mass_cen_final(:,:,1:1+ndn+nup,:), mass_cen_sum(:,:,1:1+ndn+nup,:), & - ent_bnd_sum(:,:,1:1+ndn+nup,:), & - rh_cen_sum(:,:,1:1+ndn+nup,:), & - qcloud_cen_sum(:,:,1:1+ndn+nup,:), qcloud_bf_cen_sum(:,:,1:1+ndn+nup,:), qrain_cen_sum(:,:,1:1+ndn+nup,:), & - qice_cen_sum(:,:,1:1+ndn+nup,:), qsnow_cen_sum(:,:,1:1+ndn+nup,:), & - qgraup_cen_sum(:,:,1:1+ndn+nup,:), & - qlsink_cen_sum(:,:,1:1+ndn+nup,:), precr_cen_sum(:,:,1:1+ndn+nup,:), & - precsolid_cen_sum(:,:,1:1+ndn+nup,:), precall_cen_sum(:,:,1:1+ndn+nup,:), & - qlsink_bf_cen_sum(:,:,1:1+ndn+nup,:), prain_cen_sum(:,:,1:1+ndn+nup,:) ) - -! get in-cloud value for rh, qcloud, qrain, qice, qsnow, qgraup, -! percr, precsolid, and precall. (qlsink is already in-cloud values) - do kk=1, nzm - do icl=1, NCLASS_CL - do icls=1, ncls_ecpp_in - do ipr=1, NCLASS_PR - if(area_cen_sum(kk, icl, icls, ipr).gt.afrac_cut) then - rh_cen_sum(kk,icl,icls,ipr) = rh_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - qcloud_cen_sum(kk,icl,icls,ipr) = qcloud_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - qcloud_bf_cen_sum(kk,icl,icls,ipr) = qcloud_bf_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - qrain_cen_sum(kk,icl,icls,ipr) = qrain_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - qice_cen_sum(kk,icl,icls,ipr) = qice_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - qsnow_cen_sum(kk,icl,icls,ipr) = qsnow_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - qgraup_cen_sum(kk,icl,icls,ipr) = qgraup_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - precr_cen_sum(kk,icl,icls,ipr) = precr_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - precsolid_cen_sum(kk,icl,icls,ipr) = precsolid_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - precall_cen_sum(kk,icl,icls,ipr) = precall_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - prain_cen_sum(kk,icl,icls,ipr) = prain_cen_sum(kk,icl,icls,ipr)/area_cen_sum(kk,icl,icls,ipr) - if(qcloud_bf_cen_sum(kk,icl,icls,ipr).gt.1.0e-10) then - qlsink_avg_cen_sum(kk,icl,icls,ipr) = min(1.0/ntavg2_ss, & - prain_cen_sum(kk,icl,icls,ipr)/qcloud_bf_cen_sum(kk,icl,icls,ipr)) - else - qlsink_avg_cen_sum(kk,icl,icls,ipr) = 0.0 - end if - qlsink_bf_cen_sum(kk,icl,icls,ipr) = min(1.0/ntavg2_ss, qlsink_bf_cen_sum(kk,icl,icls,ipr)) - qlsink_cen_sum(kk,icl,icls,ipr) = min(1.0/ntavg2_ss, qlsink_cen_sum(kk,icl,icls,ipr)) - else - rh_cen_sum(kk,icl,icls,ipr) = 0.0 - qcloud_cen_sum(kk,icl,icls,ipr) = 0.0 - qcloud_bf_cen_sum(kk,icl,icls,ipr) = 0.0 - qrain_cen_sum(kk,icl,icls,ipr) = 0.0 - qice_cen_sum(kk,icl,icls,ipr) = 0.0 - qsnow_cen_sum(kk,icl,icls,ipr) = 0.0 - qgraup_cen_sum(kk,icl,icls,ipr) = 0.0 - precr_cen_sum(kk,icl,icls,ipr) = 0.0 - precsolid_cen_sum(kk,icl,icls,ipr) = 0.0 - precall_cen_sum(kk,icl,icls,ipr) = 0.0 - qlsink_bf_cen_sum(kk,icl,icls,ipr) = 0.0 - prain_cen_sum(kk,icl,icls,ipr) = 0.0 - qlsink_avg_cen_sum(kk,icl,icls,ipr) = 0.0 - qlsink_bf_cen_sum(kk,icl,icls,ipr) = 0.0 - qlsink_cen_sum(kk,icl,icls,ipr) = 0.0 - end if - end do - end do - end do -! -! calculate vertical velocity variance for quiescent class - if(sum(area_cen_sum(kk,1:NCLASS_CL, QUI, 1:NCLASS_PR)).gt.afrac_cut) then - wwqui_cen_sum(kk) = wwqui_cen_sum(kk) / sum(area_cen_sum(kk,1:NCLASS_CL, QUI, 1:NCLASS_PR)) - else - wwqui_cen_sum(kk) = 0.0 - end if - if(sum(area_cen_sum(kk,CLD, QUI, 1:NCLASS_PR)).gt.afrac_cut) then - wwqui_cloudy_cen_sum(kk) = wwqui_cloudy_cen_sum(kk) / sum(area_cen_sum(kk, CLD, QUI, 1:NCLASS_PR)) - else - wwqui_cloudy_cen_sum(kk) = 0.0 - end if - - end do ! kk -! -! calcualte vertical velocity variance for quiescent calss at lay boundary - do kk=1, nzm+1 - if(sum(area_bnd_sum(kk,1:NCLASS_CL, QUI, 1:NCLASS_PR)).gt.afrac_cut) then - wwqui_bnd_sum(kk) = wwqui_bnd_sum(kk) / sum(area_bnd_sum(kk,1:NCLASS_CL, QUI, 1:NCLASS_PR)) - else - wwqui_bnd_sum(kk) = 0.0 - end if - if(sum(area_bnd_sum(kk,CLD, QUI, 1:NCLASS_PR)).gt.afrac_cut) then - wwqui_cloudy_bnd_sum(kk) = wwqui_cloudy_bnd_sum(kk) / sum(area_bnd_sum(kk, CLD, QUI, 1:NCLASS_PR)) - else - wwqui_cloudy_bnd_sum(kk) = 0.0 - end if - end do - - end if !End of level two time averaging period - -end subroutine ecpp_crm_stat - -#endif /*ECPP*/ -end module crmx_module_ecpp_crm_driver diff --git a/src/physics/spcam/crm/crmx_module_ecpp_stats.F90 b/src/physics/spcam/crm/crmx_module_ecpp_stats.F90 deleted file mode 100644 index b1f7bf909f..0000000000 --- a/src/physics/spcam/crm/crmx_module_ecpp_stats.F90 +++ /dev/null @@ -1,1805 +0,0 @@ -!------------------------------------------------------------------------ -! F90 module to calculate cloud-model stats needed as innput into ECPP. -! -! Routines in this module: -! boundary_inout -! categorization_stats -! cloud_prcp_check -! determine_transport_thresh -! rsums1 -! rsums1ToAvg -! rsums2 -! rsums2ToAvg -! setup_class_masks -! xyrsumof2d -! xyrsumof3d -! zero_out_areas -! zero_out_sums1 -! zero_out_sums2 -! -! William.Gustafson@pnl.gov; 20-Jul-2006 -! Last modified: 16-Apr-2009, William.Gustafson@pnl.gov -!------------------------------------------------------------------------ -module crmx_module_ecpp_stats -#ifdef ECPP - - use crmx_ecppvars, only: QUI, UP1, DN1, NCLASS_TR, NCLASS_CL, CLR, CLD, NCLASS_PR, PRN, PRY - use cam_abortutils,only: endrun - implicit none - -contains - -!------------------------------------------------------------------------ -subroutine boundary_inout( & - nx, ny, nz, & - uu, vv, & - u_insum, u_outsum, v_insum, v_outsum ) -! Calculates the average in/out-flow velocities and increments the -! running sum of the results. -! William.Gustafson@pnl.gov; 25-Jul-2006 -!------------------------------------------------------------------------ - integer, intent(in) :: nx, ny, nz - real, dimension(:,:,:), intent(in) :: uu, vv - real, dimension(:), intent(inout) :: u_insum, u_outsum, v_insum, v_outsum - - integer :: i, j, k, nxstag, nystag - real :: spd_in, spd_out - - nxstag = nx+1 - nystag = ny+1 -! -! Running sum of inflow/outflow horizontal velocities... -! -! 02-nov-2006 r.easter -! calculate separate in/outflow along x and y boundaries -! because of possibility of fixed boundary conditions -! and non-square domains -! for u_in & u_out, we want the "lineal" average along -! the west and east boundaries, so divide by ny -! for v_in & v_out, we want the "lineal" average along -! the south and north boundaries, so divide by nx -! previous code version divided by "nin" and "nout" -! which is incorrect -! - do k=1,nz - - spd_in = 0.; spd_out = 0. - do j=1,ny - ! Western boundary - if( uu(1,j,k) >= 0. ) then - spd_in = spd_in + uu(1,j,k) - else - spd_out = spd_out - uu(1,j,k) - end if - - ! Eastern boundary - if( uu(nxstag,j,k) <= 0. ) then - spd_in = spd_in - uu(nxstag,j,k) - else - spd_out = spd_out + uu(nxstag,j,k) - end if - end do !j=ny - u_insum(k) = u_insum(k) + spd_in /real(ny) - u_outsum(k) = u_outsum(k) + spd_out/real(ny) - - spd_in = 0.; spd_out = 0. - do i=1,nx - ! Southern boundary - if( vv(i,1,k) >= 0. ) then - spd_in = spd_in + vv(i,1,k) - else - spd_out = spd_out - vv(i,1,k) - end if - - ! Northern boundary - if( vv(i,nystag,k) <= 0. ) then - spd_in = spd_in - vv(i,nystag,k) - else - spd_out = spd_out + vv(i,nystag,k) - end if - end do !i=nx - v_insum(k) = v_insum(k) + spd_in /real(nx) - v_outsum(k) = v_outsum(k) + spd_out/real(nx) - - end do !k=nz -end subroutine boundary_inout - -!------------------------------------------------------------------------ -subroutine rsums1( qcloud, qcloudsum1, & - qcloud_bf, qcloud_bfsum1, & - qrain, qrainsum1, & - qice, qicesum1, & - qsnow, qsnowsum1, & - qgraup, qgraupsum1, & - qlsink, qlsinksum1, & - precr, precrsum1, & - precsolid, precsolidsum1, & - precall, precallsum1, & - alt, altsum1, & - rh, rhsum1, & - cf3d, cf3dsum1, & - ww, wwsum1, & - wwsq, wwsqsum1, & - tkesgs, tkesgssum1, & - qlsink_bf, qlsink_bfsum1, & - prain, prainsum1, & - qvs, qvssum1 ) - -! Increments 3-D running sums for the variables averaged every -! ntavg1_mm minutes. -! William.Gustafson@pnl.gov; 20-Jul-2006 -! Last modified: William.Gustafson@pnl.gof; 25-Nov-2008 -!------------------------------------------------------------------------ - real, dimension(:,:,:), intent(in) :: & - qcloud, qcloud_bf, qrain, qice, qsnow, qgraup, & - qlsink, precr, precsolid, precall, & - alt, rh, cf3d, ww, wwsq, tkesgs, qlsink_bf, prain, qvs - real, dimension(:,:,:), intent(inout) :: & - qcloudsum1, qcloud_bfsum1, qrainsum1, & - qicesum1, qsnowsum1, qgraupsum1, & - qlsinksum1, precrsum1, precsolidsum1, precallsum1, & - altsum1, rhsum1, cf3dsum1, wwsum1, wwsqsum1, tkesgssum1, & - qlsink_bfsum1, prainsum1, qvssum1 - - qcloudsum1 = qcloudsum1 + qcloud - qcloud_bfsum1 = qcloud_bfsum1 + qcloud_bf - qrainsum1 = qrainsum1 + qrain - qicesum1 = qicesum1 + qice - qsnowsum1 = qsnowsum1 + qsnow - qgraupsum1 = qgraupsum1 + qgraup - qlsinksum1 = qlsinksum1 + qlsink*qcloud ! Note this is converted back in rsum2ToAvg - precrsum1 = precrsum1 + precr - precsolidsum1 = precsolidsum1 + precsolid - precallsum1 = precallsum1 + precall - altsum1 = altsum1 + alt - rhsum1 = rhsum1 + rh - cf3dsum1 = cf3dsum1 + cf3d - wwsum1 = wwsum1 + ww - wwsqsum1 = wwsqsum1 + wwsq - tkesgssum1 = tkesgssum1 + tkesgs - qlsink_bfsum1 = qlsink_bfsum1 + qlsink_bf*qcloud_bf ! Note this is converted back in rsum2ToAvg - prainsum1 = prainsum1 + prain - qvssum1 = qvssum1 + qvs - -end subroutine rsums1 - - -!------------------------------------------------------------------------ -subroutine rsums1ToAvg( nt, qcloudsum, qcloud_bfsum, qrainsum, & - qicesum, qsnowsum, qgraupsum, & - qlsinksum, precrsum, precsolidsum, precallsum, & - altsum, rhsum, cf3dsum, wwsum, wwsqsum, tkesgssum, qlsink_bfsum, prainsum, qvssum ) -! Turns the columns of running sums into averages for the level one time -! period. -! William.Gustafson@pnl.gov; 20-Jul-2006 -! Last modified: William.Gustafson@pnl.gov; 25-Nov-2008 -!------------------------------------------------------------------------ - integer, intent(in) :: nt - real, dimension(:,:,:), intent(inout) :: & - qcloudsum, qcloud_bfsum, qrainsum, qicesum, qsnowsum, qgraupsum, & - qlsinksum, precrsum, precsolidsum, precallsum, & - altsum, rhsum, cf3dsum, wwsum, wwsqsum, tkesgssum, qlsink_bfsum, prainsum, qvssum - - real :: ncount - -! print*,"...end of level one averaging period." - - ncount = real(nt) - - qcloudsum = qcloudsum/ncount - qcloud_bfsum = qcloud_bfsum/ncount - qrainsum = qrainsum/ncount - qicesum = qicesum/ncount - qsnowsum = qsnowsum/ncount - qgraupsum = qgraupsum/ncount - qlsinksum = qlsinksum/ncount - precrsum = precrsum/ncount - precsolidsum = precsolidsum/ncount - precallsum = precallsum/ncount - altsum = altsum/ncount - rhsum = rhsum/ncount - cf3dsum = cf3dsum/ncount - wwsum = wwsum/ncount - wwsqsum = wwsqsum/ncount - tkesgssum = tkesgssum/ncount - qlsink_bfsum = qlsink_bfsum/ncount - prainsum = prainsum/ncount - qvssum = qvssum/ncount -end subroutine rsums1ToAvg - -!------------------------------------------------------------------------ -subroutine rsums2( & - nx, ny, nz, & - xkhv, xkhvsum ) -! Increment the running sums for the level 2 time averaging period for -! variables that are not already incremented (i.e. not the area and mass -! flux categories and in/out-flow speed that are already done). The 3-D -! variables are collapsed to 1-D columns. -! William.Gustafson@pnl.gov; 20-Jul-2006 -! Last modified: William.Gustafson@pnl.gov; 25-Nov-2008 -!------------------------------------------------------------------------ - integer, intent(in) :: nx, ny, nz - real, dimension(:,:,:), intent(in) :: & - xkhv - real, dimension(:), intent(inout) :: & - xkhvsum - - integer :: i -! -! Running sums of the simple variables that will be averaged... -! - - call xyrsumof3d(xkhv,xkhvsum) -end subroutine rsums2 - - -!------------------------------------------------------------------------ -subroutine rsums2ToAvg( areaavgtype, nx, ny, nt1, nt2, & - xkhvsum, & - wwqui_cen_sum, wwqui_bnd_sum, wwqui_cloudy_cen_sum, wwqui_cloudy_bnd_sum, & - area_bnd_final, area_bnd_sum, & - area_cen_final, area_cen_sum, & - mass_bnd_final, mass_bnd_sum, & - mass_cen_final, mass_cen_sum, & - ent_bnd_sum, & - rh_cen_sum, & - qcloud_cen_sum, qcloud_bf_cen_sum, qrain_cen_sum, & - qice_cen_sum, qsnow_cen_sum, qgraup_cen_sum, & - qlsink_cen_sum, precr_cen_sum, & - precsolid_cen_sum, precall_cen_sum, & - qlsink_bf_cen_sum, prain_cen_sum ) - -! Turns the columns of level two time period running sums into averages. -! Note that variables that the statistics variables use a different -! number of times. -! -! nt1 = time length of average for area and mass for areaavgtype=2 -! nt2 = time length of average for 2nd averaging period (the whole time) -! -! William.Gustafson@pnl.gov; 20-Jul-2006 -! Last modified: 16-Apr-2009, wig -!------------------------------------------------------------------------ - integer, intent(in) :: areaavgtype, nx, ny, nt1, nt2 - real, dimension(:), intent(inout) :: & - xkhvsum, wwqui_cen_sum, wwqui_bnd_sum, wwqui_cloudy_cen_sum, wwqui_cloudy_bnd_sum - real, dimension(:,:,:,:), intent(inout) :: & - area_bnd_final, area_bnd_sum, & - area_cen_final, area_cen_sum, & - mass_bnd_final, mass_bnd_sum, & - mass_cen_final, mass_cen_sum, & - ent_bnd_sum, rh_cen_sum, & - qcloud_cen_sum, qcloud_bf_cen_sum, qrain_cen_sum, & - qice_cen_sum, qsnow_cen_sum, qgraup_cen_sum, & - qlsink_cen_sum, precr_cen_sum, & - precsolid_cen_sum, precall_cen_sum, & - qlsink_bf_cen_sum, prain_cen_sum - integer :: i, k - real :: ncount2, ncountwind, thesum - -! print*,"...end of level two averaging period." - - ncount2 = real(nx*ny*nt2) - ncountwind = real((nx+1)*ny*nt2) - - xkhvsum = xkhvsum/ncount2 - -! Only touch final areas if doing averages over ntavg2 - if( areaavgtype == 2 ) then - area_bnd_final = area_bnd_final/real(nt1) - area_cen_final = area_cen_final/real(nt1) - end if - - area_bnd_sum = area_bnd_sum/real(nt1) - area_cen_sum = area_cen_sum/real(nt1) - ent_bnd_sum = ent_bnd_sum/real(nt1) - mass_bnd_sum = mass_bnd_sum/real(nt1) - mass_cen_sum = mass_cen_sum/real(nt1) - rh_cen_sum = rh_cen_sum/real(nt1) - qcloud_cen_sum = qcloud_cen_sum/real(nt1) - qcloud_bf_cen_sum = qcloud_bf_cen_sum/real(nt1) - qrain_cen_sum = qrain_cen_sum/real(nt1) - qice_cen_sum = qice_cen_sum/real(nt1) - qsnow_cen_sum = qsnow_cen_sum/real(nt1) - qgraup_cen_sum = qgraup_cen_sum/real(nt1) - do k=1,size(qlsink_cen_sum,1) !Note: must be after qcloud_cen_sum is turned into an avg - ! see rsums1 where qlsink=qlsink*qcloud - thesum = sum(qcloud_cen_sum(k,:,:,:)) - if( thesum > 1e-25 ) then - qlsink_cen_sum(k,:,:,:) = qlsink_cen_sum(k,:,:,:)/thesum/real(nt1) - else - qlsink_cen_sum(k,:,:,:) = 0. - end if - end do - precr_cen_sum = precr_cen_sum/real(nt1) - precsolid_cen_sum = precsolid_cen_sum/real(nt1) - precall_cen_sum = precall_cen_sum/real(nt1) - do k=1,size(qlsink_bf_cen_sum,1) !Note: must be after qcloud_bf_cen_sum is turned into an avg - ! see rsums1 where qlsink=qlsink*qcloud - thesum = sum(qcloud_bf_cen_sum(k,:,:,:)) - if( thesum > 1e-25 ) then - qlsink_bf_cen_sum(k,:,:,:) = qlsink_bf_cen_sum(k,:,:,:)/thesum/real(nt1) - else - qlsink_bf_cen_sum(k,:,:,:) = 0. - end if - end do - - prain_cen_sum = prain_cen_sum/real(nt1) - wwqui_cen_sum = wwqui_cen_sum / real(nt1) - wwqui_bnd_sum = wwqui_bnd_sum / real(nt1) - wwqui_cloudy_cen_sum = wwqui_cloudy_cen_sum / real(nt1) - wwqui_cloudy_bnd_sum = wwqui_cloudy_bnd_sum / real(nt1) - -end subroutine rsums2ToAvg - - -!------------------------------------------------------------------------ -subroutine xyrsumof2d(xin,sumout) -! For a 2-D intput variable (x,y), the x & y dimensions are summed and -! added to a running sum. -! William.Gustafson@pnl.gov; 25-Apr-2006 -!------------------------------------------------------------------------ - real, dimension(:,:), intent(in) :: xin - real, intent(out) :: sumout - - sumout = 0.0 - sumout = sumout + sum(xin(:,:)) -end subroutine xyrsumof2d - - -!------------------------------------------------------------------------ -subroutine xyrsumof3d(xin,sumout) -! For a 3-D intput variable (x,y,z), the x & y dimensions are summed and -! added to a column to return a running sum. -! William.Gustafson@pnl.gov; 26-Jun-2006 -!------------------------------------------------------------------------ - real, dimension(:,:,:), intent(in) :: xin - real, dimension(:), intent(out) :: sumout - - integer :: k - - sumout(:) = 0.0 - do k=1,ubound(sumout,1) - sumout(k) = sumout(k) + sum(xin(:,:,k)) - end do -end subroutine xyrsumof3d - - -!------------------------------------------------------------------------ -subroutine zero_out_areas( & - area_bnd_final, area_cen_final ) -! Zeros out the running sums of final area categories. -! William.Gustafson@pnl.gov; 19-Nov-2008 -!------------------------------------------------------------------------ - real, dimension(:,:,:,:), intent(out) :: & - area_bnd_final, area_cen_final - - area_bnd_final=0. - area_cen_final=0. -end subroutine zero_out_areas - - -!------------------------------------------------------------------------ -subroutine zero_out_sums1( qcloudsum, qcloud_bfsum, qrainsum, & - qicesum, qsnowsum, qgraupsum, & - qlsink, precr, precsolid, precall, & - altsum, rhsum, cf3dsum, wwsum, wwsqsum, tkesgssum, & - qlsink_bfsum, prainsum, qvssum ) -! Zeros out running sum arrays that are averaged every ntavg1_mm minutes. -! William.Gustafson@pnl.gov; 20-Jul-2006 -! Last modified: William.Gustafson@pnl.gov; 25-Nov-2008 -!------------------------------------------------------------------------ - real,dimension(:,:,:), intent(out) :: & - qcloudsum, qcloud_bfsum, qrainsum, qicesum, qsnowsum, qgraupsum, & - qlsink, precr, precsolid, precall, & - altsum, rhsum, cf3dsum, wwsum, wwsqsum, tkesgssum, qlsink_bfsum, prainsum, qvssum - - qcloudsum=0. - qcloud_bfsum=0. - qrainsum=0. - qicesum=0. - qsnowsum=0. - qgraupsum=0. - qlsink=0. - precr=0. - precsolid=0. - precall=0. - altsum=0. - rhsum=0. - cf3dsum=0. - wwsum=0. - wwsqsum=0. - tkesgssum=0. - qlsink_bfsum=0.0 - prainsum=0.0 - qvssum=0.0 -end subroutine zero_out_sums1 - - -!------------------------------------------------------------------------ -subroutine zero_out_sums2( & - xkhvsum, & - wwqui_cen_sum, wwqui_bnd_sum, wwqui_cloudy_cen_sum, wwqui_cloudy_bnd_sum, & - area_bnd_final, area_bnd_sum, area_cen_final, area_cen_sum, & - mass_bnd_final, mass_bnd_sum, mass_cen_final, mass_cen_sum, & - ent_bnd_sum, & - rh_cen_sum, & - qcloud_cen_sum, qcloud_bf_cen_sum, qrain_cen_sum, & - qice_cen_sum, qsnow_cen_sum, qgraup_cen_sum, & - qlsink_cen_sum, & - precr_cen_sum, precsolid_cen_sum, precall_cen_sum, & - qlsink_bf_cen_sum, qlsink_avg_cen_sum, prain_cen_sum ) -! Zeros out running sum arrays that are averaged every ntavg2_mm minutes. -! William.Gustafson@pnl.gov; 20-Jul-2006 -! Last modified: 25-Nov-2008, wig -!------------------------------------------------------------------------ - real,dimension(:), intent(out) :: & - xkhvsum, wwqui_cen_sum, wwqui_bnd_sum, wwqui_cloudy_cen_sum, wwqui_cloudy_bnd_sum - real,dimension(:,:,:,:), intent(out) :: & - area_bnd_final, area_bnd_sum, area_cen_final, area_cen_sum, & - mass_bnd_final, mass_bnd_sum, mass_cen_final, mass_cen_sum, & - ent_bnd_sum, rh_cen_sum, & - qcloud_cen_sum, qcloud_bf_cen_sum, qrain_cen_sum, & - qice_cen_sum, qsnow_cen_sum, qgraup_cen_sum, & - qlsink_cen_sum, & - precr_cen_sum, precsolid_cen_sum, precall_cen_sum, & - qlsink_bf_cen_sum, qlsink_avg_cen_sum, prain_cen_sum - - xkhvsum=0. - wwqui_cen_sum=0. - wwqui_bnd_sum=0. - wwqui_cloudy_cen_sum=0. - wwqui_cloudy_bnd_sum=0. - area_bnd_final=0. - area_bnd_sum=0. - area_cen_final=0. - area_cen_sum=0. - mass_bnd_final=0. - mass_bnd_sum=0. - mass_cen_final=0. - mass_cen_sum=0. - ent_bnd_sum=0. - rh_cen_sum=0. - qcloud_cen_sum=0. - qcloud_bf_cen_sum=0. - qrain_cen_sum=0. - qice_cen_sum=0. - qsnow_cen_sum=0. - qgraup_cen_sum=0. - qlsink_cen_sum=0. - precr_cen_sum=0. - precsolid_cen_sum=0. - precall_cen_sum=0. - qlsink_bf_cen_sum=0. - qlsink_avg_cen_sum=0. - prain_cen_sum=0. -end subroutine zero_out_sums2 - - -!------------------------------------------------------------------------ -subroutine categorization_stats( domass, & - nx, ny, nz, nupdraft, ndndraft, ndraft_max, & - mode_updnthresh, upthresh, downthresh, & - upthresh2, downthresh2, cloudthresh, prcpthresh, & - cloudthresh_trans, precthresh_trans, & - qvs, & - plumetype, allcomb, & -! ctime, & - updraftbase, updrafttop, dndraftbase, dndrafttop, & - qcloud, qcloud_bf, qrain, qice, qsnow, qgraup, & - qlsink, precr, precsolid, precall, & - alt, rh, cf3d, ww, wwsq, tkesgs, & - qlsink_bf, prain, & - area_bnd_final, area_cen_final, & - area_bnd_sum, area_cen_sum, ent_bnd_sum, mass_bnd_sum, & - rh_cen_sum, & - qcloud_cen_sum, qcloud_bf_cen_sum, qrain_cen_sum, & - qice_cen_sum, qsnow_cen_sum, qgraup_cen_sum, & - qlsink_cen_sum, precr_cen_sum, & - precsolid_cen_sum, precall_cen_sum, & - qlsink_bf_cen_sum, prain_cen_sum, & - wwqui_cen_sum, wwqui_bnd_sum, wwqui_cloudy_cen_sum, wwqui_cloudy_bnd_sum, & - wup_thresh, wdown_thresh ) -! -! William.Gustafson@pnl.gov; 25-Nov-2008 -! Last modified: William.Gustafson@pnl.gov; 16-Apr-2009 -!------------------------------------------------------------------------ - use module_data_ecpp1, only: a_quiescn_minaa -! -! Subroutine arguments... -! - logical, intent(in) :: domass !calculate mass fluxes? T/F - integer, intent(in) :: nx, ny, nz, nupdraft, ndndraft, ndraft_max, & - mode_updnthresh, plumetype - logical, intent(in) :: allcomb - real, intent(in) :: & - cloudthresh, prcpthresh, & - downthresh, upthresh, & - downthresh2, upthresh2 - real, intent(in) :: cloudthresh_trans, precthresh_trans -! type(time), intent(in) :: ctime - integer, dimension(:), intent(in) :: & - updraftbase, updrafttop, & - dndraftbase, dndrafttop - real, dimension(:,:,:), intent(in) :: & - qcloud, qcloud_bf, qrain, qice, qsnow, qgraup, & - qlsink, precr, precsolid, precall, & - alt, rh, cf3d, ww, wwsq, tkesgs, qlsink_bf, prain, qvs - real, dimension(:,:,:,:), intent(inout) :: & - area_bnd_final, area_cen_final, & - area_bnd_sum, area_cen_sum, ent_bnd_sum, mass_bnd_sum, & - rh_cen_sum, & - qcloud_cen_sum, qcloud_bf_cen_sum, qrain_cen_sum, & - qice_cen_sum, qsnow_cen_sum, qgraup_cen_sum, & - qlsink_cen_sum, precr_cen_sum, & - precsolid_cen_sum, precall_cen_sum, qlsink_bf_cen_sum, prain_cen_sum - - real, dimension(:), intent(inout) :: wwqui_cen_sum, wwqui_bnd_sum, wwqui_cloudy_cen_sum, wwqui_cloudy_bnd_sum - real, dimension(nz+1), intent(out) :: wdown_thresh, wup_thresh -! -! Local vars... -! - real, dimension(nx,ny,nz+1,NCLASS_CL,ndraft_max,NCLASS_PR) :: mask_bnd - real, dimension(nx,ny,nz,NCLASS_CL,ndraft_max,NCLASS_PR) :: mask_cen - real, dimension(nz+1,2) :: wdown_thresh_k, wup_thresh_k - real, dimension(nx,ny,nz) :: cloudmixr, cloudmixr_total, precmixr_total - integer, dimension(nx,ny) :: cloudtop - real, dimension(nz+1) :: wup_rms_k, wup_bar_k, wup_stddev_k & - , wdown_rms_k, wdown_bar_k, wdown_stddev_k - integer :: kup_top, kdown_top ! defined as the maximum level that allows updraft and downdraft - real :: mask, wwrho_k, wwrho_km1 - real, dimension(nz+1) :: rhoair ! layer-averaged air density - real :: wlarge = 1.0e10 ! m/s - real :: tmpa, tmpb - real, dimension(nz) :: thresh_factorbb_up, thresh_factorbb_down - real :: acen_quiesc, acen_up, acen_down, abnd_quiesc, abnd_up, abnd_down - real :: acen_quiesc_minaa - real :: wwqui_bar_cen(nz), wwqui_bar_bnd(nz+1), wwqui_cloudy_bar_cen(nz), wwqui_cloudy_bar_bnd(nz+1) - - integer :: i, icl, ipr, itr, j, k, km0, km1, km2, nxy, nzstag - integer :: iter - - logical :: thresh_calc_not_done - - acen_quiesc_minaa = a_quiescn_minaa + 0.01 - - nxy = nx*ny - nzstag = nz+1 - -! Transport classification is based on total condensate (cloudmixr_total), and -! cloudy (liquid) and clear (non-liquid) classification is based on liquid water, -! because wet deposition, aqueous chemistry, and droplet activaton, all are for liquid clouds. -! -! Minghuai Wang, 2010-04 -! - cloudmixr = qcloud - cloudmixr_total = qcloud + qice - -! total hydrometer (rain, snow, and graupel) - precmixr_total = qrain+qsnow+qgraup - - rhoair(:) = 0.0 - do j=1,ny - do i=1,nx -! -! Get cloud top height -! Cloud top height is used to determine whether there is updraft/downdraft. No updraft and -! downdraft is allowed above the condensate level (both liquid and ice). - cloudtop(i,j) = 1 !Default to bottom level if no cloud in column. - do k=nz,1,-1 - if( cloudmixr_total(i,j,k) >= cloudthresh_trans ) then -! -! 0.01*qvs may be too large at low level. -! if( cloudmixr_total(i,j,k) >= max(0.01*qvs(i,j,k), cloudthresh_trans) ) then - cloudtop(i,j) = k - exit - end if - end do !k -! -! Get layer-averaged air density - do k=1, nzstag - km0 = min(nz,k) - km1 = max(1,k-1) - rhoair(k) = rhoair(k)+0.5*(1.0/alt(i,j,km1) + 1.0/alt(i,j,km0))/real(nxy) - end do - end do !i - end do !j - - call determine_transport_thresh( & - nx, ny, nz, & - mode_updnthresh, upthresh, downthresh, & - upthresh2, downthresh2, cloudthresh, & - ww, rhoair, & - wdown_thresh_k, wup_thresh_k & - , cloudtop & - , wup_rms_k, wup_bar_k, wup_stddev_k & - , wdown_rms_k, wdown_bar_k, wdown_stddev_k & - , kup_top, kdown_top ) - - wdown_thresh(:) = wdown_thresh_k(:,1) - wup_thresh(:) = wup_thresh_k(:,1) - - if ((nupdraft > 1) .or. (ndndraft > 1)) then - call endrun('*** code for thresh_factorbb_up/down needs nup/dndraft = 1') - end if - thresh_factorbb_up(:) = 1.0 ; thresh_factorbb_down(:) = 1.0 - thresh_calc_not_done = .true. - - iter = 0 -thresh_calc_loop: & - do while ( thresh_calc_not_done ) - - iter = iter + 1 -! if quiescent class area was too small on previous iteration, -! then thresh_factor_acen_quiesc will be > 1.0 -! multiply wup/down_thresh_k by this factor to reduce the -! up/downdraft areas and increase the quiescent area - do k = 1, nzstag - if (k == 1) then - tmpa = thresh_factorbb_up(k) - tmpb = thresh_factorbb_down(k) - else if (k == nzstag) then - tmpa = thresh_factorbb_up(k-1) - tmpb = thresh_factorbb_down(k-1) - else - tmpa = maxval( thresh_factorbb_up(k-1:k) ) - tmpb = maxval( thresh_factorbb_down(k-1:k) ) - end if - wup_thresh_k( k,:) = wup_thresh_k( k,:) * tmpa - wdown_thresh_k(k,:) = wdown_thresh_k(k,:) * tmpb - end do ! k - - do k=1, max(1, kup_top-1) - wup_thresh(k) = wup_thresh_k(k,1) - end do - do k=1, max(1, kdown_top-1) - wdown_thresh(k) = wdown_thresh_k(k,1) - end do - - do k=1, nzstag - if(wup_thresh(k).lt.0.05) then - write(0,*) 'erros in wup_thresh', k, wup_thresh_k(:,1), thresh_factorbb_up(:) - call endrun('wup_thresh errors in ecpp_stat') - end if - end do -! -! fix a bug in the WRF_ECPP, Minghuai Wang, 2009-12. -! set wdown_thresh_k and wup_thresh_k to be an extreme value -! above updraft (kup_top) and downdraft top(kdown_top). -! This will make sure there is no updraft or downdraft above kup_top and kdown_top -! - do k=kup_top, nz+1 - wup_thresh_k(k, :) = wlarge - end do - do k=kdown_top, nz+1 - wdown_thresh_k(k,:) = -1. * wlarge - end do - - call setup_class_masks( & - nx, ny, nz, nupdraft, ndndraft, ndraft_max, & - cloudmixr, cf3d, precall, ww, & - wdown_thresh_k, wup_thresh_k, & - cloudthresh, prcpthresh, & - mask_bnd, mask_cen, & - cloudmixr_total, cloudthresh_trans, precthresh_trans, & - qvs, precmixr_total ) - -! -! ( code added on 14-dec-2009 to guarantee quiescent class -! area > acen_quiesc_minaa ) -! at each level -! calculate total fractional area for quiescent class -! using the current level-1 averages -! if (acen_quiesc < acen_quiesc_minaa), increase the -! thresh_factorbb_up/down(k) by factor of 1.5 or 1.2 -! (also, if acen_down > acen_up, increase thresh_factorbb_up by less -! - thresh_calc_not_done = .false. - do k = 1,nz - acen_quiesc = sum( mask_cen( 1:nx, 1:ny, k, 1:NCLASS_CL, QUI, 1:NCLASS_PR) ) - acen_quiesc = max( acen_quiesc/real(nxy), 0.0 ) - acen_up = sum( mask_cen( 1:nx, 1:ny, k, 1:NCLASS_CL, UP1, 1:NCLASS_PR) ) - acen_up = max( acen_up/real(nxy), 0.0 ) - acen_down = max( (1.0 - acen_quiesc - acen_up), 0.0 ) - - abnd_quiesc = sum( mask_bnd( 1:nx, 1:ny, k, 1:NCLASS_CL, QUI, 1:NCLASS_PR) ) - abnd_quiesc = max( abnd_quiesc/real(nxy), 0.0 ) - abnd_up = sum( mask_bnd( 1:nx, 1:ny, k, 1:NCLASS_CL, UP1, 1:NCLASS_PR) ) - abnd_up = max( abnd_up/real(nxy), 0.0 ) - abnd_down = max( (1.0 - abnd_quiesc - abnd_up), 0.0 ) - - if (min(acen_quiesc, abnd_quiesc) < acen_quiesc_minaa) then - thresh_calc_not_done = .true. - if (acen_down > acen_up ) then - tmpa = acen_up/acen_down - else if (abnd_down > abnd_up ) then - tmpa = abnd_up/abnd_down - else - tmpa = 1.0 - end if - if (min(acen_quiesc,abnd_quiesc) < 0.5*acen_quiesc_minaa) then - thresh_factorbb_down(k) = thresh_factorbb_down(k)*1.5 - thresh_factorbb_up(k) = thresh_factorbb_up(k)*max(1.5*tmpa, 1.25) - else - thresh_factorbb_down(k) = thresh_factorbb_down(k)*1.25 - thresh_factorbb_up(k) = thresh_factorbb_up(k)*max(1.25*tmpa, 1.125) - end if - if(iter.gt.5) then - write(0, *) 'warning: The number of iteration is larger than 5 in ecpp_stat', 'iter=', iter , & - 'acen_quiesc=', acen_quiesc, 'acen_up=', acen_up, 'k=', k, & - 'wthreshdown=', wdown_thresh_k(k,1), 'wthreshup=', wup_thresh_k(k,1) -! call endrun('The number of iteration is larger than 10 in ecpp_stat') - end if - end if - end do ! k - -! thresh_calc_not_done = .false. ! not use this iteration method +++mhwang - - end do thresh_calc_loop - - wwqui_bar_cen(:) = 0.0 - wwqui_cloudy_bar_cen(:) = 0.0 - wwqui_bar_bnd(:) = 0.0 - wwqui_cloudy_bar_bnd(:) = 0.0 - - XYCLASSLOOPS: do j = 1,ny - do i = 1,nx - do ipr = 1,NCLASS_PR - do itr = 1,ndraft_max - do icl = 1,NCLASS_CL -! -! We now have enough information to aggregate the variables into domain -! averages by class. Do this first for the cell centers... -! - do k = 1,nz - mask = mask_cen(i,j,k,icl,itr,ipr)/real(nxy) - - area_cen_final(k,icl,itr,ipr) = area_cen_final(k,icl,itr,ipr) + mask - - if( domass ) then - area_cen_sum(k,icl,itr,ipr) = area_cen_sum(k,icl,itr,ipr) + mask - rh_cen_sum(k,icl,itr,ipr) = rh_cen_sum(k,icl,itr,ipr) + rh(i,j,k)*mask - qcloud_cen_sum(k,icl,itr,ipr) = qcloud_cen_sum(k,icl,itr,ipr) + qcloud(i,j,k)*mask - qcloud_bf_cen_sum(k,icl,itr,ipr) = qcloud_bf_cen_sum(k,icl,itr,ipr) + qcloud_bf(i,j,k)*mask - qrain_cen_sum(k,icl,itr,ipr) = qrain_cen_sum(k,icl,itr,ipr) + qrain(i,j,k)*mask - qice_cen_sum(k,icl,itr,ipr) = qice_cen_sum(k,icl,itr,ipr) + qice(i,j,k)*mask - qsnow_cen_sum(k,icl,itr,ipr) = qsnow_cen_sum(k,icl,itr,ipr) + qsnow(i,j,k)*mask - qgraup_cen_sum(k,icl,itr,ipr) = qgraup_cen_sum(k,icl,itr,ipr) + qgraup(i,j,k)*mask - qlsink_cen_sum(k,icl,itr,ipr) = qlsink_cen_sum(k,icl,itr,ipr) + qlsink(i,j,k)*mask - precr_cen_sum(k,icl,itr,ipr) = precr_cen_sum(k,icl,itr,ipr) + precr(i,j,k)*mask - precsolid_cen_sum(k,icl,itr,ipr) = precsolid_cen_sum(k,icl,itr,ipr) + precsolid(i,j,k)*mask - precall_cen_sum(k,icl,itr,ipr) = precall_cen_sum(k,icl,itr,ipr) + precall(i,j,k)*mask - qlsink_bf_cen_sum(k,icl,itr,ipr) = qlsink_bf_cen_sum(k,icl,itr,ipr) + qlsink_bf(i,j,k)*mask - prain_cen_sum(k,icl,itr,ipr) = prain_cen_sum(k,icl,itr,ipr) + prain(i,j,k)*mask -! -! calculate the mean vertical velocity over the quiescent class +++mhwang -! - if(itr.eq.QUI) then - wwqui_bar_cen(k) = wwqui_bar_cen(k)+(ww(i,j,k)+ww(i,j,k+1))*0.5*mask - if(icl.eq.CLD) then - wwqui_cloudy_bar_cen(k)=wwqui_cloudy_bar_cen(k)+(ww(i,j,k)+ww(i,j,k+1))*0.5*mask - end if - end if - - end if - end do !k -! -! Now, we can do a similar aggregation for the cell boundaries. Here, we -! will also calculate the mass flux and entrainment. -! - do k = 1,nzstag - mask = mask_bnd(i,j,k,icl,itr,ipr)/real(nxy) - - area_bnd_final(k,icl,itr,ipr) = area_bnd_final(k,icl,itr,ipr) + mask - - if( domass ) then - !NOTE: technically we should interpolate and not do a simple - ! average to get density at the cell interface - km0 = min(nz,k) - km1 = max(1,k-1) - km2 = max(1,k-2) - wwrho_k = 0.5*(1.0/alt(i,j,km1) + 1.0/alt(i,j,km0))*ww(i,j,k) - wwrho_km1 = 0.5*(1.0/alt(i,j,km2) + 1.0/alt(i,j,km1))*ww(i,j,km1) - - area_bnd_sum(k,icl,itr,ipr) = area_bnd_sum(k,icl,itr,ipr) + mask - mass_bnd_sum(k,icl,itr,ipr) = mass_bnd_sum(k,icl,itr,ipr) + wwrho_k*mask - ent_bnd_sum(k,icl,itr,ipr) = ent_bnd_sum(k,icl,itr,ipr) + max(0., wwrho_k-wwrho_km1)*mask - -! -! calculate the mean vertical velocity over the quiescent class +++mhwang -! - if(itr.eq.QUI) then - wwqui_bar_bnd(k) = wwqui_bar_bnd(k)+ww(i,j,k)*mask - if(icl.eq.CLD) then - wwqui_cloudy_bar_bnd(k)=wwqui_cloudy_bar_bnd(k)+ww(i,j,k)*mask - end if - end if - - end if - end do !k - - end do !icl - end do !itr - end do !pr - end do !i - end do XYCLASSLOOPS !j - -! -! calcualte vertical velocity variance for quiescent class (total and cloudy) +++mhwang -! - do k=1, nz - if(sum(mask_cen(1:nx, 1:ny, k, 1:NCLASS_CL, QUI, 1:NCLASS_PR)).ge.0.5) then - wwqui_bar_cen(k) = wwqui_bar_cen(k)* real(nxy) /sum(mask_cen(1:nx, 1:ny, k, 1:NCLASS_CL, QUI, 1:NCLASS_PR)) - else - wwqui_bar_cen(k) = 0.0 - end if - if(sum(mask_cen(1:nx, 1:ny, k, CLD, QUI, 1:NCLASS_PR)).ge.0.5) then - wwqui_cloudy_bar_cen(k) = wwqui_cloudy_bar_cen(k)* real(nxy) /sum(mask_cen(1:nx, 1:ny, k, CLD, QUI, 1:NCLASS_PR)) - else - wwqui_cloudy_bar_cen(k) = 0.0 - end if - end do - do k=1, nzstag - if(sum(mask_bnd(1:nx, 1:ny, k, 1:NCLASS_CL, QUI, 1:NCLASS_PR)).ge.0.5) then - wwqui_bar_bnd(k) = wwqui_bar_bnd(k)* real(nxy) /sum(mask_bnd(1:nx, 1:ny, k, 1:NCLASS_CL, QUI, 1:NCLASS_PR)) - else - wwqui_bar_bnd(k) = 0.0 - end if - if(sum(mask_bnd(1:nx, 1:ny, k, CLD, QUI, 1:NCLASS_PR)).ge.0.5) then - wwqui_cloudy_bar_bnd(k) = wwqui_cloudy_bar_bnd(k)* real(nxy) /sum(mask_bnd(1:nx, 1:ny, k, CLD, QUI, 1:NCLASS_PR)) - else - wwqui_cloudy_bar_bnd(k) = 0.0 - end if - end do - - QUIELOOPS: do j = 1,ny - do i = 1,nx - do ipr = 1,NCLASS_PR - do icl = 1,NCLASS_CL - - do k = 1,nz - mask = mask_cen(i,j,k,icl,QUI,ipr)/real(nxy) - -! -! calculate the vertical velocity variance over the quiescent class +++mhwang -! wwqui_bar_cen is used in for both all sky and cloudy sky. -! when wwqui_cloudy_bar_cen was used for cloudy sky, wwqui_cloudy_cen_sum will be smaller than wwqui_cen_sum. -! -#ifdef CLUBB_CRM - wwqui_cen_sum(k) = wwqui_cen_sum(k)+mask * ((ww(i,j,k)+ww(i,j,k+1))*0.5-wwqui_bar_cen(k))**2 + mask * & - (wwsq(i,j,k)+wwsq(i,j,k+1))**2/4. -#else - wwqui_cen_sum(k) = wwqui_cen_sum(k)+mask * ((ww(i,j,k)+ww(i,j,k+1))*0.5-wwqui_bar_cen(k))**2 + mask * & - tkesgs(i,j,k)/3. -#endif - if(icl.eq.CLD) then -#ifdef CLUBB_CRM - wwqui_cloudy_cen_sum(k)=wwqui_cloudy_cen_sum(k)+mask * ((ww(i,j,k)+ww(i,j,k+1))*0.5-wwqui_bar_cen(k))**2 & - + mask * (wwsq(i,j,k)+wwsq(i,j,k+1))**2/4. -#else - wwqui_cloudy_cen_sum(k)=wwqui_cloudy_cen_sum(k)+mask * ((ww(i,j,k)+ww(i,j,k+1))*0.5-wwqui_bar_cen(k))**2 & - + mask * tkesgs(i,j,k)/3. -#endif - end if - end do !k - -! -! Now, we can do a similar aggregation for the cell boundaries. -! - do k = 1,nzstag - mask = mask_bnd(i,j,k,icl,QUI,ipr)/real(nxy) - - !NOTE: technically we should interpolate and not do a simple - ! average to get density at the cell interface - km0 = min(nz,k) - km1 = max(1,k-1) -! -! calculate the mean vertical velocity over the quiescent class +++mhwang -! wwqui_bar_bnd is used in both all sky and cloudy sky. -! when wwqui_cloudy_bar_bnd was used for cloudy sky, wwqui_cloudy_bnd_sum will be smaller than wwqui_bnd_sum. -! -#ifdef CLUBB_CRM - wwqui_bnd_sum(k) = wwqui_bnd_sum(k)+mask * (ww(i,j,k)-wwqui_bar_bnd(k))**2 + mask * wwsq(i,j,k)**2 -#else - wwqui_bnd_sum(k) = wwqui_bnd_sum(k)+mask * (ww(i,j,k)-wwqui_bar_bnd(k))**2 + mask * (tkesgs(i,j,km0)+& - tkesgs(i,j,km1)) * 0.5/3. -#endif - if(icl.eq.CLD) then -#ifdef CLUBB_CRM - wwqui_cloudy_bnd_sum(k)=wwqui_cloudy_bnd_sum(k)+mask * (ww(i,j,k)-wwqui_bar_bnd(k))**2 + mask * & - wwsq(i,j,k)**2 -#else - wwqui_cloudy_bnd_sum(k)=wwqui_cloudy_bnd_sum(k)+mask * (ww(i,j,k)-wwqui_bar_bnd(k))**2 + mask * & - (tkesgs(i,j,km0)+tkesgs(i,j,km1)) * 0.5/3. -#endif - end if - - end do !k - - end do !icl - end do !pr - end do !i - end do QUIELOOPS !j - -! testing small queiscent fraction +++mhwang - do k=1, nz - if(sum(area_cen_final(k,:,1,:)).lt.1.0e-3) then - write(0, *) 'ecpp, area_cen_final, quiescent', sum(area_cen_final(k,:,1,:)), k, area_cen_final(k,:,1,:), & - wdown_thresh_k(k,1), wup_thresh_k(k,1) - write(0, *) 'ecpp, area_cen_final, quiescent, wwk', ww(:,:,k), i, wup_rms_k(k), wup_bar_k(k), wup_stddev_k(k) - write(0, *) 'ecpp, area_cen_final, quiescent, wwk+1', ww(:,:,k+1), i, wup_rms_k(k+1), wup_bar_k(k+1), wup_stddev_k(k+1) -! call endrun('area_cen_final less then 1.0-e3') - end if - end do -! ---mhwang -end subroutine categorization_stats - -!------------------------------------------------------------------------ -subroutine determine_transport_thresh( & - nx, ny, nz, & - mode_updnthresh, upthresh, downthresh, & - upthresh2, downthresh2, cloudthresh, & -! ctime, & - ww, rhoair, & - wdown_thresh_k, wup_thresh_k & - , cloudtop & - , wup_rms_k, wup_bar_k, wup_stddev_k & - , wdown_rms_k, wdown_bar_k, wdown_stddev_k & - , kup_top, kdown_top) -! -! Deterines the velocity thresholds used to indicate whether a cell's -! motion is up, down, or quiescent. This is down for two threshold values -! in each direction by level. A dozen options are available on how this -! is done as documented below and at the top of postproc_wrfout. -! -! William.Gustafosn@pnl.gov; 11-Sep-2008 -! Modified: William.Gustafosn@pnl.gov; 14-Apr-2009 -!------------------------------------------------------------------------ -! use timeroutines -! -! Soubroutine arguments... -! - integer, intent(in) :: nx, ny, nz, mode_updnthresh - real, intent(in) :: & - cloudthresh, & - downthresh, upthresh, & - downthresh2, upthresh2 -! type(time), intent(in) :: ctime - real, dimension(:,:,:), intent(in) :: & - ww - real, dimension(nz+1), intent(in) :: rhoair - real, dimension(nz+1,2), intent(out) :: wdown_thresh_k, wup_thresh_k - integer, dimension(nx,ny), intent(in) :: cloudtop - real, dimension(nz+1), intent(out) :: wup_rms_k, wup_bar_k, wup_stddev_k, wdown_bar_k, wdown_rms_k, wdown_stddev_k - integer, intent(out) :: kup_top, kdown_top ! defined as the maximum level that allows updraft and downdraft -! -! Local vars... -! - real, dimension(nz+1) :: & - tmpveca, tmpvecb, & -! wdown_bar_k, wdown_rms_k, wdown_stddev_k, & -! wup_bar_k, wup_rms_k, wup_stddev_k, & - wup_rms_ksmo, wdown_rms_ksmo - real :: tmpsuma, tmpsumb, tmpw, tmpw_minval, & - wdown_bar, wdown_rms, wdown_stddev, & - wup_bar, wup_rms, wup_stddev - integer, dimension(nx,ny) :: & - cloudtop_upaa, cloudtop_upbb, cloudtop_downaa, cloudtop_downbb - integer, dimension(nz+1) :: nup_k, ndown_k - integer :: i, ib, ic, & - j, jb, jc, & - k, kk, kup_center, kdown_center - integer :: ndown, nup - integer :: ijdel, ijdel_cur, ijdel_upaa, ijdel_upbb, ijdel_downaa, ijdel_downbb - -! Calc cloudtop_upaa(i,j) = max( cloudtop(i-del:i+del,j-del:j+del) ) -! and similar for cloudtop_upbb, cloudtop_downaa/bb -! (assume periodic BC here) - ijdel_upaa = 0 ; ijdel_downaa = 0 - ijdel_upbb = 0 ; ijdel_downbb = 0 - if ((mode_updnthresh == 12) .or. (mode_updnthresh == 13)) then -! ijdel_... = 1 corresponds to 3x3 stencil - ijdel_upaa = 1 ; ijdel_downaa = 1 - ijdel_upbb = 1 ; ijdel_downbb = 1 - end if - ijdel = max( ijdel_upaa, ijdel_upbb, ijdel_downaa, ijdel_downbb ) - - if (ijdel > 0) then - do j = 1, ny - do i = 1, nx - cloudtop_upaa(i,j) = cloudtop(i,j) - cloudtop_downaa(i,j) = cloudtop(i,j) - cloudtop_upbb(i,j) = cloudtop(i,j) - cloudtop_downbb(i,j) = cloudtop(i,j) - do jb = j-ijdel, j+ijdel - jc = jb - if (jc < 1) jc = jc + ny - if (jc > ny) jc = jc - ny - do ib = i-ijdel, i+ijdel - ic = ib - if (ic < 1) ic = ic + nx - if (ic > nx) ic = ic - nx - ijdel_cur = max( iabs(ib-i), iabs(jb-j) ) -! cloudtop_downaa calculated over a (2*ijdel_downaa+1)**2 stencil - if (ijdel_cur <= ijdel_downaa) & - cloudtop_downaa(i,j) = max( cloudtop_downaa(i,j), cloudtop(ic,jc) ) -! cloudtop_upaa calculated over a (2*ijdel_upaa+1)**2 stencil - if (ijdel_cur <= ijdel_upaa) & - cloudtop_upaa(i,j) = max( cloudtop_upaa(i,j), cloudtop(ic,jc) ) -! cloudtop_downbb, cloudtop_upbb similarly - if (ijdel_cur <= ijdel_downbb) & - cloudtop_downbb(i,j) = max( cloudtop_downbb(i,j), cloudtop(ic,jc) ) - if (ijdel_cur <= ijdel_upbb) & - cloudtop_upbb(i,j) = max( cloudtop_upbb(i,j), cloudtop(ic,jc) ) - end do ! ib - end do ! jb -! add on 1 level as a "margin of error" - cloudtop_upaa( i,j) = min( cloudtop_upaa( i,j)+1, nz ) - cloudtop_downaa(i,j) = min( cloudtop_downaa(i,j)+1, nz ) - cloudtop_upbb( i,j) = min( cloudtop_upbb( i,j)+1, nz ) - cloudtop_downbb(i,j) = min( cloudtop_downbb(i,j)+1, nz ) - end do ! i - end do ! j - end if ! (ijdel > 0) - -! new coding here and below -! cloudtop_up/downaa - only grid cells with k<=cloudtop_up/downaa -! are used for calc of wup_rms and wdn_rms -! cloudtop_up/downbb - only grid cells with k<=cloudtop_up/downbb -! can be classified as up/downdraft - if ((mode_updnthresh == 12) .or. (mode_updnthresh == 13)) then -! mode_updnthresh >= 12 is a newer, more consistent usage of cloudtop info -! the cloudtop_upaa/upbb/downaa/downbb values are identical, -! and they correspond to the max cloudtop(i,j) over a 3x3 stencil -! only grid cells with k <= this "local" cloudtop can be up/downdraft grids - continue - else -! mode_updnthresh /= 12,13 corresponds to pre 11-jan-2008 versions of preprocessor -! where only grid cells with k <= cloudtop(i,j) are used for calc of wup/dn_rms, -! but any grid cells can be up/dn [even those with k >> cloudtop(i,j)] - cloudtop_upaa(:,:) = cloudtop(:,:) - cloudtop_downaa(:,:) = cloudtop(:,:) - cloudtop_upbb(:,:) = nz - cloudtop_downbb(:,:) = nz - end if - -! -! Get standard deviation of up and down vertical velocity below the -! cloud tops. For now, each cell is treated equally. We may want to -! consider weighting each cell by its volume or mass. -! - ! Get the mean values first for wup and wdown - ndown = 0; nup = 0 - wdown_bar = 0.; wup_bar = 0. - ndown_k(:) = 0; nup_k(:) = 0 - wdown_bar_k(:) = 0.; wup_bar_k(:) = 0. - kup_top = 1; kdown_top= 1 - do j=1,ny - do i=1,nx - do k=1,cloudtop_upaa(i,j)+1 !Plus 1 is so we get w across top of cloud. - !It is dimmensionally ok since w is dimmed nz+1 - !We intentially ignore when w==0 as to not bias one direction - !over the other for the count. This differs from the Ferret code which - !assigns w=0 to up values. - if( ww(i,j,k) > 0. ) then - nup = nup + 1 - wup_bar = wup_bar + ww(i,j,k) - nup_k(k) = nup_k(k) + 1 - wup_bar_k(k) = wup_bar_k(k) + ww(i,j,k) - kup_top = max(kup_top, k) - end if - end do - do k=1,cloudtop_downaa(i,j)+1 - if( ww(i,j,k) < 0. ) then - ndown = ndown + 1 - wdown_bar = wdown_bar + ww(i,j,k) - ndown_k(k) = ndown_k(k) + 1 - wdown_bar_k(k) = wdown_bar_k(k) + ww(i,j,k) - kdown_top = max(kdown_top, k) - end if - end do - - end do - end do - if( nup > 0 ) wup_bar = wup_bar / nup - if( ndown > 0 ) wdown_bar = wdown_bar / ndown - do k = 1, nz+1 - if( nup_k(k) > 0 ) wup_bar_k(k) = wup_bar_k(k) / nup_k(k) - if( ndown_k(k) > 0 ) wdown_bar_k(k) = wdown_bar_k(k) / ndown_k(k) - end do - - !Now, we can get the std. dev. of wup and wdown. - wdown_stddev = 0.; wup_stddev = 0. - wdown_stddev_k(:) = 0.; wup_stddev_k(:) = 0. - do j=1,ny - do i=1,nx - do k=1,cloudtop_upaa(i,j)+1 !Plus 1 is so we get w across top of cloud. - !We intentionally ignore when w==0 as to not bias one direction - !over the other. - if( ww(i,j,k) > 0. ) then - wup_stddev = wup_stddev + (wup_bar-ww(i,j,k))**2 - wup_stddev_k(k) = wup_stddev_k(k) + (wup_bar_k(k)-ww(i,j,k))**2 - end if - end do - do k=1,cloudtop_downaa(i,j)+1 - if( ww(i,j,k) < 0. ) then - wdown_stddev = wdown_stddev + (wdown_bar-ww(i,j,k))**2 - wdown_stddev_k(k) = wdown_stddev_k(k) + (wdown_bar_k(k)-ww(i,j,k))**2 - end if - end do - end do - end do - if( nup > 0 ) wup_stddev = sqrt(wup_stddev / nup) - if( ndown > 0 ) wdown_stddev = sqrt(wdown_stddev / ndown) - wup_rms = sqrt( wup_bar**2 + wup_stddev**2 ) - wdown_rms = sqrt( wdown_bar**2 + wdown_stddev**2 ) - do k = 1, nz+1 - if( nup_k(k) > 0 ) wup_stddev_k(k) = sqrt(wup_stddev_k(k) / nup_k(k)) - if( ndown_k(k) > 0 ) wdown_stddev_k(k) = sqrt(wdown_stddev_k(k) / ndown_k(k)) - wup_rms_k(k) = sqrt( wup_bar_k(k)**2 + wup_stddev_k(k)**2 ) - wdown_rms_k(k) = sqrt( wdown_bar_k(k)**2 + wdown_stddev_k(k)**2 ) - end do - -! calculated smoothed (3-point) wup/down_rms - tmpveca(:) = wup_rms_k( :) - tmpvecb(:) = wdown_rms_k(:) - do k = 2, nz - wup_rms_ksmo( k) = 0.0 - wdown_rms_ksmo(k) = 0.0 - tmpsuma = 0.0 - do kk = max(k-1,2), min(k+1,nz) - wup_rms_ksmo( k) = wup_rms_ksmo( k) + tmpveca(kk) - wdown_rms_ksmo(k) = wdown_rms_ksmo(k) + tmpvecb(kk) - tmpsuma = tmpsuma + 1.0 - end do - tmpsuma = max(tmpsuma,1.0) - wup_rms_ksmo( k) = wup_rms_ksmo( k)/tmpsuma - wdown_rms_ksmo(k) = wdown_rms_ksmo(k)/tmpsuma - end do - wup_rms_ksmo( 1) = wup_rms_ksmo( 2) - wdown_rms_ksmo(1) = wdown_rms_ksmo(2) - wup_rms_ksmo( nz+1) = wup_rms_ksmo( nz) - wdown_rms_ksmo(nz+1) = wdown_rms_ksmo(nz) - -! print "(2a,2(2x,3f8.4))", & -! " ...wup_bar,std,rms; wdown_bar,std,rms ", & -! wup_bar, wup_stddev, wup_rms, wdown_bar, wdown_stddev, wdown_rms -! if (mode_updnthresh >= 5) then -! print "(a/(15f7.3))", & -! " ... wup_rms_k(2:nz)", (wup_rms_k(k), k=2,nz) -! print "(a/(15f7.3))", & -! " ...wdown_rms_k(2:nz)", (wdown_rms_k(k), k=2,nz) -! end if - -! -! Get masks to determine (cloud vs. clear) (up vs. down vs. other) categories. -! Vertical velocities are checked on the cell vertical interfaces to determine -! if they pass the threshold criteria. Clouds below the interface are then -! used for updrafts and above the int. for downdrafts. Quiescent (other) -! drafts use an average of the cloud above and below the interface to -! determine cloudiness. -! - select case ( mode_updnthresh ) - case ( 1 ) - wup_thresh_k( :,1) = wup_stddev*abs(upthresh) - wdown_thresh_k(:,1) = -wdown_stddev*abs(downthresh) - wup_thresh_k( :,2) = wup_stddev*abs(upthresh2) - wdown_thresh_k(:,2) = -wdown_stddev*abs(downthresh2) - case ( 2 ) - wup_thresh_k( :,1) = wup_bar + wup_stddev*abs(upthresh) - wdown_thresh_k(:,1) = wdown_bar - wdown_stddev*abs(downthresh) - wup_thresh_k( :,2) = wup_bar + wup_stddev*abs(upthresh2) - wdown_thresh_k(:,2) = wdown_bar - wdown_stddev*abs(downthresh2) - case ( 3 ) - wup_thresh_k( :,1) = abs(upthresh) - wdown_thresh_k(:,1) = -abs(downthresh) - wup_thresh_k( :,2) = abs(upthresh2) - wdown_thresh_k(:,2) = -abs(downthresh2) - case ( 4 ) - wup_thresh_k( :,1) = (wup_rms )*abs(upthresh) - wdown_thresh_k(:,1) = -(wdown_rms)*abs(downthresh) - wup_thresh_k( :,2) = (wup_rms )*abs(upthresh2) - wdown_thresh_k(:,2) = -(wdown_rms)*abs(downthresh2) - - case ( 5 ) -! For mode_updnthresh = 5, use a weighted average of wup_rms & wup_rms_ksmo(k) -! because wup_rms_ksmo will be zero (or close to it) at many levels - wup_thresh_k( :,1) = (0.25*wup_rms +0.75*wup_rms_ksmo( :))*abs(upthresh) - wdown_thresh_k(:,1) = -(0.25*wdown_rms+0.75*wdown_rms_ksmo(:))*abs(downthresh) - wup_thresh_k( :,2) = (0.25*wup_rms +0.75*wup_rms_ksmo( :))*abs(upthresh2) - wdown_thresh_k(:,2) = -(0.25*wdown_rms+0.75*wdown_rms_ksmo(:))*abs(downthresh2) - - case ( 6, 7 ) -! For mode_updnthresh = 6 & 7, like case 4 except when k <= "updraft center k", -! use minimum of wup_rms and wup_rms_k for updraft threshold - wup_thresh_k( :,1) = (wup_rms )*abs(upthresh) - wdown_thresh_k(:,1) = -(wdown_rms)*abs(downthresh) - wup_thresh_k( :,2) = (wup_rms )*abs(upthresh2) - wdown_thresh_k(:,2) = -(wdown_rms)*abs(downthresh2) - - tmpsuma = 0.0 ; tmpsumb = 1.0e-30 - do k = 1, nz - tmpw = wup_rms_k(k) - if (mode_updnthresh == 7) tmpw = wup_rms_ksmo(k) - tmpw = max(1.0e-4,tmpw) - tmpw = tmpw * rhoair(k) - tmpsuma = tmpsuma + tmpw*k ; tmpsumb = tmpsumb + tmpw - end do - kup_center = nint(tmpsuma/tmpsumb) - tmpw_minval = 0.10 - do k = 1, kup_center - tmpw = wup_rms_k(k) - if (mode_updnthresh == 7) tmpw = wup_rms_ksmo(k) - tmpw = max( tmpw, tmpw_minval ) - tmpw = min( tmpw, wup_rms ) - wup_thresh_k(k,1) = tmpw*abs(upthresh) - wup_thresh_k(k,2) = tmpw*abs(upthresh2) - end do - - case ( 8, 9 ) -! For mode_updnthresh = 8 & 9, like case 6, 7 except that updraft and -! downdraft are treated similarly. So when k >= "downdraft center k", -! use minimum of wdown_rms and wdown_rms_k for downdraft threshold - wup_thresh_k( :,1) = (wup_rms )*abs(upthresh) - wdown_thresh_k(:,1) = -(wdown_rms)*abs(downthresh) - wup_thresh_k( :,2) = (wup_rms )*abs(upthresh2) - wdown_thresh_k(:,2) = -(wdown_rms)*abs(downthresh2) - - tmpsuma = 0.0 ; tmpsumb = 1.0e-30 - do k = 1, nz+1 - tmpw = wup_rms_k(k) - if (mode_updnthresh == 9) tmpw = wup_rms_ksmo(k) - tmpw = max(1.0e-4,tmpw) - tmpw = tmpw * rhoair(k) - tmpsuma = tmpsuma + tmpw*k ; tmpsumb = tmpsumb + tmpw - end do - kup_center = nint(tmpsuma/tmpsumb) - tmpw_minval = 0.10 - do k = 1, kup_center - tmpw = wup_rms_k(k) - if (mode_updnthresh == 9) tmpw = wup_rms_ksmo(k) - tmpw = max( tmpw, tmpw_minval ) - tmpw = min( tmpw, wup_rms ) - wup_thresh_k(k,1) = tmpw*abs(upthresh) - wup_thresh_k(k,2) = tmpw*abs(upthresh2) - end do - - tmpsuma = 0.0 ; tmpsumb = 1.0e-30 - do k = 1, nz+1 - tmpw = wdown_rms_k(k) - if (mode_updnthresh == 9) tmpw = wdown_rms_ksmo(k) - tmpw = max(1.0e-4,tmpw) - tmpw = tmpw * rhoair(k) - tmpsuma = tmpsuma + tmpw*k ; tmpsumb = tmpsumb + tmpw - end do - kdown_center = nint(tmpsuma/tmpsumb) - tmpw_minval = 0.10 - do k = kdown_center, nz+1 - tmpw = wdown_rms_k(k) - if (mode_updnthresh == 9) tmpw = wdown_rms_ksmo(k) - tmpw = max( tmpw, tmpw_minval ) - tmpw = min( tmpw, wdown_rms ) - wdown_thresh_k(k,1) = -tmpw*abs(downthresh) - wdown_thresh_k(k,2) = -tmpw*abs(downthresh2) - end do - - case ( 14, 15 ) -! case 14 & 15 -- added on 10-dec-2009 -! updraft and k > "updraft center k", wup_rms -! updraft and k <= "updraft center k", use min( wup_rms_k, wup_rms ) -! downdraft and k > "downdraft center k", wdown_rms -! downdraft and k <= "downdraft center k", min( use wdown_rms_k, wdown_rms ) -! The idea is to have a higher threshold in upper troposphere to -! filter out gravity waves motions - tmpsuma = 0.0 ; tmpsumb = 1.0e-30 - do k = 1, nz+1 - tmpw = wup_rms_k(k) - if (mode_updnthresh == 15) tmpw = wup_rms_ksmo(k) - tmpw = max(1.0e-4,tmpw) - tmpw = tmpw * rhoair(k) - tmpsuma = tmpsuma + tmpw*k ; tmpsumb = tmpsumb + tmpw - end do - kup_center = nint(tmpsuma/tmpsumb) - tmpw_minval = 0.10 - do k = 1, nz+1 - tmpw = wup_rms_k(k) - if (mode_updnthresh == 15) tmpw = wup_rms_ksmo(k) - if (k > kup_center) then - tmpw = wup_rms - else - tmpw = min( tmpw, wup_rms ) - end if - tmpw = max( tmpw, tmpw_minval ) - wup_thresh_k(k,1) = tmpw*abs(upthresh) - wup_thresh_k(k,2) = tmpw*abs(upthresh2) - end do - - tmpsuma = 0.0 ; tmpsumb = 1.0e-30 - do k = 1, nz+1 - tmpw = wdown_rms_k(k) - if (mode_updnthresh == 15) tmpw = wdown_rms_ksmo(k) - tmpw = max(1.0e-4,tmpw) - tmpw = tmpw * rhoair(k) - tmpsuma = tmpsuma + tmpw*k ; tmpsumb = tmpsumb + tmpw - end do - kdown_center = nint(tmpsuma/tmpsumb) - tmpw_minval = 0.10 - do k = 1, nz+1 - tmpw = wdown_rms_k(k) - if (mode_updnthresh == 15) tmpw = wdown_rms_ksmo(k) - if (k > kdown_center) then - tmpw = wdown_rms - else - tmpw = min( tmpw, wdown_rms ) - end if - tmpw = max( tmpw, tmpw_minval ) - wdown_thresh_k(k,1) = -tmpw*abs(downthresh) - wdown_thresh_k(k,2) = -tmpw*abs(downthresh2) - end do - - case ( 16, 17 ) -! case 16 & 17 -- added on 10-dec-2009 -! updraft and k > "updraft center k", use max( wup_rms_k, wup_rms ) -! updraft and k <= "updraft center k", use wup_rms_k -! downdraft and k > "downdraft center k", use max( wdown_rms_k, wdown_rms ) -! downdraft and k <= "downdraft center k", use wdown_rms_k -! The idea is to have a higher threshold in upper troposphere to -! filter out gravity waves motions - tmpsuma = 0.0 ; tmpsumb = 1.0e-30 - do k = 1, nz+1 - tmpw = wup_rms_k(k) - if (mode_updnthresh == 17) tmpw = wup_rms_ksmo(k) - tmpw = max(1.0e-4,tmpw) - tmpw = tmpw * rhoair(k) - tmpsuma = tmpsuma + tmpw*k ; tmpsumb = tmpsumb + tmpw - end do - kup_center = nint(tmpsuma/tmpsumb) - tmpw_minval = 0.10 - do k = 1, nz+1 - tmpw = wup_rms_k(k) - if (mode_updnthresh == 17) tmpw = wup_rms_ksmo(k) - if (k > kup_center) tmpw = max( tmpw, wup_rms ) - tmpw = max( tmpw, tmpw_minval ) - wup_thresh_k(k,1) = tmpw*abs(upthresh) - wup_thresh_k(k,2) = tmpw*abs(upthresh2) - end do - - tmpsuma = 0.0 ; tmpsumb = 1.0e-30 - do k = 1, nz+1 - tmpw = wdown_rms_k(k) - if (mode_updnthresh == 17) tmpw = wdown_rms_ksmo(k) - tmpw = max(1.0e-4,tmpw) - tmpw = tmpw * rhoair(k) - tmpsuma = tmpsuma + tmpw*k ; tmpsumb = tmpsumb + tmpw - end do - kdown_center = nint(tmpsuma/tmpsumb) - tmpw_minval = 0.10 - do k = 1, nz+1 - tmpw = wdown_rms_k(k) - if (mode_updnthresh == 17) tmpw = wdown_rms_ksmo(k) - if (k > kdown_center) tmpw = max( tmpw, wdown_rms ) - tmpw = max( tmpw, tmpw_minval ) - wdown_thresh_k(k,1) = -tmpw*abs(downthresh) - wdown_thresh_k(k,2) = -tmpw*abs(downthresh2) - end do - - case ( 10, 11, 12, 13 ) -! For mode_updnthresh = 10, 11, use wup_rms_k and wdown_rms_k at all -! levels (or the w---_rms_ksmo) - tmpw_minval = 0.10 - do k = 1, nz+1 - tmpw = wup_rms_k(k) - if (mode_updnthresh == 11) tmpw = wup_rms_ksmo(k) - if (mode_updnthresh == 13) tmpw = wup_rms_ksmo(k) - tmpw = max( tmpw, tmpw_minval ) - wup_thresh_k(k,1) = tmpw*abs(upthresh) - wup_thresh_k(k,2) = tmpw*abs(upthresh2) - end do - tmpw_minval = 0.10 - do k = 1, nz+1 - tmpw = wdown_rms_k(k) - if (mode_updnthresh == 11) tmpw = wdown_rms_ksmo(k) - if (mode_updnthresh == 13) tmpw = wdown_rms_ksmo(k) - tmpw = max( tmpw, tmpw_minval ) - wdown_thresh_k(k,1) = -tmpw*abs(downthresh) - wdown_thresh_k(k,2) = -tmpw*abs(downthresh2) - end do - - case default - call endrun('determine_transport_thresh error - must have 1 <= mode_updnthresh <= 11') - end select - -end subroutine determine_transport_thresh - - -!------------------------------------------------------------------------ -subroutine setup_class_masks( & - nx, ny, nz, nupdraft, ndndraft, ndraft_max, & - cloudmixr, cf3d, precall, ww, & - wdown_thresh_k, wup_thresh_k, & - cloudthresh, prcpthresh, & - mask_bnd, mask_cen, & - cloudmixr_total, cloudthresh_trans, precthresh_trans, & - qvs, precmixr_total ) -! -! Sets up the masks used for determining quiescent/up/down, clear/cloudy, -! and non-precipitatin/precipitating classes. -! -! William.Gustafosn@pnl.gov; 20-Nov-2008 -! Last modified: William.Gustafson@pnl.gov; 16-Apr-2009 - -! Modification by Minghuai Wang (Minghuai.Wang@pnl.gov), April 23, 2010 -! use total condensate (liquid+ice), different condensate and precipitating thresholds -! to classify transport classes. -! See Xu et al., 2002, Q.J.R.M.S. -! - -!------------------------------------------------------------------------ -! -! Soubroutine arguments... -! - integer, intent(in) :: nx, ny, nz, nupdraft, ndndraft, ndraft_max - real, dimension(:,:,:), intent(in) :: & - cloudmixr, cf3d, precall, ww - real, dimension(nz+1,2), intent(in) :: wdown_thresh_k, wup_thresh_k - real, intent(in) :: cloudthresh, prcpthresh - real, dimension(nx,ny,nz+1,NCLASS_CL,ndraft_max,NCLASS_PR), & - intent(out) :: mask_bnd - real, dimension(nx,ny,nz,NCLASS_CL,ndraft_max,NCLASS_PR), & - intent(out) :: mask_cen - real, dimension( :, :, :), intent(in) :: cloudmixr_total ! total condensate (liquid+ice) - real, intent(in) :: cloudthresh_trans, precthresh_trans ! threshold for transport classes - real, dimension( :, :, :), intent(in) :: qvs, precmixr_total -! -! Local vars... -! - integer, dimension(nz+1,nupdraft) :: maskup - integer, dimension(nz+1,ndndraft) :: maskdn - integer, dimension(nz+1) :: maskqu, & - maskcld_bnd, maskclr_bnd, maskpry_bnd, maskprn_bnd - integer, dimension(nz) :: maskcld, maskclr, maskpry, maskprn - integer :: i, itr, icl, ipr, j, k, m, nzstag - real :: cloudthresh_trans_temp, precthresh_trans_temp - - nzstag = nz+1 -! -! Initialize the masks to zero and then we will accumulate values into -! them as we identify the various classes. -! - mask_bnd = 0. - mask_cen = 0. -! -! Loop over the horizontal dimensions... -! - XYLOOPS : do j = 1,ny - do i=1,nx -! -! Set initial mask values for the vertical cell boundaries... -! - maskup = 0 - maskdn = 0 - maskqu = 0 - maskcld = 0 - maskclr = 0 - maskcld_bnd = 0 - maskclr_bnd = 0 - maskpry = 0 - maskprn = 0 - maskpry_bnd = 0 - maskprn_bnd = 0 - - if( nupdraft > 2 .or. ndndraft > 2 ) then - call endrun('OOPS. Cannot have more than 2 updraft or 2 downdraft categories right now.') - end if - - do k = 1,nzstag - - !Transport upward at cell boundaries... - !We have to take into account the possibility of multiple - !updraft categories. At this point, we handle only the - !cases of one or two categories. We do not yet handle the - !allcomb option. - ! - ! updraft only exist in cloudy area or precipitating clear area ++++mhwang - cloudthresh_trans_temp = cloudthresh_trans -! cloudthresh_trans_temp = max(cloudthresh_trans, 0.01 * (qvs(i,j,max(k-1,1))+qvs(i,j,min(k,nz)))*0.5) - if( (cloudmixr_total(i,j,max(k-1,1))+cloudmixr_total(i,j,min(k,nz)))*0.5 > cloudthresh_trans_temp & -! .or. (precall(i,j,max(k-1,1))+precall(i,j,min(k,nz)))*0.5 > prcpthresh_trans) then !+++mhwang - .or. (precmixr_total(i,j,max(k-1,1))+precmixr_total(i,j,min(k,nz)))*0.5 > precthresh_trans) then !+++mhwang - select case (nupdraft) - case (1) !Only one threshold - if( ww(i,j,k) > wup_thresh_k(k,1) ) then - maskup(k,1) = 1 - end if - case (2) !Two thresholds, assumes 1st is stronger wind - if( ww(i,j,k) > wup_thresh_k(k,1) ) then - maskup(k,1) = 1 - else if( ww(i,j,k) > wup_thresh_k(k,2) & - .and. ww(i,j,k) <= wup_thresh_k(k,1) ) then - maskup(k,2) = 1 - end if - end select - end if ! end cloudmixr_total +++mhwang - - !Transport downward at cell boundaries... - ! - ! downdraft only exist in cloudy area or precipitating clear area +++mhwang - if( (cloudmixr_total(i,j,max(k-1,1))+cloudmixr_total(i,j,min(k,nz)))*0.5 > cloudthresh_trans_temp & -! .or. (precall(i,j,max(k-1,1))+precall(i,j,min(k,nz)))*0.5 > prcpthresh_trans) then !+++mhwang - .or. (precmixr_total(i,j,max(k-1,1))+precmixr_total(i,j,min(k,nz)))*0.5 > precthresh_trans) then !+++mhwang - select case (ndndraft) - case (1) !Only one threshold - if( ww(i,j,k) < wdown_thresh_k(k,1) ) then - maskdn(k,1) = 1 - end if - case (2) !Two thresholds, assumes 1st is stronger wind - if( ww(i,j,k) < wdown_thresh_k(k,1) ) then - maskdn(k,1) = 1 - else if( ww(i,j,k) < wdown_thresh_k(k,2) & - .and. ww(i,j,k) >= wdown_thresh_k(k,1) ) then - maskdn(k,2) = 1 - end if - end select - end if ! end cloudmixr_total, and precall +++mhwang - - !Transport quiescent at cell boundaries if neither up or - !down triggered... - if( sum(maskup(k,:))+sum(maskdn(k,:)) < 1 ) then - maskqu(k) = 1 - end if - - ! Cloudy or clear at cell boundaries... - if( (cloudmixr(i,j,max(k-1,1))+cloudmixr(i,j,min(k,nz)))*0.5 > cloudthresh ) then - maskcld_bnd(k) = 1 - else - maskclr_bnd(k) = 1 - end if - - ! Raining or not at cell boundaries... - if( (precall(i,j,max(k-1,1))+precall(i,j,min(k,nz)))*0.5 > prcpthresh ) then - maskpry_bnd(k) = 1 - else - maskprn_bnd(k) = 1 - end if - - end do !k - do k = 1,nz - - ! Cloudy or clear at cell centers... - if( cloudmixr(i,j,k) > cloudthresh ) then - maskcld(k) = 1 - else - maskclr(k) = 1 - end if - - ! Raining or not at cell centers... - if( precall(i,j,k) > prcpthresh ) then - maskpry(k) = 1 - else - maskprn(k) = 1 - end if - - end do !k -! -! Now, use the initial boundary masks by class to generate a combined -! mask for the cell boundaries. -! - do k = 1,nzstag - - !Upward, or at least upward quiescent - if( sum(maskup(k,:)) > 0 .or. & - (maskqu(k) > 0 .and. ww(i,j,k) > 0) ) then - - !Are we are here because of maskup? If so, then we need to - !parse the correct updraft category. - if( maskqu(k) < 1 ) then - itr = UP1 + maxloc(maskup(k,:),1)-1 - else - itr = QUI - end if - - !For upward motion, determine cloud and precip characteristics - !based on the cell-center values below the boundary. - if( k==1 ) then - icl = CLR - ipr = PRN - else - call cloud_prcp_check(maskcld, CLD, maskclr, CLR, k-1, icl, & - "setup_class_masks: bnd cloud up") - call cloud_prcp_check(maskpry, PRY, maskprn, PRN, k-1, ipr, & - "setup_class_masks: bnd prcp up") - end if - - !Downward, or at least downward quiescent - else if( sum(maskdn(k,:)) > 0 .or. & - (maskqu(k) > 0 .and. ww(i,j,k) < 0) ) then - - !Are we here because of maskdn? If so, then we need to - !parse the correct downdraft category. - if( maskqu(k) < 1 ) then - itr = DN1 + maxloc(maskdn(k,:),1)-1 - else - itr = QUI - end if - - !For downward motion, determine cloud and precip characteristics - !based on the cell-center values above the boundary. - if( k==nzstag ) then - icl = CLR - ipr = PRN - else - call cloud_prcp_check(maskcld, CLD, maskclr, CLR, k, icl, & - "setup_class_masks: bnd cloud down") - call cloud_prcp_check(maskpry, PRY, maskprn, PRN, k, ipr, & - "setup_class_masks: bnd prcp down") - end if - - !Quiescent with w=0. Use the cell-center values averaged - !surrounding the boundary for the cloud/prcp states. - else - itr = QUI - call cloud_prcp_check(maskcld_bnd, CLD, maskclr_bnd, CLR, k, icl, & - "setup_class_masks: bnd cloud quiescent") - call cloud_prcp_check(maskpry_bnd, PRY, maskprn_bnd, PRN, k, ipr, & - "setup_class_masks: bnd prcp quiescent") - end if - -! +++mhwang -! Total condensate and different thresholds are used to classify transport classes. So the following change -! is not needed anymore. Minghuai Wang, 2010-04-23. -! -! In the clear, and non-precipitating class, it is classified as quiescent class in the MMF simulation. -! If this is classed as updraft or downdraft in mode 16, this would lead to too much upraft and downdraft mass fluxes. -! Minghuai Wang, 2010-01-18 (Minghuai.Wang@pnl.gov) -! if(icl.eq.CLR .and. ipr.eq.PRN) then -! itr = QUI -! end if -!---mhwang - - !We have all the class indices determined so now we can set - !the correct mask location to 1. -! mask_bnd(i,j,k,icl,itr,ipr) = 1. -! use fractioal cloudiness in SAM - if(icl.eq.CLR) then - mask_bnd(i,j,k,icl,itr,ipr) = 1. - else if(icl.eq.CLD) then - mask_bnd(i,j,k,CLD,itr,ipr) = (cf3d(i,j,max(k-1,1))+cf3d(i,j,min(k, nz)))*0.5 - mask_bnd(i,j,k,CLR,itr,ipr) = 1. - (cf3d(i,j,max(k-1,1))+cf3d(i,j,min(k, nz)))*0.5 - end if - - - end do !k-loop mask for boundaries -! -! Now, use the initial boundary masks by class to generate a combined -! mask for the cell centers. We determine the transport class based on -! splitting the cell conceptually in half with the upper boundary -! influencing the top half of the cell and the bottom boundary the bottom -! half. Each contributes either 0 or 0.5 of the total contribution of the -! cell's transport. e.g. if both boundaries are upward, then the cell is -! fully an "up" transport cell. If the two boundaries are opposite, then -! the cell is weighted half in each direction for the masking. -! - do k = 1,nz - - !Get the cloud/prcp characteristics at cell center. - call cloud_prcp_check(maskcld, CLD, maskclr, CLR, k, icl) - call cloud_prcp_check(maskpry, PRY, maskprn, PRN, k, ipr) - - !Look at the bottom boundary first and determine it's - !contribution to the cell center transport class. - if( sum(maskup(k,:)) > 0 ) then - itr = UP1 + maxloc(maskup(k,:),1)-1 - else if( sum(maskdn(k,:)) > 0 ) then - itr = DN1 + maxloc(maskdn(k,:),1)-1 - else if( maskqu(k) > 0 ) then - itr = QUI - else - call endrun("ERROR: setup_class_masks: We should not be in this place for cell bottoms.") - stop - end if - -! +++mhwang -! ! Total condensate and different thresholds are used to classify transport classes. So the following change -! is not needed anymore. Minghuai Wang, 2010-04-23. - -! In the clear, and non-precipitating class, it is classified as quiescent class in the MMF simulation. -! If this is classed as updraft or downdraft in mode 16, this would lead to too much upraft and downdraft mass fluxes. -! Minghuai Wang, 2010-01-18 (Minghuai.Wang@pnl.gov) -! if(icl.eq.CLR .and. ipr.eq.PRN) then -! itr = QUI -! end if -!---mhwang - - !We have what we need for the cell bottom classes so increment - !the center mask for the bottom half... -! mask_cen(i,j,k,icl,itr,ipr) = mask_cen(i,j,k,icl,itr,ipr) + 0.5 -! Use fractional cloudiness at SAM - if(icl.eq.CLR) then - mask_cen(i,j,k,icl,itr,ipr) = mask_cen(i,j,k,icl,itr,ipr) + 0.5 - else if(icl.eq.CLD) then - mask_cen(i,j,k,CLD,itr,ipr) = mask_cen(i,j,k,CLD,itr,ipr) + (cf3d(i,j,k))*0.5 - mask_cen(i,j,k,CLR,itr,ipr) = mask_cen(i,j,k,CLR,itr,ipr) + (1. - cf3d(i,j,k)) * 0.5 - end if - - !Next, look at the top boundary and determine it's - !contribution to the cell center transport class. - if( sum(maskup(k+1,:)) > 0 ) then - itr = UP1 + maxloc(maskup(k+1,:),1)-1 - else if( sum(maskdn(k+1,:)) > 0 ) then - itr = DN1 + maxloc(maskdn(k+1,:),1)-1 - else if( maskqu(k+1) > 0 ) then - itr = QUI - else - call endrun("ERROR: setup_class_masks: We should not be in this place for cell tops.") - end if - -! +++mhwang -! In the clear, and non-precipitating class, it is classified as quiescent class in the MMF simulation. -! If this is classed as updraft or downdraft in mode 16, this would lead to too much upraft and downdraft mass fluxes. -! Minghuai Wang, 2010-01-18 (Minghuai.Wang@pnl.gov) -! if(icl.eq.CLR .and. ipr.eq.PRN) then -! itr = QUI -! end if -!---mhwang - - !We have what we need for the cell top classes so increment - !the center mask for the top half... -! mask_cen(i,j,k,icl,itr,ipr) = mask_cen(i,j,k,icl,itr,ipr) + 0.5 -! use fractional cloudiness in SAM - if(icl.eq.CLR) then - mask_cen(i,j,k,icl,itr,ipr) = mask_cen(i,j,k,icl,itr,ipr) + 0.5 - else if(icl.eq.CLD) then - mask_cen(i,j,k,CLD,itr,ipr) = mask_cen(i,j,k,CLD,itr,ipr) + (cf3d(i,j,k))*0.5 - mask_cen(i,j,k,CLR,itr,ipr) = mask_cen(i,j,k,CLR,itr,ipr) + (1. - cf3d(i,j,k)) * 0.5 - end if - - end do !k-loop mask for centers - - end do - end do XYLOOPS -end subroutine setup_class_masks - - -!------------------------------------------------------------------------ -subroutine cloud_prcp_check(mask1, flag1, mask2, flag2, k, iout, msg) -! -! Assigns the flag associated with the mask value that is true to the -! output index. The masks are assumed to be 1-D arrays and k is the -! position in the array to check. -! William.Gustafson@pnl.gov; 11-Sep-2008 -!------------------------------------------------------------------------ -! -! Soubroutine arguments... -! - integer, dimension(:), intent(in) :: mask1, mask2 - integer, intent(in) :: flag1, flag2, k - integer, intent(out) :: iout - character(len=*), optional :: msg -! -! Local var... -! - integer :: n -! -! Sanity check -! - n = ubound(mask1,1) - if( k < 1 .or. k > n) then - write(0, *) 'cloud_prcp_check', 'k =',k, ' n =',n - call endrun('ERROR: k out of bounds in cloud_prcp_check') - end if -! -! Whichever mask has the value 1 has the associated flag put into iout -! - if( mask1(k) > 0 .and. mask2(k) < 1 ) then - iout = flag1 - else if( mask2(k) > 0 .and. mask1(k) < 1) then - iout = flag2 - else - write(0, *) 'cloud_prcp_check', 'k =', k - call endrun("ERROR: neither mask dominates in cloud_prcp_check") - end if - -end subroutine cloud_prcp_check - -#endif /*ECPP*/ -end module crmx_module_ecpp_stats - diff --git a/src/physics/spcam/crm/crmx_params.F90 b/src/physics/spcam/crm/crmx_params.F90 deleted file mode 100644 index f825374c30..0000000000 --- a/src/physics/spcam/crm/crmx_params.F90 +++ /dev/null @@ -1,180 +0,0 @@ -module crmx_params - -use crmx_grid, only: nzm -#ifdef CLUBB_CRM -! Use the CLUBB values for these constants for consistency -use crmx_constants_clubb, only: Cp_clubb => Cp, grav_clubb => grav, Lv_clubb => Lv, Lf_clubb => Lf, & - Ls_clubb => Ls, Rv_clubb => Rv, Rd_clubb => Rd, pi_clubb => pi -#else - -#ifdef CRM -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 -#endif /*CRM*/ - -#endif - -implicit none - -! Constants: - -#ifdef CLUBB_CRM -! Define Cp, ggr, etc. in module constants_clubb -real, parameter :: cp = Cp_clubb -real, parameter :: ggr = grav_clubb -real, parameter :: lcond = Lv_clubb -real, parameter :: lfus = Lf_clubb -real, parameter :: lsub = Ls_clubb -real, parameter :: rv = Rv_clubb -real, parameter :: rgas= Rd_clubb -#else -#ifndef CRM -real, parameter :: cp = 1004. ! Specific heat of air, J/kg/K -real, parameter :: ggr = 9.81 ! Gravity acceleration, m/s2 -real, parameter :: lcond = 2.5104e+06 ! Latent heat of condensation, J/kg -real, parameter :: lfus = 0.3336e+06 ! Latent heat of fusion, J/kg -real, parameter :: lsub = 2.8440e+06 ! Latent heat of sublimation, J/kg -real, parameter :: rv = 461. ! Gas constant for water vapor, J/kg/K -real, parameter :: rgas = 287. ! Gas constant for dry air, J/kg/K -#else -real, parameter :: cp = shr_const_cpdair -real, parameter :: ggr = shr_const_g -real, parameter :: lcond = shr_const_latvap -real, parameter :: lfus = shr_const_latice -real, parameter :: lsub = lcond + lfus -real, parameter :: rv = shr_const_rgas/shr_const_mwwv -real, parameter :: rgas = shr_const_rdair -#endif -#endif -real, parameter :: diffelq = 2.21e-05 ! Diffusivity of water vapor, m2/s -real, parameter :: therco = 2.40e-02 ! Thermal conductivity of air, J/m/s/K -real, parameter :: muelq = 1.717e-05 ! Dynamic viscosity of air - -real, parameter :: fac_cond = lcond/cp -real, parameter :: fac_fus = lfus/cp -real, parameter :: fac_sub = lsub/cp - -#ifdef CLUBB_CRM -real, parameter :: pi = pi_clubb -#else -real, parameter :: pi = 3.141592653589793 -#endif - -! -! internally set parameters: - -real epsv ! = (1-eps)/eps, where eps= Rv/Ra, or =0. if dosmoke=.true. -logical:: dosubsidence = .false. -real fcorz ! Vertical Coriolis parameter -real coszrs - -!---------------------------------------------- -! Parameters set by PARAMETERS namelist: -! Initialized to default values. -!---------------------------------------------- - -real:: ug = 0. ! Velocity of the Domain's drift in x direction -real:: vg = 0. ! Velocity of the Domain's drift in y direction -real:: fcor = -999. ! Coriolis parameter -real:: longitude0 = 0. ! latitude of the domain's center -real:: latitude0 = 0. ! longitude of the domain's center -real:: nxco2 = 1 ! factor to modify co2 concentration -logical:: doradlat = .false. -logical:: doradlon = .false. - -real(kind=selected_real_kind(12)):: tabs_s =0. ! surface temperature,K -real:: delta_sst = 0. ! amplitude of sin-pattern of sst about tabs_s (ocean_type=1) -real:: depth_slab_ocean = 2. ! thickness of the slab-ocean (m) -real:: Szero = 0. ! mean ocean transport (W/m2) -real:: deltaS = 0. ! amplitude of linear variation of ocean transport (W/m2) -real:: timesimpleocean = 0. ! time to start simple ocean - -real:: fluxt0 =0. ! surface sensible flux, Km/s -real:: fluxq0 =0. ! surface latent flux, m/s -real:: tau0 =0. ! surface stress, m2/s2 -real:: z0 =0.035 ! roughness length -real:: soil_wetness =1.! wetness coeff for soil (from 0 to 1.) -integer:: ocean_type =0 ! type of SST forcing -logical:: cem =.false. ! flag for Cloud Ensemble Model -logical:: les =.false. ! flag for Large-Eddy Simulation -logical:: ocean =.false. ! flag indicating that surface is water -logical:: land =.false. ! flag indicating that surface is land -logical:: sfc_flx_fxd =.false. ! surface sensible flux is fixed -logical:: sfc_tau_fxd =.false.! surface drag is fixed - -real:: timelargescale =0. ! time to start large-scale forcing - -! nudging boundaries (between z1 and z2, where z2 > z1): -real:: nudging_uv_z1 =-1., nudging_uv_z2 = 1000000. -real:: nudging_t_z1 =-1., nudging_t_z2 = 1000000. -real:: nudging_q_z1 =-1., nudging_q_z2 = 1000000. -real:: tauls = 99999999. ! nudging-to-large-scaler-profile time-scale -real:: tautqls = 99999999.! nudging-to-large-scaler-profile time-scale for scalars - -logical:: dodamping = .false. -logical:: doupperbound = .false. -logical:: docloud = .false. -logical:: doclubb = .false. ! Enabled the CLUBB parameterization (interactively) -logical:: doclubb_sfc_fluxes = .false. ! Apply the surface fluxes within the CLUBB code rather than SAM -logical:: doclubbnoninter = .false. ! Enable the CLUBB parameterization (non-interactively) -logical:: docam_sfc_fluxes = .false. ! Apply the surface fluxes within CAM -logical:: doprecip = .false. -logical:: dolongwave = .false. -logical:: doshortwave = .false. -logical:: dosgs = .false. -logical:: docoriolis = .false. -logical:: docoriolisz = .false. -logical:: dofplane = .true. -logical:: dosurface = .false. -logical:: dolargescale = .false. -logical:: doradforcing = .false. -logical:: dosfcforcing = .false. -logical:: doradsimple = .false. -logical:: donudging_uv = .false. -logical:: donudging_tq = .false. -logical:: donudging_t = .false. -logical:: donudging_q = .false. -logical:: doensemble = .false. -logical:: dowallx = .false. -logical:: dowally = .false. -logical:: docolumn = .false. -logical:: docup = .false. -logical:: doperpetual = .false. -logical:: doseasons = .false. -logical:: doradhomo = .false. -logical:: dosfchomo = .false. -logical:: dossthomo = .false. -logical:: dodynamicocean = .false. -logical:: dosolarconstant = .false. -logical:: dotracers = .false. -logical:: dosmoke = .false. -logical:: notracegases = .false. - -! Specify solar constant and zenith angle for perpetual insolation. -! Based onn Tompkins and Graig (1998) -! Note that if doperpetual=.true. and dosolarconstant=.false. -! the insolation will be set to the daily-averaged value on day0. -real:: solar_constant = 685. ! solar constant (in W/m2) -real:: zenith_angle = 51.7 ! zenith angle (in degrees) - -integer:: nensemble =0 ! the number of subensemble set of perturbations -integer:: perturb_type = 0 ! type of initial noise in setperturb() -integer:: nclubb = 1 ! SAM timesteps per CLUBB timestep -! Initial bubble parameters. Activated when perturb_type = 2 - real:: bubble_x0 = 0. - real:: bubble_y0 = 0. - real:: bubble_z0 = 0. - real:: bubble_radius_hor = 0. - real:: bubble_radius_ver = 0. - real:: bubble_dtemp = 0. - real:: bubble_dq = 0. - -real uhl ! current large-scale velocity in x near sfc -real vhl ! current large-scale velocity in y near sfc -real :: taux0 = 0. ! surface stress in x, m2/s2 -real :: tauy0 = 0. ! surface stress in y, m2/s2 - -end module crmx_params diff --git a/src/physics/spcam/crm/crmx_periodic.F90 b/src/physics/spcam/crm/crmx_periodic.F90 deleted file mode 100644 index d0126e21ee..0000000000 --- a/src/physics/spcam/crm/crmx_periodic.F90 +++ /dev/null @@ -1,107 +0,0 @@ - -subroutine periodic(flag) - -use crmx_vars -use crmx_microphysics -use crmx_sgs -use crmx_params, only: dotracers, dosgs -use crmx_crmtracers -#ifdef CLUBB_CRM -use crmx_params, only: doclubb, doclubbnoninter -#endif -implicit none - -integer flag, i - -if(flag.eq.0) then - - call bound_exchange(u,dimx1_u,dimx2_u,dimy1_u,dimy2_u,nzm,1,1,1,1,1) - call bound_exchange(v,dimx1_v,dimx2_v,dimy1_v,dimy2_v,nzm,1,1,1,1,2) - ! use w at the top level - 0s anyway - to exchange the sst boundaries (for - ! surface fluxes call - w(1:nx,1:ny,nz) = sstxy(1:nx,1:ny) - call bound_exchange(w,dimx1_w,dimx2_w,dimy1_w,dimy2_w,nz,1,1,1,1,3) - sstxy(0:nx,1-YES3D:ny) = w(0:nx,1-YES3D:ny,nz) - w(0:nx+1,1-YES3D:ny+YES3D,nz) = 0. - -endif - - -if(flag.eq.2) then - - call bound_exchange(u,dimx1_u,dimx2_u,dimy1_u,dimy2_u,nzm,2,3,2+NADV,2+NADV,1) - call bound_exchange(v,dimx1_v,dimx2_v,dimy1_v,dimy2_v,nzm,2+NADV,2+NADV,2,3,2) - call bound_exchange(w,dimx1_w,dimx2_w,dimy1_w,dimy2_w,nz,2+NADV,2+NADV,2+NADV,2+NADV,3) - - call bound_exchange(t,dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm,3+NADVS,3+NADVS,3+NADVS,3+NADVS,4) - do i = 1,nsgs_fields - if(dosgs.and.advect_sgs) & - call bound_exchange(sgs_field(:,:,:,i),dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm, & - 3+NADVS,3+NADVS,3+NADVS,3+NADVS,4+i) - end do - do i = 1,nmicro_fields - if( i.eq.index_water_vapor & -#ifdef CLUBB_CRM - ! Vince Larson (UWM) changed so that bound_exchange is called even if - ! docloud = .false. and doclubb = .true. 11 Nov 2007 - .or. (docloud.or.doclubb.or.doclubbnoninter) .and.flag_precip(i).ne.1 & -#else - .or. docloud.and.flag_precip(i).ne.1 & -#endif - .or. doprecip.and.flag_precip(i).eq.1 ) & - call bound_exchange(micro_field(:,:,:,i),dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm, & - 3+NADVS,3+NADVS,3+NADVS,3+NADVS,4+nsgs_fields+nsgs_fields_diag+i) - end do - if(dotracers) then - do i=1,ntracers - call bound_exchange(tracer(:,:,:,i),dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm, & - 3+NADVS,3+NADVS,3+NADVS,3+NADVS,4+nsgs_fields+nsgs_fields_diag+nmicro_fields+i) - end do - end if - -endif - -if(flag.eq.3) then - - call bound_exchange(t,dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm,1,1,1,1,4) - do i = 1,nsgs_fields - if(dosgs.and.advect_sgs) & - call bound_exchange(sgs_field(:,:,:,i),dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm,1,1,1,1,4+i) - end do - do i = 1,nmicro_fields - if( i.eq.index_water_vapor & -#ifdef CLUBB_CRM - ! Vince Larson (UWM) changed so that bound_exchange is called even if - ! docloud = .false. and doclubb = .true. 11 Nov 2007 - .or. (docloud.or.doclubb.or.doclubbnoninter) .and.flag_precip(i).ne.1 & -#else - .or. docloud.and.flag_precip(i).ne.1 & -#endif - .or. doprecip.and.flag_precip(i).eq.1 ) & - call bound_exchange(micro_field(:,:,:,i),dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm, & - 1,1,1,1,4+nsgs_fields+nsgs_fields_diag+i) - end do - if(dotracers) then - do i=1,ntracers - call bound_exchange(tracer(:,:,:,i),dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm, & - 1,1,1,1,4+nsgs_fields+nsgs_fields_diag+nmicro_fields+i) - end do - end if - -endif - -if(flag.eq.4) then - - do i = 1,nsgs_fields_diag - if(dosgs.and.do_sgsdiag_bound) & - call bound_exchange(sgs_field_diag(:,:,:,i),dimx1_d,dimx2_d,dimy1_d,dimy2_d,nzm, & - 1+dimx1_d,dimx2_d-nx,YES3D+dimy1_d,1-YES3D+dimy2_d-ny,4+nsgs_fields+i) - end do - -end if - - - - -end subroutine periodic - diff --git a/src/physics/spcam/crm/crmx_precip_fall.F90 b/src/physics/spcam/crm/crmx_precip_fall.F90 deleted file mode 100644 index fb81395cee..0000000000 --- a/src/physics/spcam/crm/crmx_precip_fall.F90 +++ /dev/null @@ -1,229 +0,0 @@ -subroutine precip_fall(qp, term_vel, hydro_type, omega, ind) - -! positively definite monotonic advection with non-oscillatory option -! and gravitational sedimentation - -use crmx_vars -use crmx_params -implicit none - - - -real qp(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! falling hydrometeor -integer hydro_type ! 0 - all liquid, 1 - all ice, 2 - mixed -real omega(nx,ny,nzm) ! = 1: liquid, = 0: ice; = 0-1: mixed : used only when hydro_type=2 -integer ind - -! Terminal velocity fnction - -real, external :: term_vel ! terminal velocity function - - -! Local: - -real mx(nzm),mn(nzm), lfac(nz) -real www(nz),fz(nz) -real df(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) -real f0(nzm),df0(nzm) -real eps -integer i,j,k,kc,kb -logical nonos - -real y,pp,pn -pp(y)= max(0.,y) -pn(y)=-min(0.,y) - -real lat_heat, wmax - -real wp(nzm), tmp_qp(nzm), irhoadz(nzm), iwmax(nzm), rhofac(nzm), prec_cfl -integer nprec, iprec -real flagstat - -!-------------------------------------------------------- - -!call t_startf ('precip_fall') - -eps = 1.e-10 -nonos = .true. - - do k = 1,nzm - rhofac(k) = sqrt(1.29/rho(k)) - irhoadz(k) = 1./(rho(k)*adz(k)) ! Useful factor - kb = max(1,k-1) - wmax = dz*adz(kb)/dtn ! Velocity equivalent to a cfl of 1.0. - iwmax(k) = 1./wmax - end do - -! Add sedimentation of precipitation field to the vert. vel. - -do j=1,ny - do i=1,nx - - ! Compute precipitation velocity and flux column-by-column - - prec_cfl = 0. - - do k=1,nzm - - select case (hydro_type) - case(0) - lfac(k) = fac_cond - flagstat = 1. - case(1) - lfac(k) = fac_sub - flagstat = 1. - case(2) - lfac(k) = fac_cond + (1-omega(i,j,k))*fac_fus - flagstat = 1. - case(3) - lfac(k) = 0. - flagstat = 0. - case default - if(masterproc) then - print*, 'unknown hydro_type in precip_fall. exitting ...' - call task_abort - end if - end select - - wp(k)=rhofac(k)*term_vel(i,j,k,ind) - prec_cfl = max(prec_cfl,wp(k)*iwmax(k)) ! Keep column maximum CFL - wp(k) = -wp(k)*rhow(k)*dtn/dz - - end do ! k - - fz(nz)=0. - www(nz)=0. - lfac(nz)=0 - - ! If maximum CFL due to precipitation velocity is greater than 0.9, - ! take more than one advection step to maintain stability. - if (prec_cfl.gt.0.9) then - nprec = CEILING(prec_cfl/0.9) - do k = 1,nzm - ! wp already includes factor of dt, so reduce it by a - ! factor equal to the number of precipitation steps. - wp(k) = wp(k)/float(nprec) - end do - else - nprec = 1 - end if - - do iprec = 1,nprec - - do k = 1,nzm - tmp_qp(k) = qp(i,j,k) ! Temporary array for qp in this column - end do - - !----------------------------------------- - - if(nonos) then - - do k=1,nzm - kc=min(nzm,k+1) - kb=max(1,k-1) - mx(k)=max(tmp_qp(kb),tmp_qp(kc),tmp_qp(k)) - mn(k)=min(tmp_qp(kb),tmp_qp(kc),tmp_qp(k)) - end do - - end if ! nonos - - ! loop over iterations - - do k=1,nzm - ! Define upwind precipitation flux - fz(k)=tmp_qp(k)*wp(k) - end do - - do k=1,nzm - kc=k+1 - tmp_qp(k)=tmp_qp(k)-(fz(kc)-fz(k))*irhoadz(k) !Update temporary qp - end do - - do k=1,nzm - ! Also, compute anti-diffusive correction to previous - ! (upwind) approximation to the flux - kb=max(1,k-1) - ! The precipitation velocity is a cell-centered quantity, - ! since it is computed from the cell-centered - ! precipitation mass fraction. Therefore, a reformulated - ! anti-diffusive flux is used here which accounts for - ! this and results in reduced numerical diffusion. - www(k) = 0.5*(1.+wp(k)*irhoadz(k)) & - *(tmp_qp(kb)*wp(kb) - tmp_qp(k)*wp(k)) ! works for wp(k)<0 - end do - - !---------- non-osscilatory option --------------- - - if(nonos) then - - do k=1,nzm - kc=min(nzm,k+1) - kb=max(1,k-1) - mx(k)=max(tmp_qp(kb),tmp_qp(kc),tmp_qp(k),mx(k)) - mn(k)=min(tmp_qp(kb),tmp_qp(kc),tmp_qp(k),mn(k)) - end do - - do k=1,nzm - kc=min(nzm,k+1) - mx(k)=rho(k)*adz(k)*(mx(k)-tmp_qp(k))/(pn(www(kc)) + pp(www(k))+eps) - mn(k)=rho(k)*adz(k)*(tmp_qp(k)-mn(k))/(pp(www(kc)) + pn(www(k))+eps) - end do - - do k=1,nzm - kb=max(1,k-1) - ! Add limited flux correction to fz(k). - fz(k) = fz(k) & ! Upwind flux - + pp(www(k))*min(1.,mx(k), mn(kb)) & - - pn(www(k))*min(1.,mx(kb),mn(k)) ! Anti-diffusive flux - end do - - endif ! nonos - - ! Update precipitation mass fraction and liquid-ice static - ! energy using precipitation fluxes computed in this column. - do k=1,nzm - kc=k+1 - ! Update precipitation mass fraction. - ! Note that fz is the total flux, including both the - ! upwind flux and the anti-diffusive correction. - qp(i,j,k)=qp(i,j,k)-(fz(kc)-fz(k))*irhoadz(k) - qpfall(k)=qpfall(k)-(fz(kc)-fz(k))*irhoadz(k)*flagstat ! For qp budget - lat_heat = -(lfac(kc)*fz(kc)-lfac(k)*fz(k))*irhoadz(k) - t(i,j,k)=t(i,j,k)-lat_heat - tlat(k)=tlat(k)-lat_heat ! For energy budget - precflux(k) = precflux(k) - fz(k)*flagstat ! For statistics - end do - precsfc(i,j) = precsfc(i,j) - fz(1)*flagstat ! For statistics - precssfc(i,j) = precssfc(i,j) - fz(1)*(1.-omega(i,j,1))*flagstat ! For statistics - prec_xy(i,j) = prec_xy(i,j) - fz(1)*flagstat ! For 2D output - - if (iprec.lt.nprec) then - - ! Re-compute precipitation velocity using new value of qp. - do k=1,nzm - wp(k) = rhofac(k)*term_vel(i,j,k,ind) - ! Decrease precipitation velocity by factor of nprec - wp(k) = -wp(k)*rhow(k)*dtn/dz/float(nprec) - ! Note: Don't bother checking CFL condition at each - ! substep since it's unlikely that the CFL will - ! increase very much between substeps when using - ! monotonic advection schemes. - end do - - fz(nz)=0. - www(nz)=0. - lfac(nz)=0. - - end if - - end do !iprec - - end do -end do - - -!call t_stopf ('precip_fall') - -end subroutine precip_fall - - diff --git a/src/physics/spcam/crm/crmx_press_grad.F90 b/src/physics/spcam/crm/crmx_press_grad.F90 deleted file mode 100644 index f8dbd12da5..0000000000 --- a/src/physics/spcam/crm/crmx_press_grad.F90 +++ /dev/null @@ -1,69 +0,0 @@ - -subroutine press_grad - -! pressure term of the momentum equations - -use crmx_vars -use crmx_params, only: dowallx, dowally -implicit none - -real *8 rdx,rdy,rdz -integer i,j,k,kb,jb,ib - -rdx=1./dx -rdy=1./dy - -do k=1,nzm - kb=max(1,k-1) - rdz = 1./(dz*adzw(k)) - do j=1,ny - jb=j-YES3D - do i=1,nx - ib=i-1 - dudt(i,j,k,na)=dudt(i,j,k,na)-(p(i,j,k)-p(ib,j,k))*rdx - dvdt(i,j,k,na)=dvdt(i,j,k,na)-(p(i,j,k)-p(i,jb,k))*rdy - dwdt(i,j,k,na)=dwdt(i,j,k,na)-(p(i,j,k)-p(i,j,kb))*rdz - end do ! i - end do ! j -end do ! k - -do k=1,nzm - do j=1-YES3D,ny !bloss: 0,n* fixes computation of dp/d* in stats. - do i=0,nx - p(i,j,k)=p(i,j,k)*rho(k) ! convert p'/rho to p' - end do - end do -end do - -if(dowallx.and.mod(rank,nsubdomains_x).eq.0) then - - do k=1,nzm - do j=1,ny - dudt(1,j,k,na) = 0. - end do - end do - -end if - -if(dowally.and.RUN3D.and.rank.lt.nsubdomains_x) then - - do k=1,nzm - do i=1,nx - dvdt(i,1,k,na) = 0. - end do - end do - -end if - -if(dompi) then - call task_bound_duvdt() -else - call bound_duvdt() -endif - -call task_barrier() - -end subroutine press_grad - - - diff --git a/src/physics/spcam/crm/crmx_press_rhs.F90 b/src/physics/spcam/crm/crmx_press_rhs.F90 deleted file mode 100644 index 215a06bc13..0000000000 --- a/src/physics/spcam/crm/crmx_press_rhs.F90 +++ /dev/null @@ -1,105 +0,0 @@ - -subroutine press_rhs - -! right-hand-side of the Poisson equation for pressure - -use crmx_vars -use crmx_params, only: dowallx, dowally - -implicit none - - -real *8 dta,rdx,rdy,rdz,btat,ctat,rup,rdn -integer i,j,k,ic,jc,kc - -if(dowallx.and.mod(rank,nsubdomains_x).eq.0) then - - do k=1,nzm - do j=1,ny - dudt(1,j,k,na) = 0. - end do - end do - -end if - -if(dowally.and.RUN3D.and.rank.lt.nsubdomains_x) then - - do k=1,nzm - do i=1,nx - dvdt(i,1,k,na) = 0. - end do - end do - -end if - - -if(dompi) then - call task_bound_duvdt() -else - call bound_duvdt() -endif - -dta=1./dt3(na)/at -rdx=1./dx -rdy=1./dy -btat=bt/at -ctat=ct/at - -if(RUN3D) then - -do k=1,nzm - kc=k+1 - rdz=1./(adz(k)*dz) - rup = rhow(kc)/rho(k)*rdz - rdn = rhow(k)/rho(k)*rdz - do j=1,ny - jc=j+1 - do i=1,nx - ic=i+1 - p(i,j,k)=(rdx*(u(ic,j,k)-u(i,j,k))+ & - rdy*(v(i,jc,k)-v(i,j,k))+ & - (w(i,j,kc)*rup-w(i,j,k)*rdn) )*dta + & - (rdx*(dudt(ic,j,k,na)-dudt(i,j,k,na))+ & - rdy*(dvdt(i,jc,k,na)-dvdt(i,j,k,na))+ & - (dwdt(i,j,kc,na)*rup-dwdt(i,j,k,na)*rdn) ) + & - btat*(rdx*(dudt(ic,j,k,nb)-dudt(i,j,k,nb))+ & - rdy*(dvdt(i,jc,k,nb)-dvdt(i,j,k,nb))+ & - (dwdt(i,j,kc,nb)*rup-dwdt(i,j,k,nb)*rdn) ) + & - ctat*(rdx*(dudt(ic,j,k,nc)-dudt(i,j,k,nc))+ & - rdy*(dvdt(i,jc,k,nc)-dvdt(i,j,k,nc))+ & - (dwdt(i,j,kc,nc)*rup-dwdt(i,j,k,nc)*rdn) ) - p(i,j,k)=p(i,j,k)*rho(k) - end do - end do -end do - - -else - -j=1 - -do k=1,nzm - kc=k+1 - rdz=1./(adz(k)*dz) - rup = rhow(kc)/rho(k)*rdz - rdn = rhow(k)/rho(k)*rdz - do i=1,nx - ic=i+1 - p(i,j,k)=(rdx*(u(ic,j,k)-u(i,j,k))+ & - (w(i,j,kc)*rup-w(i,j,k)*rdn) )*dta + & - (rdx*(dudt(ic,j,k,na)-dudt(i,j,k,na))+ & - (dwdt(i,j,kc,na)*rup-dwdt(i,j,k,na)*rdn) ) + & - btat*(rdx*(dudt(ic,j,k,nb)-dudt(i,j,k,nb))+ & - (dwdt(i,j,kc,nb)*rup-dwdt(i,j,k,nb)*rdn) ) + & - ctat*(rdx*(dudt(ic,j,k,nc)-dudt(i,j,k,nc))+ & - (dwdt(i,j,kc,nc)*rup-dwdt(i,j,k,nc)*rdn) ) - p(i,j,k)=p(i,j,k)*rho(k) - end do -end do - - -endif - -call task_barrier() - -end subroutine press_rhs diff --git a/src/physics/spcam/crm/crmx_pressure.F90 b/src/physics/spcam/crm/crmx_pressure.F90 deleted file mode 100644 index d8376e782d..0000000000 --- a/src/physics/spcam/crm/crmx_pressure.F90 +++ /dev/null @@ -1,517 +0,0 @@ -! Non-blocking receives before blocking sends - -subroutine pressure - -! Original pressure solver based on horizontal slabs -! (C) 1998, 2002 Marat Khairoutdinov -! Works only when the number of slabs is equal to the number of processors. -! Therefore, the number of processors shouldn't exceed the number of levels nzm -! Also, used for a 2D version -! For more processors for the given number of levels and 3D, use pressure_big - -use crmx_vars -use crmx_params, only: dowallx, dowally, docolumn -implicit none - - -integer, parameter :: npressureslabs = nsubdomains -integer, parameter :: nzslab = max(1,nzm / npressureslabs) -integer, parameter :: nx2=nx_gl+2, ny2=ny_gl+2*YES3D -integer, parameter :: n3i=3*nx_gl/2+1,n3j=3*ny_gl/2+1 - -real f(nx2,ny2,nzslab) ! global rhs and array for FTP coefficeients -real ff(nx+1,ny+2*YES3D,nzm) ! local (subdomain's) version of f -real buff_slabs(nxp1,nyp2,nzslab,npressureslabs) -real buff_subs(nxp1,nyp2,nzslab,nsubdomains) -real bufp_slabs(0:nx,1-YES3D:ny,nzslab,npressureslabs) -real bufp_subs(0:nx,1-YES3D:ny,nzslab,nsubdomains) -common/tmpstack/f,ff,buff_slabs,buff_subs -equivalence (buff_slabs,bufp_slabs) -equivalence (buff_subs,bufp_subs) - -real work(nx2,ny2),trigxi(n3i),trigxj(n3j) ! FFT stuff -integer ifaxj(100),ifaxi(100) - -real(kind=selected_real_kind(12)) a(nzm),b,c(nzm),e,fff(nzm) -real(kind=selected_real_kind(12)) xi,xj,xnx,xny,ddx2,ddy2,pii,factx,facty,eign -real(kind=selected_real_kind(12)) alfa(nzm-1),beta(nzm-1) - -integer reqs_in(nsubdomains) -integer i, j, k, id, jd, m, n, it, jt, ii, jj, tag, rf -integer nyp22, n_in, count -integer iii(0:nx_gl),jjj(0:ny_gl) -logical flag(nsubdomains) -integer iwall,jwall -integer,parameter :: DBL = selected_real_kind(12) - -! check if the grid size allows the computation: - -if(nsubdomains.gt.nzm) then - if(masterproc) print*,'pressure_orig: nzm < nsubdomains. STOP' - call task_abort -endif - -if(mod(nzm,npressureslabs).ne.0) then - if(masterproc) print*,'pressure_orig: nzm/npressureslabs is not round number. STOP' - call task_abort -endif - -!----------------------------------------------------------------- - -if(docolumn) return - -if(dowallx) then - iwall=1 -else - iwall=0 -end if -if(RUN2D) then - nyp22=1 - jwall=0 -else - nyp22=nyp2 - if(dowally) then - jwall=2 - else - jwall=0 - end if -endif - -!----------------------------------------------------------------- -! Compute the r.h.s. of the Poisson equation for pressure - -call press_rhs() - - -!----------------------------------------------------------------- -! Form the horizontal slabs of right-hand-sides of Poisson equation -! for the global domain. Request sending and receiving tasks. - -! iNon-blocking receive first: - -n_in = 0 -do m = 0,nsubdomains-1 - - if(rank.lt.npressureslabs.and.m.ne.nsubdomains-1) then - - n_in = n_in + 1 - call task_receive_float(bufp_subs(0,1-YES3D,1,n_in), & - nzslab*nxp1*nyp1,reqs_in(n_in)) - flag(n_in) = .false. - - endif - - if(rank.lt.npressureslabs.and.m.eq.nsubdomains-1) then - - call task_rank_to_index(rank,it,jt) - n = rank*nzslab - do k = 1,nzslab - do j = 1,ny - do i = 1,nx - f(i+it,j+jt,k) = p(i,j,k+n) - end do - end do - end do - endif - -end do ! m - - -! Blocking send now: - - -do m = 0,nsubdomains-1 - - if(m.lt.npressureslabs.and.m.ne.rank) then - - n = m*nzslab + 1 - call task_bsend_float(m,p(0,1-YES3D,n),nzslab*nxp1*nyp1, 33) - endif - -end do ! m - - -! Fill slabs when receive buffers are full: - -count = n_in -do while (count .gt. 0) - do m = 1,n_in - if(.not.flag(m)) then - call task_test(reqs_in(m), flag(m), rf, tag) - if(flag(m)) then - count=count-1 - call task_rank_to_index(rf,it,jt) - do k = 1,nzslab - do j = 1,ny - do i = 1,nx - f(i+it,j+jt,k) = bufp_subs(i,j,k,m) - end do - end do - end do - endif - endif - end do -end do - - -!------------------------------------------------- -! Perform Fourier transformation for a slab: - -if(rank.lt.npressureslabs) then - - call fftfax_crm(nx_gl,ifaxi,trigxi) - if(RUN3D) call fftfax_crm(ny_gl,ifaxj,trigxj) - - do k=1,nzslab - - call fft991_crm(f(1,1,k),work,trigxi,ifaxi,1,nx2,nx_gl,ny_gl,-1) - - if(RUN3D) then - call fft991_crm(f(1,1,k),work,trigxj,ifaxj,nx2,1,ny_gl,nx_gl+1,-1) - end if - - end do - -endif - - -! Synchronize all slabs: - -call task_barrier() - -!------------------------------------------------- -! Send Fourier coeffiecients back to subdomains: - -! Non-blocking receive first: - -n_in = 0 -do m = 0, nsubdomains-1 - - call task_rank_to_index(m,it,jt) - - if(rank.lt.npressureslabs.and.m.eq.rank) then - - n = rank*nzslab - do k = 1,nzslab - do j = 1,nyp22-jwall - do i = 1,nxp1-iwall - ff(i,j,k+n) = f(i+it,j+jt,k) - end do - end do - end do - - end if - - if(m.lt.npressureslabs-1.or.m.eq.npressureslabs-1 & - .and.rank.ge.npressureslabs) then - - n_in = n_in + 1 - call task_receive_float(buff_slabs(1,1,1,n_in), & - nzslab*nxp1*nyp22,reqs_in(n_in)) - flag(n_in) = .false. - endif - -end do ! m - -! Blocking send now: - -do m = 0, nsubdomains-1 - - call task_rank_to_index(m,it,jt) - - if(rank.lt.npressureslabs.and.m.ne.rank) then - - do k = 1,nzslab - do j = 1,nyp22 - do i = 1,nxp1 - buff_subs(i,j,k,1) = f(i+it,j+jt,k) - end do - end do - end do - - call task_bsend_float(m, buff_subs(1,1,1,1),nzslab*nxp1*nyp22,44) - - endif - -end do ! m - - - -! Fill slabs when receive buffers are complete: - - -count = n_in -do while (count .gt. 0) - do m = 1,n_in - if(.not.flag(m)) then - call task_test(reqs_in(m), flag(m), rf, tag) - if(flag(m)) then - count=count-1 - n = rf*nzslab - do k = 1,nzslab - do j=1,nyp22 - do i=1,nxp1 - ff(i,j,k+n) = buff_slabs(i,j,k,m) - end do - end do - end do - endif - endif - end do -end do - -!------------------------------------------------- -! Solve the tri-diagonal system for Fourier coeffiecients -! in the vertical for each subdomain: - -do k=1,nzm - a(k)=rhow(k)/(adz(k)*adzw(k)*dz*dz) - c(k)=rhow(k+1)/(adz(k)*adzw(k+1)*dz*dz) -end do - -call task_rank_to_index(rank,it,jt) - -ddx2=1._DBL/(dx*dx) -ddy2=1._DBL/(dy*dy) -pii = acos(-1._DBL) -xnx=pii/nx_gl -xny=pii/ny_gl -do j=1,nyp22-jwall - if(dowally) then - jd=j+jt-1 - facty = 1.d0 - else - jd=(j+jt-0.1)/2. - facty = 2.d0 - end if - xj=jd - do i=1,nxp1-iwall - if(dowallx) then - id=i+it-1 - factx = 1.d0 - else - id=(i+it-0.1)/2. - factx = 2.d0 - end if - fff(1:nzm) = ff(i,j,1:nzm) - xi=id - eign=(2._DBL*cos(factx*xnx*xi)-2._DBL)*ddx2+ & - (2._DBL*cos(facty*xny*xj)-2._DBL)*ddy2 - if(id+jd.eq.0) then - b=1._DBL/(eign*rho(1)-a(1)-c(1)) - alfa(1)=-c(1)*b - beta(1)=fff(1)*b - else - b=1._DBL/(eign*rho(1)-c(1)) - alfa(1)=-c(1)*b - beta(1)=fff(1)*b - end if - do k=2,nzm-1 - e=1._DBL/(eign*rho(k)-a(k)-c(k)+a(k)*alfa(k-1)) - alfa(k)=-c(k)*e - beta(k)=(fff(k)-a(k)*beta(k-1))*e - end do - - fff(nzm)=(fff(nzm)-a(nzm)*beta(nzm-1))/ & - (eign*rho(nzm)-a(nzm)+a(nzm)*alfa(nzm-1)) - - do k=nzm-1,1,-1 - fff(k)=alfa(k)*fff(k+1)+beta(k) - end do - ff(i,j,1:nzm) = fff(1:nzm) - - end do -end do - -call task_barrier() - -!----------------------------------------------------------------- -! Send the Fourier coefficient to the tasks performing -! the inverse Fourier transformation: - -! Non-blocking receive first: - -n_in = 0 -do m = 0,nsubdomains-1 - - if(rank.lt.npressureslabs.and.m.ne.nsubdomains-1) then - n_in = n_in + 1 - call task_receive_float(buff_subs(1,1,1,n_in), & - nzslab*nxp1*nyp22, reqs_in(n_in)) - flag(n_in) = .false. - endif - - if(rank.lt.npressureslabs.and.m.eq.nsubdomains-1) then - - call task_rank_to_index(rank,it,jt) - n = rank*nzslab - do k = 1,nzslab - do j = 1,nyp22-jwall - do i = 1,nxp1-iwall - f(i+it,j+jt,k) = ff(i,j,k+n) - end do - end do - end do - - endif - -end do ! m - -! Blocking send now: - -do m = 0,nsubdomains-1 - - if(m.lt.npressureslabs.and.m.ne.rank) then - n = m*nzslab+1 - call task_bsend_float(m,ff(1,1,n),nzslab*nxp1*nyp22, 33) - endif - -end do ! m - - -! Fill slabs when receive buffers are full: - - -count = n_in -do while (count .gt. 0) - do m = 1,n_in - if(.not.flag(m)) then - call task_test(reqs_in(m), flag(m), rf, tag) - if(flag(m)) then - count=count-1 - call task_rank_to_index(rf,it,jt) - do k = 1,nzslab - do j = 1,nyp22-jwall - do i = 1,nxp1-iwall - f(i+it,j+jt,k) = buff_subs(i,j,k,m) - end do - end do - end do - endif - endif - end do -end do - -!------------------------------------------------- -! Perform inverse Fourier transformation: - -if(rank.lt.npressureslabs) then - - do k=1,nzslab - - if(RUN3D) then - call fft991_crm(f(1,1,k),work,trigxj,ifaxj,nx2,1,ny_gl,nx_gl+1,+1) - end if - - call fft991_crm(f(1,1,k),work,trigxi,ifaxi,1,nx2,nx_gl,ny_gl,+1) - - end do - -endif - -call task_barrier() - -!----------------------------------------------------------------- -! Fill the pressure field for each subdomain: - -do i=1,nx_gl - iii(i)=i -end do -iii(0)=nx_gl -do j=1,ny_gl - jjj(j)=j -end do -jjj(0)=ny_gl - -! Non-blocking receive first: - -n_in = 0 -do m = 0, nsubdomains-1 - - call task_rank_to_index(m,it,jt) - - if(m.lt.npressureslabs-1.or. & - m.eq.npressureslabs-1.and.rank.ge.npressureslabs) then - - n_in = n_in + 1 - call task_receive_float(bufp_slabs(0,1-YES3D,1,n_in), & - nzslab*nxp1*nyp1, reqs_in(n_in)) - flag(n_in) = .false. - - endif - - if(rank.lt.npressureslabs.and.m.eq.rank) then - - n = rank*nzslab - do k = 1,nzslab - do j = 1-YES3D,ny - jj=jjj(j+jt) - do i = 0,nx - ii=iii(i+it) - p(i,j,k+n) = f(ii,jj,k) - end do - end do - end do - - end if - -end do ! m - - -! Blocking send now: - -do m = 0, nsubdomains-1 - - call task_rank_to_index(m,it,jt) - - if(rank.lt.npressureslabs.and.m.ne.rank) then - - do k = 1,nzslab - do j = 1-YES3D,ny - jj=jjj(j+jt) - do i = 0,nx - ii=iii(i+it) - bufp_subs(i,j,k,1) = f(ii,jj,k) - end do - end do - end do - - call task_bsend_float(m, bufp_subs(0,1-YES3D,1,1), nzslab*nxp1*nyp1,44) - - endif - -end do ! m - -! Fill the receive buffers: - -count = n_in -do while (count .gt. 0) - do m = 1,n_in - if(.not.flag(m)) then - call task_test(reqs_in(m), flag(m), rf, tag) - if(flag(m)) then - count=count-1 - n = rf*nzslab - do k = 1,nzslab - do j=1-YES3D,ny - do i=0,nx - p(i,j,k+n) = bufp_slabs(i,j,k,m) - end do - end do - end do - endif - endif - end do -end do - - -call task_barrier() - -! Add pressure gradient term to the rhs of the momentum equation: - -call press_grad() - -end - - - diff --git a/src/physics/spcam/crm/crmx_random.F90 b/src/physics/spcam/crm/crmx_random.F90 deleted file mode 100644 index 7e0172527b..0000000000 --- a/src/physics/spcam/crm/crmx_random.F90 +++ /dev/null @@ -1,62 +0,0 @@ -! Simple randaom number generator in the range [0,1] -! ranset_(iseed) initializes with iseed -! ranf_() returns next random numer - - - - - real function ranf_() - implicit none - real rand_ -! ranf_ = rand_(0) - call random_number(ranf_) - return - end - - - subroutine ranset_(iseed) - implicit none - real rand_,ranf_ - integer iseed, i, m, nsteps -! i = rand_(1) ! reinitialize (reset) - nsteps = iseed*10000 - do i = 1,nsteps - m = ranf_() -! m = rand_(0) - end do - return - end - - - - - - real function rand_(iseed) - implicit none - integer iseed - integer ia1, ia0, ia1ma0, ic, ix1, ix0, iy0, iy1 - save ia1, ia0, ia1ma0, ic, ix1, ix0 - data ix1, ix0, ia1, ia0, ia1ma0, ic/0,0,1536,1029,507,1731/ - if (iseed.ne.0) then - ia1 = 1536 - ia0 = 1029 - ia1ma0 = 507 - ic = 1731 - ix1 = 0 - ix0 = 0 - rand_ = 0 - else - iy0 = ia0*ix0 - iy1 = ia1*ix1 + ia1ma0*(ix0-ix1) + iy0 - iy0 = iy0 + ic - ix0 = mod (iy0, 2048) - iy1 = iy1 + (iy0-ix0)/2048 - ix1 = mod (iy1, 2048) - rand_ = ix1*2048 + ix0 - rand_ = rand_ / 4194304. - end if - return - end - - - diff --git a/src/physics/spcam/crm/crmx_sat.F90 b/src/physics/spcam/crm/crmx_sat.F90 deleted file mode 100644 index fb74141d07..0000000000 --- a/src/physics/spcam/crm/crmx_sat.F90 +++ /dev/null @@ -1,122 +0,0 @@ - -! Saturation vapor pressure and mixing ratio. -! Based on Flatau et.al, (JAM, 1992:1507) - valid for T > -80C -! sat. vapor over ice below -80C - used Murphy and Koop (2005) -! For water below -80C simply assumed esw/esi = 2. -! des/dT below -80C computed as a finite difference of es - -real function esatw_crm(t) -implicit none -real t ! temperature (K) -real a0,a1,a2,a3,a4,a5,a6,a7,a8 -data a0,a1,a2,a3,a4,a5,a6,a7,a8 /& - 6.105851, 0.4440316, 0.1430341e-1, & - 0.2641412e-3, 0.2995057e-5, 0.2031998e-7, & - 0.6936113e-10, 0.2564861e-13,-0.3704404e-15/ -! 6.11239921, 0.443987641, 0.142986287e-1, & -! 0.264847430e-3, 0.302950461e-5, 0.206739458e-7, & -! 0.640689451e-10, -0.952447341e-13,-0.976195544e-15/ -real dt - dt = t-273.16 -if(dt.gt.-80.) then - esatw_crm = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) -else - esatw_crm = 2.*0.01*exp(9.550426 - 5723.265/t + 3.53068*Log(t) - 0.00728332*t) -end if -end - - - -real function qsatw_crm(t,p) -implicit none -real t ! temperature (K) -real p ! pressure (mb) -real esat_crm,esatw_crm -esat_crm = esatw_crm(t) -qsatw_crm = 0.622 * esat_crm/max(esat_crm,p-esat_crm) -end - - -real function dtesatw_crm(t) -implicit none -real t ! temperature (K) -real a0,a1,a2,a3,a4,a5,a6,a7,a8 -data a0,a1,a2,a3,a4,a5,a6,a7,a8 /& - 0.443956472, 0.285976452e-1, 0.794747212e-3, & - 0.121167162e-4, 0.103167413e-6, 0.385208005e-9, & - -0.604119582e-12, -0.792933209e-14, -0.599634321e-17/ -real dt,esatw_crm -dt = t-273.16 -if(dt.gt.-80.) then - dtesatw_crm = a0 + dt* (a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) -else - dtesatw_crm = esatw_crm(t+1)-esatw_crm(t) -end if - -end - - -real function dtqsatw_crm(t,p) -implicit none -real t ! temperature (K) -real p ! pressure (mb) -real dtesatw_crm -dtqsatw_crm = 0.622*dtesatw_crm(t)/p -end - - -real function esati_crm(t) -implicit none -real t ! temperature (K) -real a0,a1,a2,a3,a4,a5,a6,a7,a8 -data a0,a1,a2,a3,a4,a5,a6,a7,a8 /& - 6.11147274, 0.503160820, 0.188439774e-1, & - 0.420895665e-3, 0.615021634e-5,0.602588177e-7, & - 0.385852041e-9, 0.146898966e-11, 0.252751365e-14/ -real dt -dt = t-273.16 -if(dt.gt.-80.) then - esati_crm = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) -else - esati_crm = 0.01*exp(9.550426 - 5723.265/t + 3.53068*Log(t) - 0.00728332*t) -end if -end - - - -real function qsati_crm(t,p) -implicit none -real t ! temperature (K) -real p ! pressure (mb) -real esat_crm,esati_crm -esat_crm=esati_crm(t) -qsati_crm=0.622 * esat_crm/max(esat_crm,p-esat_crm) -end - - -real function dtesati_crm(t) -implicit none -real t ! temperature (K) -real a0,a1,a2,a3,a4,a5,a6,a7,a8 -data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & - 0.503223089, 0.377174432e-1,0.126710138e-2, & - 0.249065913e-4, 0.312668753e-6, 0.255653718e-8, & - 0.132073448e-10, 0.390204672e-13, 0.497275778e-16/ -real dt,esati_crm -dt = t-273.16 -if(dt.gt.-80.) then - dtesati_crm = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) -else - dtesati_crm = esati_crm(t+1.)-esati_crm(t) -end if -end - - -real function dtqsati_crm(t,p) -implicit none -real t ! temperature (K) -real p ! pressure (mb) -real dtesati_crm -dtqsati_crm=0.622*dtesati_crm(t)/p -end - diff --git a/src/physics/spcam/crm/crmx_setparm.F90 b/src/physics/spcam/crm/crmx_setparm.F90 deleted file mode 100644 index e843b22621..0000000000 --- a/src/physics/spcam/crm/crmx_setparm.F90 +++ /dev/null @@ -1,140 +0,0 @@ -module crmx_setparm_mod - -contains - -subroutine setparm - -! initialize parameters: - -use crmx_vars -!use micro_params -use crmx_params -use crmx_microphysics, only: micro_setparm -use crmx_sgs, only: sgs_setparm - -implicit none - -integer icondavg, ierr - -!NAMELIST /PARAMETERS/ dodamping, doupperbound, docloud, doprecip, & -! dolongwave, doshortwave, dosgs, & -! docoriolis, dosurface, dolargescale, doradforcing, & -! nadams,fluxt0,fluxq0,tau0,tabs_s,z0,tauls,nelapse, & -! dt, dx, dy, fcor, ug, vg, nstop, caseid, & -! nstat, nstatfrq, nprint, nrestart, doradsimple, & -! nsave3D, nsave3Dstart, nsave3Dend, dosfcforcing, & -! donudging_uv, donudging_tq, dosmagor, doscalar, & -! timelargescale, longitude0, latitude0, day0, nrad, & -! CEM,LES,OCEAN,LAND,SFC_FLX_FXD,SFC_TAU_FXD, soil_wetness, & -! doensemble, nensemble, doxy, dowallx, dowally, & -! nsave2D, nsave2Dstart, nsave2Dend, qnsave3D, & -! docolumn, save2Dbin, save2Davg, save3Dbin, & -! save2Dsep, save3Dsep, dogzip2D, dogzip3D, restart_sep, & -! doseasons, doperpetual, doradhomo, dosfchomo, doisccp, & -! dodynamicocean, ocean_type, & -! dosolarconstant, solar_constant, zenith_angle, rundatadir, & -! dotracers, output_sep, perturb_type, & -! doSAMconditionals, dosatupdnconditionals, & -! doscamiopdata, iopfile, dozero_out_day0, & -! nstatmom, nstatmomstart, nstatmomend, savemomsep, savemombin, & -! nmovie, nmoviestart, nmovieend, nrestart_skip, & -! bubble_x0,bubble_y0,bubble_z0,bubble_radius_hor, & -! bubble_radius_ver,bubble_dtemp,bubble_dq, dosmoke, & -! doclubb, doclubbnoninter, doclubb_sfc_fluxes, & ! added by dschanen UWM -! docam_sfc_fluxes ! added by mhwang - - - -!---------------------------------- -! Read namelist variables from the standard input: -!------------ - -!open(55,file='./'//trim(case)//'/prm', status='old',form='formatted') -!read (55,PARAMETERS) -!close(55) - - doprecip = .true. - dosgs = .true. - dosurface = .true. - dodamping = .true. - dt = CRM_DT - dx = CRM_DX - dy = CRM_DY - CEM = .true. -#ifndef CLUBB_CRM - doclubb = .false. ! then docloud must be .true. - docloud = .true. -#else - doclubb = .true. ! then docloud must be .false. - docloud = .false. - doclubbnoninter = .false. - doclubb_sfc_fluxes = .false. - docam_sfc_fluxes = .true. ! update variables in cam, neither in sam nor in clubb +++mhwang - nclubb = 3 - -#ifdef sam1mom -! for sam1mom, nclubb needs to be 1. -! see comments in ./MICRO_SAM1MOM/microphysics.F90 - nclubb = 3 -#endif - -#endif - rank = 0 ! in MMF model, rank = 0 -!------------------------------------ -! Set parameters - - - ! Allow only special cases for separate output: - - output_sep = output_sep.and.RUN3D - if(output_sep) save2Dsep = .true. - - if(RUN2D) dy=dx - - if(RUN2D.and.YES3D.eq.1) then - print*,'Error: 2D run and YES3D is set to 1. Exitting...' - call task_abort() - endif - if(RUN3D.and.YES3D.eq.0) then - print*,'Error: 3D run and YES3D is set to 0. Exitting...' - call task_abort() - endif -#ifdef CLUBB_CRM - if ( dx >= 1000. .and. LES ) then - print*,'Error: Horizonatal grid spacing is >= 1000. meters' - print*,'but LES is true. Use CEM mode for coarse resolutions.' - call task_abort() - end if -#endif - - if(fcor.eq.-999.) fcor= 4*pi/86400.*sin(latitude0*pi/180.) - fcorz = sqrt(4.*(2*pi/(3600.*24.))**2-fcor**2) - - if(ny.eq.1) dy=dx - dtn = dt - - notopened2D = .true. - notopened3D = .true. - -! call zero_instr_diag() ! initialize instruments output - call sgs_setparm() ! read in SGS options from prm file. - call micro_setparm() ! read in microphysical options from prm file. - - if(dosmoke) then - epsv=0. - else - epsv=0.61 - endif - - if(navgmom_x.lt.0.or.navgmom_y.lt.0) then - nstatmom = 1 - nstatmomstart = 99999999 - nstatmomend = 999999999 - end if - - if(tautqls.eq.99999999.) tautqls = tauls - - masterproc = rank.eq.0 - -end subroutine setparm -end module crmx_setparm_mod diff --git a/src/physics/spcam/crm/crmx_setperturb.F90 b/src/physics/spcam/crm/crmx_setperturb.F90 deleted file mode 100644 index 88bbabeed4..0000000000 --- a/src/physics/spcam/crm/crmx_setperturb.F90 +++ /dev/null @@ -1,59 +0,0 @@ - -subroutine setperturb(iseed) - -! Random noise -! This surboutine has been updated for SPCAM5 (Minghuai.Wang@pnnl.gov, April, 2012). -! Now the random generator is seeded based on the global column id, which gets rid -! of the dependence of the SPCAM reulst on pcols. - -use crmx_vars -use crmx_sgs, only: setperturb_sgs - -implicit none - -integer, intent(in) :: iseed - -integer i,j,k -real rrr,ranf_ -integer, allocatable :: rndm_seed(:) -integer :: rndm_seed_sz -real :: t02(nzm) -real :: tke02(nzm) - -!call ranset_(30*rank) -call random_seed(size=rndm_seed_sz) -allocate(rndm_seed(rndm_seed_sz)) - -rndm_seed = iseed -call random_seed(put=rndm_seed) - -call setperturb_sgs(0) ! set sgs fields - -t02 = 0.0 -tke02 = 0.0 -do k=1,nzm - do j=1,ny - do i=1,nx - rrr=1.-2.*ranf_() - - if(k.le.5) then - t(i,j,k)=t(i,j,k)+0.02*rrr*(6-k) - endif - t02(k) = t02(k) + t(i,j,k)/(nx*ny) - end do - end do - -! energy conservation +++mhwang (2012-06) - do j=1, ny - do i=1, nx - if(k.le.5) then - t(i,j,k) = t(i,j,k) * t0(k)/t02(k) - end if - end do - end do -end do - -deallocate(rndm_seed) - -end - diff --git a/src/physics/spcam/crm/crmx_stepout.F90 b/src/physics/spcam/crm/crmx_stepout.F90 deleted file mode 100644 index 0c7f66bc0f..0000000000 --- a/src/physics/spcam/crm/crmx_stepout.F90 +++ /dev/null @@ -1,196 +0,0 @@ -subroutine stepout(nstatsteps) - -use crmx_vars -!use rad, only: qrad -use crmx_sgs, only: tk, sgs_print -use crmx_crmtracers -use crmx_microphysics, only: micro_print -use crmx_params -implicit none - -integer i,j,k,ic,jc,nstatsteps -integer n -real div, divmax, divmin -real rdx, rdy, rdz, coef -integer im,jm,km -real wmax, qnmax(1), qnmax1(1) -real(kind=selected_real_kind(12)) buffer(6), buffer1(6) -real(kind=selected_real_kind(12)) qi0(nzm) - -#ifdef CLUBB_CRM -real(8) buffer_e(7), buffer1_e(7) -#endif - - - -!------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ -! Print stuff out: - -!call t_startf ('print_out') - -if(masterproc) print *,'NSTEP = ',nstep,' NCYCLE=',ncycle - -if(mod(nstep,nprint).eq.0) then - - - divmin=1.e20 - divmax=-1.e20 - - rdx = 1./dx - rdy = 1./dy - - wmax=0. - do k=1,nzm - coef = rho(k)*adz(k)*dz - rdz = 1./coef - if(ny.ne.1) then - do j=1,ny-1*YES3D - jc = j+1*YES3D - do i=1,nx-1 - ic = i+1 - div = (u(ic,j,k)-u(i,j,k))*rdx + (v(i,jc,k)-v(i,j,k))*rdy + & - (w(i,j,k+1)*rhow(k+1)-w(i,j,k)*rhow(k))*rdz - divmax = max(divmax,div) - divmin = min(divmin,div) - if(w(i,j,k).gt.wmax) then - wmax=w(i,j,k) - im=i - jm=j - km=k - endif - end do - end do - else - j = 1 - do i=1,nx-1 - ic = i+1 - div = (u(ic,j,k)-u(i,j,k))*rdx +(w(i,j,k+1)*rhow(k+1)-w(i,j,k)*rhow(k))*rdz - divmax = max(divmax,div) - divmin = min(divmin,div) - if(w(i,j,k).gt.wmax) then - wmax=w(i,j,k) - im=i - jm=j - km=k - endif - end do - endif - end do - - if(dompi) then - buffer(1) = total_water_before - buffer(2) = total_water_after - buffer(3) = total_water_evap - buffer(4) = total_water_prec - buffer(5) = total_water_ls -#ifdef CLUBB_CRM - buffer(6) = total_water_clubb - - buffer_e(1) = total_energy_before - buffer_e(2) = total_energy_after - buffer_e(3) = total_energy_evap - buffer_e(4) = total_energy_prec - buffer_e(5) = total_energy_ls - buffer_e(6) = total_energy_clubb - buffer_e(7) = total_energy_rad -#endif - call task_sum_real8(buffer, buffer1,6) - total_water_before = buffer1(1) - total_water_after = buffer1(2) - total_water_evap = buffer1(3) - total_water_prec = buffer1(4) - total_water_ls = buffer1(5) -#ifdef CLUBB_CRM - total_water_clubb = buffer1(6) - - call task_sum_real8(buffer_e, buffer1_e,7) - total_energy_before = buffer1_e(1) - total_energy_after = buffer1_e(2) - total_energy_evap = buffer1_e(3) - total_energy_prec = buffer1_e(4) - total_energy_ls = buffer1_e(5) - total_energy_clubb = buffer1_e(6) - total_energy_rad = buffer1_e(7) -#endif - end if - -!print*,rank,minval(u(1:nx,1:ny,:)),maxval(u(1:nx,1:ny,:)) -!print*,rank,'min:',minloc(u(1:nx,1:ny,:)) -!print*,rank,'max:',maxloc(u(1:nx,1:ny,:)) - -!if(masterproc) then - -!print*,'--->',tk(27,1,1) -!print*,'tk->:' -!write(6,'(16f7.2)')((tk(i,1,k),i=1,16),k=nzm,1,-1) -!print*,'p->:' -!write(6,'(16f7.2)')((p(i,1,k),i=1,16),k=nzm,1,-1) -!print*,'u->:' -!write(6,'(16f7.2)')((u(i,1,k),i=1,16),k=nzm,1,-1) -!print*,'v->:' -!write(6,'(16f7.2)')((v(i,1,k),i=1,16),k=nzm,1,-1) -!print*,'w->:' -!write(6,'(16f7.2)')((w(i,1,k),i=1,16),k=nzm,1,-1) -!print*,'qcl:' -!write(6,'(16f7.2)')((qcl(i,13,k)*1000.,i=1,16),k=30,1,-1) -!print*,'qpl:' -!write(6,'(16f7.2)')((qpl(i,13,k)*1000.,i=1,16),k=30,1,-1) -!print*,'qrad:' -!write(6,'(16f7.2)')((qrad(i,13,k)*3600.,i=1,16),k=30,1,-1) -!print*,'qv:' -!write(6,'(16f7.2)')((qv(i,13,k)*1000.,i=1,16),k=30,1,-1) -!print*,'tabs:' -!write(6,'(16f7.2)')((tabs(i,13,k),i=1,16),k=30,1,-1) -! -!end if - -!-------------------------------------------------------- - if(masterproc) then - - print*,'DAY = ',day - write(6,*) 'NSTEP=',nstep - write(6,*) 'div:',divmax,divmin - if(.not.dodynamicocean) write(6,*) 'SST=',tabs_s - write(6,*) 'surface pressure=',pres0 - - endif - - call fminmax_print('u:',u,dimx1_u,dimx2_u,dimy1_u,dimy2_u,nzm) - call fminmax_print('v:',v,dimx1_v,dimx2_v,dimy1_v,dimy2_v,nzm-5) - call fminmax_print('w:',w,dimx1_w,dimx2_w,dimy1_w,dimy2_w,nz) - call fminmax_print('p:',p,0,nx,1-YES3D,ny,nzm) - call fminmax_print('t:',t,dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm) - call fminmax_print('tabs:',tabs,1,nx,1,ny,nzm) - call fminmax_print('qv:',qv,1,nx,1,ny,nzm) - if(dosgs) call sgs_print() -#ifdef CLUBB_CRM - if(docloud.or.doclubb) then -#else - if(docloud) then -#endif /*CLUBB_CRM*/ - call fminmax_print('qcl:',qcl,1,nx,1,ny,nzm) - call fminmax_print('qci:',qci,1,nx,1,ny,nzm) - call micro_print() - end if - if(doprecip) then - call fminmax_print('qpl:',qpl,1,nx,1,ny,nzm) - call fminmax_print('qpi:',qpi,1,nx,1,ny,nzm) - end if -! if(dolongwave.or.doshortwave) call fminmax_print('qrad(K/day):',qrad*86400.,1,nx,1,ny,nzm) - if(dotracers) then - do k=1,ntracers - call fminmax_print(trim(tracername(k))//':',tracer(:,:,:,k),dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm) - end do - end if - call fminmax_print('shf:',fluxbt*cp*rhow(1),1,nx,1,ny,1) - call fminmax_print('lhf:',fluxbq*lcond*rhow(1),1,nx,1,ny,1) - call fminmax_print('uw:',fluxbu,1,nx,1,ny,1) - call fminmax_print('vw:',fluxbv,1,nx,1,ny,1) - call fminmax_print('sst:',sstxy,0,nx,1-YES3D,ny,1) - -end if ! (mod(nstep,nprint).eq.0) - -!call t_stopf ('print_out') - -end diff --git a/src/physics/spcam/crm/crmx_task_init.F90 b/src/physics/spcam/crm/crmx_task_init.F90 deleted file mode 100644 index 0280dba2f4..0000000000 --- a/src/physics/spcam/crm/crmx_task_init.F90 +++ /dev/null @@ -1,69 +0,0 @@ -subroutine task_init - -! Check things, initialize multitasking: - -use crmx_grid -implicit none - -integer itasks,ntasks - -if(YES3D .ne. 1 .and. YES3D .ne. 0) then - print*,'YES3D is not 1 or 0. STOP' - stop -endif - -if(YES3D .eq. 1 .and. ny_gl .lt. 4) then - print*,'ny_gl is too small for a 3D case.STOP' - stop -endif - -if(YES3D .eq. 0 .and. ny_gl .ne. 1) then - print*,'ny_gl should be 1 for a 2D case. STOP' - stop -endif - -if(nsubdomains.eq.1) then - - rank =0 - ntasks = 1 - dompi = .false. - -else - -! call task_start(rank, ntasks) - -! dompi = .true. - -! call systemf('hostname') - -! if(ntasks.ne.nsubdomains) then -! if(masterproc) print *,'number of processors is not equal to nsubdomains!',& -! ' ntasks=',ntasks,' nsubdomains=',nsubdomains -! call task_abort() -! endif - -! call task_barrier() - -! call task_ranks() - -end if ! nsubdomains.eq.1 - -#ifndef CRM -do itasks=0,nsubdomains-1 - call task_barrier() - if(itasks.eq.rank) then - open(8,file='./CaseName',status='old',form='formatted') - read(8,'(a)') case - close (8) - endif -end do -#endif /*CRM*/ - -masterproc = rank.eq.0 - -#ifndef CRM -if(masterproc) print *,'number of MPI tasks:',ntasks -#endif /*CRM*/ - - -end diff --git a/src/physics/spcam/crm/crmx_task_util_NOMPI.F90 b/src/physics/spcam/crm/crmx_task_util_NOMPI.F90 deleted file mode 100644 index b2c9b4e8c9..0000000000 --- a/src/physics/spcam/crm/crmx_task_util_NOMPI.F90 +++ /dev/null @@ -1,230 +0,0 @@ - - subroutine task_start(rank,numtasks) - integer rank,numtasks - print*, 'MPI call from a single task program! Exiting...' - stop - end - -!---------------------------------------------------------------------- - - subroutine task_abort() - print*,'Aborting the program...' - stop - end -!---------------------------------------------------------------------- - - subroutine task_finish() - print*,'program is finished...' - stop - end - -!---------------------------------------------------------------------- - subroutine task_barrier() - return - end - -!---------------------------------------------------------------------- - - subroutine task_bcast_float(rank_from,buffer,length) - implicit none - integer rank_from ! broadcasting task's rank - real buffer(*) ! buffer of data - integer length ! buffers' length - print*, 'MPIsndf call from a single task program! Exiting...' - stop - end - -!---------------------------------------------------------------------- - - subroutine task_send_float(rank_to,buffer,length,tag,request) - implicit none - integer rank_to ! receiving task's rank - real buffer(*) ! buffer of data - integer length ! buffers' length - integer tag ! tag of the message - integer request ! request id - print*, 'MPIsndf call from a single task program! Exiting...' - stop - end - -!---------------------------------------------------------------------- - - subroutine task_send_integer(rank_to,buffer,length,tag,request) - implicit none - integer rank_to ! receiving task's rank - integer buffer(*) ! buffer of data - integer length ! buffers' length - integer tag ! tag of the message - integer request - print*, 'MPIsndi call from a single task program! Exiting...' - stop - end - -!---------------------------------------------------------------------- - - subroutine task_send_character(rank_to,buffer,length,tag,request) - implicit none - integer rank_to ! receiving task's rank - character*1 buffer(*) ! buffer of data - integer length ! buffers' length - integer tag ! tag of the message - integer request - print*, 'MPIsndi call from a single task program! Exiting...' - stop - end - -!---------------------------------------------------------------------- - - subroutine task_receive_float(buffer,length,request) - real buffer(*) ! buffer of data - integer length ! buffers' length - integer request - print*, 'MPIrcvf call from a single task program! Exiting...' - stop - end - -!---------------------------------------------------------------------- - - subroutine task_receive_charcater(buffer,length,request) - character*1 buffer(*) ! buffer of data - integer length ! buffers' length - integer request - print*, 'MPIrcvi call from a single task program! Exiting...' - stop - end - -!---------------------------------------------------------------------- - - subroutine task_receive_integer(buffer,length,request) - integer buffer(*) ! buffer of data - integer length ! buffers' length - integer request - print*, 'MPIrcvi call from a single task program! Exiting...' - stop - end -!---------------------------------------------------------------------- - - subroutine task_bsend_float(rank_to,buffer,length,tag) - integer rank_to ! receiving task's rank - real buffer(*) ! buffer of data - integer length ! buffers' length - integer tag ! tag of the message - print*, 'MPI call from a single task program! Exiting...' - stop - return - end - -!---------------------------------------------------------------------- - subroutine task_wait(request,rank,tag) - integer request - integer rank, tag - return - end - -!---------------------------------------------------------------------- - - subroutine task_waitall(count,reqs,ranks,tags) - integer count,reqs(count) - integer ranks(count),tags(count) - return - end - -!---------------------------------------------------------------------- - subroutine task_test(request,flag,rank,tag) - integer request - integer rank, tag - logical flag - print*, 'MPItst call from a single task program! Exiting...' - stop - end - -!---------------------------------------------------------------------- - - subroutine task_sum_real(buffer1,buffer2,length) - real buffer1(*) ! buffer of data - real buffer2(*) ! buffer of data - integer length ! buffers' length - print*, 'MPI call from a single task program! Exiting...' - stop - end - -!---------------------------------------------------------------------- - - subroutine task_sum_real8(buffer1,buffer2,length) - real buffer1(*) ! buffer of data - real buffer2(*) ! buffer of data - integer length ! buffers' length - print*, 'MPI call from a single task program! Exiting...' - stop - end -!---------------------------------------------------------------------- - - subroutine task_sum_integer(buffer1,buffer2,length) - real buffer1(*) ! buffer of data - real buffer2(*) ! buffer of data - integer length ! buffers' length - print*, 'MPI call from a single task program! Exiting...' - stop - end -!---------------------------------------------------------------------- - - subroutine task_max_real(buffer1,buffer2,length) - real buffer1(*) ! buffer of data - real buffer2(*) ! buffer of data - integer length ! buffers' length - return - print*, 'MPI call from a single task program! Exiting...' - stop - end -!---------------------------------------------------------------------- - - subroutine task_max_integer(buffer1,buffer2,length) - real buffer1(*) ! buffer of data - real buffer2(*) ! buffer of data - integer length ! buffers' length - print*, 'MPI call from a single task program! Exiting...' - stop - end -!---------------------------------------------------------------------- - - subroutine task_min_real(buffer1,buffer2,length) - real buffer1(*) ! buffer of data - real buffer2(*) ! buffer of data - integer length ! buffers' length - print*, 'MPI call from a single task program! Exiting...' - stop - end -!---------------------------------------------------------------------- - - subroutine task_min_integer(buffer1,buffer2,length) - real buffer1(*) ! buffer of data - real buffer2(*) ! buffer of data - integer length ! buffers' length - print*, 'MPI call from a single task program! Exiting...' - stop - end -!---------------------------------------------------------------------- - - subroutine task_receive_character(buffer,length,request) - character*1 buffer(*) ! buffer of data - integer length ! buffers' length - integer request - print*, 'MPI call from a single task program! Exiting...' - stop - end -!---------------------------------------------------------------------- - subroutine task_rank_to_index (rank,i,j) - integer rank, i, j - i=0 - j=0 - end -!---------------------------------------------------------------------- - subroutine task_bound_duvdt () - return - end -!---------------------------------------------------------------------- - subroutine task_boundaries(flag) - integer flag - end - - diff --git a/src/physics/spcam/crm/crmx_utils.F90 b/src/physics/spcam/crm/crmx_utils.F90 deleted file mode 100644 index 1a9acaecb0..0000000000 --- a/src/physics/spcam/crm/crmx_utils.F90 +++ /dev/null @@ -1,145 +0,0 @@ -integer function lenstr (string) - -! returns string's length ignoring the rightmost blank and null characters - -implicit none -character *(*) string -integer k -lenstr = 0 -do k = 1,len(string) - if (string(k:k).ne.' '.and.string(k:k).ne.char(0)) then - lenstr = lenstr+1 - end if -end do -111 return -end - - - -subroutine averageXY(f,dimx1,dimx2,dimy1,dimy2,dimz,fm) - -use crmx_grid -implicit none -integer dimx1, dimx2, dimy1, dimy2, dimz -real f(dimx1:dimx2, dimy1:dimy2, dimz),fm(nzm) -real(kind=selected_real_kind(12)) ff,factor -integer i,j,k -factor = 1./dble(nx*ny) -do k =1,nzm - ff = 0. - do j =1,ny - do i =1,nx - ff = ff + f(i,j,k) - end do - end do - ff = ff*factor - fm(k) = real(ff) -end do -end - - -subroutine averageXY_MPI(f,dimx1,dimx2,dimy1,dimy2,dimz,fm) - -use crmx_grid -implicit none -integer dimx1, dimx2, dimy1, dimy2, dimz -real f(dimx1:dimx2, dimy1:dimy2, dimz),fm(nzm) -real(kind=selected_real_kind(12)) fm1(nzm),fm2(nzm),factor -integer i,j,k -factor = 1./dble(nx*ny) -do k =1,nzm - fm1(k) = 0. - do j =1,ny - do i =1,nx - fm1(k) = fm1(k) + f(i,j,k) - end do - end do - fm1(k) = fm1(k) * factor -end do -if(dompi) then - do k =1,nzm - fm2(k) = fm1(k) - end do - call task_sum_real8(fm2,fm1,nzm) - do k=1,nzm - fm(k)=real(fm1(k)/dble(nsubdomains)) - end do -else - do k=1,nzm - fm(k)=real(fm1(k)) - end do -endif -end - - - - -subroutine fminmax_print(name,f,dimx1,dimx2,dimy1,dimy2,dimz) - -use crmx_grid -implicit none -integer dimx1, dimx2, dimy1, dimy2, dimz -real f(dimx1:dimx2, dimy1:dimy2, dimz),fmn(nz),fmx(nz) -character *(*) name -real fmin(1),fmax(1),fff(1) -integer i,j,k - -do k=1,dimz - if(dimx2.eq.1.and.dimy2.eq.1) then - fmn(k) = f(1,1,k) - fmx(k) = f(1,1,k) - else - fmn(k) = 1.e30 - fmx(k) =-1.e30 - do j=1,ny - do i=1,nx - fmn(k) = min(fmn(k),f(i,j,k)) - fmx(k) = max(fmx(k),f(i,j,k)) - end do - enddo - end if -enddo -fmin(1) = 1.e30 -fmax(1) =-1.e30 -do k=1,dimz - fmin(1) = min(fmin(1),fmn(k)) - fmax(1) = max(fmax(1),fmx(k)) -end do - -if(dompi) then - fff(1)=fmax(1) - call task_max_real(fff(1),fmax(1),1) - fff(1)=fmin(1) - call task_min_real(fff(1),fmin(1),1) -end if -if(masterproc) print *,name,fmin,fmax -end - - - - -subroutine setvalue(f,n,f0) -implicit none -integer n -real f(n), f0 -integer k -do k=1,n - f(k)=f0 -end do -end - -! determine number of byte in a record in direct access files (can be anything, from 1 to 8): -! can't assume 1 as it is compiler and computer dependent -integer function bytes_in_rec() -implicit none -character*8 str -integer n, err -open(1,status ='scratch',access ='direct',recl=1) -do n = 1,8 - write(1,rec=1,iostat=err) str(1:n) - if (err.ne.0) exit - bytes_in_rec = n -enddo -close(1,status='delete') -end - diff --git a/src/physics/spcam/crm/crmx_uvw.F90 b/src/physics/spcam/crm/crmx_uvw.F90 deleted file mode 100644 index 2edaa17e70..0000000000 --- a/src/physics/spcam/crm/crmx_uvw.F90 +++ /dev/null @@ -1,13 +0,0 @@ -subroutine uvw - -! update the velocity field - -use crmx_vars -use crmx_params -implicit none - -u(1:nx,1:ny,1:nzm) = dudt(1:nx,1:ny,1:nzm,nc) -v(1:nx,1:ny,1:nzm) = dvdt(1:nx,1:ny,1:nzm,nc) -w(1:nx,1:ny,1:nzm) = dwdt(1:nx,1:ny,1:nzm,nc) - -end subroutine uvw diff --git a/src/physics/spcam/crm/crmx_vars.F90 b/src/physics/spcam/crm/crmx_vars.F90 deleted file mode 100644 index f85feeb1e3..0000000000 --- a/src/physics/spcam/crm/crmx_vars.F90 +++ /dev/null @@ -1,259 +0,0 @@ -module crmx_vars - -use crmx_grid -#ifdef CRM -#ifdef MODAL_AERO -use modal_aero_data, only: ntot_amode -#endif -#endif - -implicit none -!-------------------------------------------------------------------- -! prognostic variables: - -real u (dimx1_u:dimx2_u, dimy1_u:dimy2_u, nzm) ! x-wind -real v (dimx1_v:dimx2_v, dimy1_v:dimy2_v, nzm) ! y-wind -real w (dimx1_w:dimx2_w, dimy1_w:dimy2_w, nz ) ! z-wind -real t (dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! liquid/ice water static energy - -!-------------------------------------------------------------------- -! diagnostic variables: - -real p (0:nx, (1-YES3D):ny, nzm) ! perturbation pressure (from Poison eq) -real tabs (nx, ny, nzm) ! temperature -real qv (nx, ny, nzm) ! water vapor -real qcl (nx, ny, nzm) ! liquid water (condensate) -real qpl (nx, ny, nzm) ! liquid water (precipitation) -real qci (nx, ny, nzm) ! ice water (condensate) -real qpi (nx, ny, nzm) ! ice water (precipitation) - -real tke2(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) ! SGS TKE -real tk2 (0:nxp1, (1-YES3D):nyp1, nzm) ! SGS eddyviscosity - -!-------------------------------------------------------------------- -! time-tendencies for prognostic variables - -real dudt (nxp1, ny, nzm, 3) -real dvdt (nx, nyp1, nzm, 3) -real dwdt (nx, ny, nz, 3) - -!---------------------------------------------------------------- -! Temporary storage array: - - real misc(nx, ny, nz) -!------------------------------------------------------------------ -! fluxes at the top and bottom of the domain: - -real fluxbu (nx, ny), fluxbv (nx, ny), fluxbt (nx, ny) -real fluxbq (nx, ny), fluxtu (nx, ny), fluxtv (nx, ny) -real fluxtt (nx, ny), fluxtq (nx, ny), fzero (nx, ny) -real precsfc(nx,ny) ! surface precip. rate -real precssfc(nx,ny) ! surface ice precip. rate - -!----------------------------------------------------------------- -! profiles - -real t0(nzm), q0(nzm), qv0(nzm), tabs0(nzm), tl0(nzm), & - tv0(nzm), u0(nzm), v0(nzm), & - tg0(nzm), qg0(nzm), ug0(nzm), vg0(nzm), p0(nzm), & - tke0(nzm), t01(nzm), q01(nzm), qp0(nzm), qn0(nzm) -!---------------------------------------------------------------- -! "observed" (read from snd file) surface characteristics - -real sstobs, lhobs, shobs -!---------------------------------------------------------------- -! Domain top stuff: - -real gamt0 ! gradient of t() at the top,K/m -real gamq0 ! gradient of q() at the top,g/g/m - -!----------------------------------------------------------------- -! reference vertical profiles: - -real prespot(nzm) ! (1000./pres)**R/cp -real rho(nzm) ! air density at pressure levels,kg/m3 -real rhow(nz) ! air density at vertical velocity levels,kg/m3 -real bet(nzm) ! = ggr/tv0 -real gamaz(nzm) ! ggr/cp*z -real wsub(nz) ! Large-scale subsidence velocity,m/s -real qtend(nzm) ! Large-scale tendency for total water -real ttend(nzm) ! Large-scale tendency for temp. -real utend(nzm) ! Large-scale tendency for u -real vtend(nzm) ! Large-scale tendency for v - - -!--------------------------------------------------------------------- -! Large-scale and surface forcing: - -integer nlsf ! number of large-scale forcing profiles -integer nrfc ! number of radiative forcing profiles -integer nsfc ! number of surface forcing profiles -integer nsnd ! number of observed soundings -integer nzlsf ! number of large-scale forcing profiles -integer nzrfc ! number of radiative forcing profiles -integer nzsnd ! number of observed soundings - -real, allocatable :: dqls(:,:) ! Large-scale tendency for total water -real, allocatable :: dtls(:,:) ! Large-scale tendency for temp. -real, allocatable :: ugls(:,:) ! Large-scale wind in X-direction -real, allocatable :: vgls(:,:) ! Large-scale wind in Y-direction -real, allocatable :: wgls(:,:) ! Large-scale subsidence velocity,m/s -real, allocatable :: pres0ls(:)! Surface pressure, mb -real, allocatable :: zls(:,:) ! Height -real, allocatable :: pls(:,:) ! Pressure -real, allocatable :: dayls(:) ! Large-scale forcing arrays time (days) -real, allocatable :: dtrfc(:,:)! Radiative tendency for pot. temp. -real, allocatable :: dayrfc(:) ! Radiative forcing arrays time (days) -real, allocatable :: prfc(:,:) ! Pressure/Height -real, allocatable :: sstsfc(:) ! SSTs -real, allocatable :: shsfc(:) ! Sensible heat flux,W/m2 -real, allocatable :: lhsfc(:) ! Latent heat flux,W/m2 -real, allocatable :: tausfc(:) ! Surface drag,m2/s2 -real, allocatable :: daysfc(:) ! Surface forcing arrays time (days) -real, allocatable :: usnd(:,:) ! Observed zonal wind -real, allocatable :: vsnd(:,:) ! Observed meriod wind -real, allocatable :: tsnd(:,:) ! Observed Abs. temperature -real, allocatable :: qsnd(:,:) ! Observed Moisture -real, allocatable :: zsnd(:,:) ! Height -real, allocatable :: psnd(:,:) ! Pressure -real, allocatable :: daysnd(:) ! number of sounding samples - -!--------------------------------------------------------------------- -! Horizontally varying stuff (as a function of xy) -! -real sstxy(0:nx,(1-YES3D):ny) ! surface temperature xy-distribution -real fcory(0:ny) ! Coriolis parameter xy-distribution -real fcorzy(ny) ! z-Coriolis parameter xy-distribution -real latitude(nx,ny) ! latitude (degrees) -real longitude(nx,ny) ! longitude(degrees) -real prec_xy(nx,ny) ! mean precip. rate for outout -real shf_xy(nx,ny) ! mean precip. rate for outout -real lhf_xy(nx,ny) ! mean precip. rate for outout -real lwns_xy(nx,ny) ! mean net lw at SFC -real swns_xy(nx,ny) ! mean net sw at SFC -real lwnsc_xy(nx,ny) ! clear-sky mean net lw at SFC -real swnsc_xy(nx,ny) ! clear-sky mean net sw at SFC -real lwnt_xy(nx,ny) ! mean net lw at TOA -real swnt_xy(nx,ny) ! mean net sw at TOA -real lwntc_xy(nx,ny) ! clear-sky mean net lw at TOA -real swntc_xy(nx,ny) ! clear-sky mean net sw at TOA -real solin_xy(nx,ny) ! solar TOA insolation -real pw_xy(nx,ny) ! precipitable water -real cw_xy(nx,ny) ! cloud water path -real iw_xy(nx,ny) ! ice water path -real cld_xy(nx,ny) ! cloud frequency -real u200_xy(nx,ny) ! u-wind at 200 mb -real usfc_xy(nx,ny) ! u-wind at at the surface -real v200_xy(nx,ny) ! v-wind at 200 mb -real vsfc_xy(nx,ny) ! v-wind at the surface -real w500_xy(nx,ny) ! w at 500 mb -real qocean_xy(nx,ny) ! ocean cooling in W/m2 - -!---------------------------------------------------------------------- -! Vertical profiles of quantities sampled for statitistics purposes: - -real & - twle(nz), twsb(nz), precflux(nz), & - uwle(nz), uwsb(nz), vwle(nz), vwsb(nz), & - radlwup(nz), radlwdn(nz), radswup(nz), radswdn(nz), & - radqrlw(nz), radqrsw(nz), w_max, u_max, s_acld, s_acldcold, s_ar, s_arthr, s_sst, & - s_acldl, s_acldm, s_acldh, ncmn, nrmn, z_inv, z_cb, z_ct, z_cbmn, z_ctmn, & - z2_inv, z2_cb, z2_ct, cwpmean, cwp2, precmean, prec2, precmax, nrainy, ncloudy, & - s_acldisccp, s_acldlisccp, s_acldmisccp, s_acldhisccp, s_ptopisccp, & - s_acldmodis, s_acldlmodis, s_acldmmodis, s_acldhmodis, s_ptopmodis, & - s_acldmisr, s_ztopmisr, s_relmodis, s_reimodis, s_lwpmodis, s_iwpmodis, & - s_tbisccp, s_tbclrisccp, s_acldliqmodis, s_acldicemodis, & - s_cldtauisccp,s_cldtaumodis,s_cldtaulmodis,s_cldtauimodis,s_cldalbisccp, & - s_flns,s_flnt,s_flntoa,s_flnsc,s_flntoac,s_flds,s_fsns, & - s_fsnt,s_fsntoa,s_fsnsc,s_fsntoac,s_fsds,s_solin, & - tkeleadv(nz), tkelepress(nz), tkelediss(nz), tkelediff(nz),tkelebuoy(nz), & - t2leadv(nz),t2legrad(nz),t2lediff(nz),t2leprec(nz),t2lediss(nz), & - q2leadv(nz),q2legrad(nz),q2lediff(nz),q2leprec(nz),q2lediss(nz), & - twleadv(nz),twlediff(nz),twlepres(nz),twlebuoy(nz),twleprec(nz), & - qwleadv(nz),qwlediff(nz),qwlepres(nz),qwlebuoy(nz),qwleprec(nz), & - momleadv(nz,3),momlepress(nz,3),momlebuoy(nz,3), & - momlediff(nz,3),tadv(nz),tdiff(nz),tlat(nz), tlatqi(nz),qifall(nz),qpfall(nz) -real tdiff_xy(nz), tdiff_z(nz), ttest0(nzm), ttest1(nz), ttest2(nz, 10) !+++mhwang test - - -! register functions: - - -real, external :: esatw_crm,esati_crm,dtesatw_crm,dtesati_crm -real, external :: qsatw_crm,qsati_crm,dtqsatw_crm,dtqsati_crm -integer, external :: lenstr, bytes_in_rec - -! energy conservation diagnostics: - - real(kind=selected_real_kind(12)) total_water_before, total_water_after - real(kind=selected_real_kind(12)) total_water_evap, total_water_prec, total_water_ls -!#ifdef CLUBB_CRM - real(kind=selected_real_kind(12)) total_water_clubb - real(kind=selected_real_kind(12)) total_energy_before, total_energy_after - real(kind=selected_real_kind(12)) total_energy_evap, total_energy_prec, total_energy_ls - real(kind=selected_real_kind(12)) total_energy_clubb, total_energy_rad -!#endif - real(kind=selected_real_kind(12)) qtotmicro(5) ! total water for water conservation test in microphysics +++mhwang - -!=========================================================================== -! UW ADDITIONS - -! conditional average statistics, subsumes cloud_factor, core_factor, coredn_factor -integer :: ncondavg, icondavg_cld, icondavg_cor, icondavg_cordn, & - icondavg_satdn, icondavg_satup, icondavg_env -real, allocatable :: condavg_factor(:,:) ! replaces cloud_factor, core_factor -real, allocatable :: condavg_mask(:,:,:,:) ! indicator array for various conditional averages -character(LEN=8), allocatable :: condavgname(:) ! array of short names -character(LEN=25), allocatable :: condavglongname(:) ! array of long names - -real qlsvadv(nzm) ! Large-scale vertical advection tendency for total water -real tlsvadv(nzm) ! Large-scale vertical advection tendency for temperature -real ulsvadv(nzm) ! Large-scale vertical advection tendency for zonal velocity -real vlsvadv(nzm) ! Large-scale vertical advection tendency for meridional velocity - -real qnudge(nzm) ! Nudging of horiz.-averaged total water profile -real tnudge(nzm) ! Nudging of horiz.-averaged temperature profile -real unudge(nzm) ! Nudging of horiz.-averaged zonal velocity -real vnudge(nzm) ! Nudging of horiz.-averaged meridional velocity - -real qstor(nzm) ! Storage of horiz.-averaged total water profile -real tstor(nzm) ! Storage of horiz.-averaged temperature profile -real ustor(nzm) ! Storage of horiz.-averaged zonal velocity -real vstor(nzm) ! Storage of horiz.-averaged meridional velocity -real qtostor(nzm) ! Storage of horiz.-averaged total water profile (vapor + liquid) - -real utendcor(nzm) ! coriolis acceleration of zonal velocity -real vtendcor(nzm) ! coriolis acceleration of meridional velocity - -real CF3D(1:nx, 1:ny, 1:nzm) ! Cloud fraction - ! =1.0 when there is no fractional cloudiness scheme - ! = cloud fraction produced by fractioal cloudiness scheme when avaiable - -! 850 mbar horizontal winds -real u850_xy(nx,ny) ! zonal velocity at 850 mb -real v850_xy(nx,ny) ! meridional velocity at 850 mb - -! Surface pressure -real psfc_xy(nx,ny) ! pressure (in millibar) at lowest grid point - -! Saturated water vapor path, useful for computing column relative humidity -real swvp_xy(nx,ny) ! saturated water vapor path (wrt water) - -! Cloud and echo top heights, and cloud top temperature (instantaneous) -real cloudtopheight(nx,ny), echotopheight(nx,ny), cloudtoptemp(nx,ny) - -! END UW ADDITIONS -!=========================================================================== -! Initial bubble parameters. Activated when perturb_type = 2 - real bubble_x0 - real bubble_y0 - real bubble_z0 - real bubble_radius_hor - real bubble_radius_ver - real bubble_dtemp - real bubble_dq - real, allocatable :: naer(:,:) ! Aerosol number concentration [/m3] - real, allocatable :: vaer(:,:) ! aerosol volume concentration [m3/m3] - real, allocatable :: hgaer(:,:) ! hygroscopicity of aerosol mode - -end module crmx_vars diff --git a/src/physics/spcam/crm/crmx_zero.F90 b/src/physics/spcam/crm/crmx_zero.F90 deleted file mode 100644 index a3510da024..0000000000 --- a/src/physics/spcam/crm/crmx_zero.F90 +++ /dev/null @@ -1,16 +0,0 @@ - -subroutine zero - -use crmx_vars -use crmx_microphysics, only : total_water - -implicit none - -integer k - -dudt(:,:,:,na) = 0. -dvdt(:,:,:,na) = 0. -dwdt(:,:,:,na) = 0. -misc(:,:,:) = 0. - -end diff --git a/src/physics/spcam/crm/fft.F b/src/physics/spcam/crm/fft.F deleted file mode 100644 index 2d02fbd981..0000000000 --- a/src/physics/spcam/crm/fft.F +++ /dev/null @@ -1,787 +0,0 @@ - subroutine fft991_crm(a,work,trigs,ifax,inc,jump,n,lot,isign) - dimension a(*),work(*),trigs(*),ifax(*) -c -c subroutine "fft991" - multiple real/half-complex periodic -c fast fourier transform -c -c same as fft99 except that ordering of data corresponds to -c that in mrfft2 -c -c procedure used to convert to half-length complex transform -c is given by cooley, lewis and welch (j. sound vib., vol. 12 -c (1970), 315-337) -c -c a is the array containing input and output data -c work is an area of size (n+1)*lot -c trigs is a previously prepared list of trig function values -c ifax is a previously prepared list of factors of n/2 -c inc is the increment within each data 'vector' -c (e.g. inc=1 for consecutively stored data) -c jump is the increment between the start of each data vector -c n is the length of the data vectors -c lot is the number of data vectors -c isign = +1 for transform from spectral to gridpoint -c = -1 for transform from gridpoint to spectral -c -c ordering of coefficients: -c a(0),b(0),a(1),b(1),a(2),b(2),...,a(n/2),b(n/2) -c where b(0)=b(n/2)=0; (n+2) locations required -c -c ordering of data: -c x(0),x(1),x(2),...,x(n-1) -c -c vectorization is achieved on cray by doing the transforms in -c parallel -c -c *** n.b. n is assumed to be an even number -c -c definition of transforms: -c ------------------------- -c -c isign=+1: x(j)=sum(k=0,...,n-1)(c(k)*exp(2*i*j*k*pi/n)) -c where c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k) -c -c isign=-1: a(k)=(1/n)*sum(j=0,...,n-1)(x(j)*cos(2*j*k*pi/n)) -c b(k)=-(1/n)*sum(j=0,...,n-1)(x(j)*sin(2*j*k*pi/n)) -c -c -c - nfax=ifax(1) - nx=n+1 - nh=n/2 - ink=inc+inc - if (isign.eq.+1) go to 30 -c -c if necessary, transfer data to work area - igo=50 - if (mod(nfax,2).eq.1) goto 40 - ibase=1 - jbase=1 - do 20 l=1,lot - i=ibase - j=jbase -cdir$ ivdep - do 10 m=1,n - work(j)=a(i) - i=i+inc - j=j+1 - 10 continue - ibase=ibase+jump - jbase=jbase+nx - 20 continue -c - igo=60 - go to 40 -c -c preprocessing (isign=+1) -c ------------------------ -c - 30 continue - call fft99a_crm(a,work,trigs,inc,jump,n,lot) - igo=60 -c -c complex transform -c ----------------- -c - 40 continue - ia=1 - la=1 - do 80 k=1,nfax - if (igo.eq.60) go to 60 - 50 continue - call vpassm_crm(a(ia),a(ia+inc),work(1),work(2),trigs, - * ink,2,jump,nx,lot,nh,ifax(k+1),la) - igo=60 - go to 70 - 60 continue - call vpassm_crm(work(1),work(2),a(ia),a(ia+inc),trigs, - * 2,ink,nx,jump,lot,nh,ifax(k+1),la) - igo=50 - 70 continue - la=la*ifax(k+1) - 80 continue -c - if (isign.eq.-1) go to 130 -c -c if necessary, transfer data from work area - if (mod(nfax,2).eq.1) go to 110 - ibase=1 - jbase=1 - do 100 l=1,lot - i=ibase - j=jbase -cdir$ ivdep - do 90 m=1,n - a(j)=work(i) - i=i+1 - j=j+inc - 90 continue - ibase=ibase+nx - jbase=jbase+jump - 100 continue -c -c fill in zeros at end - 110 continue - ib=n*inc+1 -cdir$ ivdep - do 120 l=1,lot - a(ib)=0.0 - a(ib+inc)=0.0 - ib=ib+jump - 120 continue - go to 140 -c -c postprocessing (isign=-1): -c -------------------------- -c - 130 continue - call fft99b_crm(work,a,trigs,inc,jump,n,lot) -c - 140 continue - return - end - - - - - - subroutine fftfax_crm(n,ifax,trigs) - dimension ifax(13),trigs(*) -c -c mode 3 is used for real/half-complex transforms. it is possible -c to do complex/complex transforms with other values of mode, but -c documentation of the details were not available when this routine -c was written. -c - data mode /3/ - call fax_crm (ifax, n, mode) - i = ifax(1) -cgsp if (ifax(i+1) .gt. 5 .or. n .le. 4) ifax(1) = -99 -cgsp if (ifax(1) .le. 0 )call uliber(33,'fftfax -- invalid n', 20) - call fftrig_crm (trigs, n, mode) - return - end - - - - - - subroutine fax_crm(ifax,n,mode) - dimension ifax(*) - nn=n - if (iabs(mode).eq.1) go to 10 - if (iabs(mode).eq.8) go to 10 - nn=n/2 - if ((nn+nn).eq.n) go to 10 - ifax(1)=-99 - return - 10 k=1 -c test for factors of 4 - 20 if (mod(nn,4).ne.0) go to 30 - k=k+1 - ifax(k)=4 - nn=nn/4 - if (nn.eq.1) go to 80 - go to 20 -c test for extra factor of 2 - 30 if (mod(nn,2).ne.0) go to 40 - k=k+1 - ifax(k)=2 - nn=nn/2 - if (nn.eq.1) go to 80 -c test for factors of 3 - 40 if (mod(nn,3).ne.0) go to 50 - k=k+1 - ifax(k)=3 - nn=nn/3 - if (nn.eq.1) go to 80 - go to 40 -c now find remaining factors - 50 l=5 - inc=2 -c inc alternately takes on values 2 and 4 - 60 if (mod(nn,l).ne.0) go to 70 - k=k+1 - ifax(k)=l - nn=nn/l - if (nn.eq.1) go to 80 - go to 60 - 70 l=l+inc - inc=6-inc - go to 60 - 80 ifax(1)=k-1 -c ifax(1) contains number of factors - nfax=ifax(1) -c sort factors into ascending order - if (nfax.eq.1) go to 110 - do 100 ii=2,nfax - istop=nfax+2-ii - do 90 i=2,istop - if (ifax(i+1).ge.ifax(i)) go to 90 - item=ifax(i) - ifax(i)=ifax(i+1) - ifax(i+1)=item - 90 continue - 100 continue - 110 continue - return - end - - - - - - subroutine fftrig_crm(trigs,n,mode) - dimension trigs(*) - pi=2.0*asin(1.0) - imode=iabs(mode) - nn=n - if (imode.gt.1.and.imode.lt.6) nn=n/2 - del=(pi+pi)/float(nn) - l=nn+nn - do 10 i=1,l,2 - angle=0.5*float(i-1)*del - trigs(i)=cos(angle) - trigs(i+1)=sin(angle) - 10 continue - if (imode.eq.1) return - if (imode.eq.8) return - del=0.5*del - nh=(nn+1)/2 - l=nh+nh - la=nn+nn - do 20 i=1,l,2 - angle=0.5*float(i-1)*del - trigs(la+i)=cos(angle) - trigs(la+i+1)=sin(angle) - 20 continue - if (imode.le.3) return - del=0.5*del - la=la+nn - if (mode.eq.5) go to 40 - do 30 i=2,nn - angle=float(i-1)*del - trigs(la+i)=2.0*sin(angle) - 30 continue - return - 40 continue - del=0.5*del - do 50 i=2,n - angle=float(i-1)*del - trigs(la+i)=sin(angle) - 50 continue - return - end - - - - - - - - - - - subroutine fft99a_crm(a,work,trigs,inc,jump,n,lot) - dimension a(*),work(*),trigs(*) -c -c subroutine fft99a - preprocessing step for fft99, isign=+1 -c (spectral to gridpoint transform) -c - nh=n/2 - nx=n+1 - ink=inc+inc -c -c a(0) and a(n/2) - ia=1 - ib=n*inc+1 - ja=1 - jb=2 -cdir$ ivdep - do 10 l=1,lot - work(ja)=a(ia)+a(ib) - work(jb)=a(ia)-a(ib) - ia=ia+jump - ib=ib+jump - ja=ja+nx - jb=jb+nx - 10 continue -c -c remaining wavenumbers - iabase=2*inc+1 - ibbase=(n-2)*inc+1 - jabase=3 - jbbase=n-1 -c - do 30 k=3,nh,2 - ia=iabase - ib=ibbase - ja=jabase - jb=jbbase - c=trigs(n+k) - s=trigs(n+k+1) -cdir$ ivdep - do 20 l=1,lot - work(ja)=(a(ia)+a(ib))- - * (s*(a(ia)-a(ib))+c*(a(ia+inc)+a(ib+inc))) - work(jb)=(a(ia)+a(ib))+ - * (s*(a(ia)-a(ib))+c*(a(ia+inc)+a(ib+inc))) - work(ja+1)=(c*(a(ia)-a(ib))-s*(a(ia+inc)+a(ib+inc)))+ - * (a(ia+inc)-a(ib+inc)) - work(jb+1)=(c*(a(ia)-a(ib))-s*(a(ia+inc)+a(ib+inc)))- - * (a(ia+inc)-a(ib+inc)) - ia=ia+jump - ib=ib+jump - ja=ja+nx - jb=jb+nx - 20 continue - iabase=iabase+ink - ibbase=ibbase-ink - jabase=jabase+2 - jbbase=jbbase-2 - 30 continue -c - if (iabase.ne.ibbase) go to 50 -c wavenumber n/4 (if it exists) - ia=iabase - ja=jabase -cdir$ ivdep - do 40 l=1,lot - work(ja)=2.0*a(ia) - work(ja+1)=-2.0*a(ia+inc) - ia=ia+jump - ja=ja+nx - 40 continue -c - 50 continue - return - end - - - - - - subroutine fft99b_crm(work,a,trigs,inc,jump,n,lot) - dimension work(*),a(*),trigs(*) -c -c subroutine fft99b - postprocessing step for fft99, isign=-1 -c (gridpoint to spectral transform) -c - nh=n/2 - nx=n+1 - ink=inc+inc -c -c a(0) and a(n/2) - scale=1.0/float(n) - ia=1 - ib=2 - ja=1 - jb=n*inc+1 -cdir$ ivdep - do 10 l=1,lot - a(ja)=scale*(work(ia)+work(ib)) - a(jb)=scale*(work(ia)-work(ib)) - a(ja+inc)=0.0 - a(jb+inc)=0.0 - ia=ia+nx - ib=ib+nx - ja=ja+jump - jb=jb+jump - 10 continue -c -c remaining wavenumbers - scale=0.5*scale - iabase=3 - ibbase=n-1 - jabase=2*inc+1 - jbbase=(n-2)*inc+1 -c - do 30 k=3,nh,2 - ia=iabase - ib=ibbase - ja=jabase - jb=jbbase - c=trigs(n+k) - s=trigs(n+k+1) -cdir$ ivdep - do 20 l=1,lot - a(ja)=scale*((work(ia)+work(ib)) - * +(c*(work(ia+1)+work(ib+1))+s*(work(ia)-work(ib)))) - a(jb)=scale*((work(ia)+work(ib)) - * -(c*(work(ia+1)+work(ib+1))+s*(work(ia)-work(ib)))) - a(ja+inc)=scale*((c*(work(ia)-work(ib))-s*(work(ia+1)+work(ib+1))) - * +(work(ib+1)-work(ia+1))) - a(jb+inc)=scale*((c*(work(ia)-work(ib))-s*(work(ia+1)+work(ib+1))) - * -(work(ib+1)-work(ia+1))) - ia=ia+nx - ib=ib+nx - ja=ja+jump - jb=jb+jump - 20 continue - iabase=iabase+2 - ibbase=ibbase-2 - jabase=jabase+ink - jbbase=jbbase-ink - 30 continue -c - if (iabase.ne.ibbase) go to 50 -c wavenumber n/4 (if it exists) - ia=iabase - ja=jabase - scale=2.0*scale -cdir$ ivdep - do 40 l=1,lot - a(ja)=scale*work(ia) - a(ja+inc)=-scale*work(ia+1) - ia=ia+nx - ja=ja+jump - 40 continue -c - 50 continue - return - end - - - - subroutine vpassm_crm - & (a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la) - dimension a(*),b(*),c(*),d(*),trigs(*) -c -c subroutine "vpassm" - multiple version of "vpassa" -c performs one pass through data -c as part of multiple complex fft routine -c a is first real input vector -c b is first imaginary input vector -c c is first real output vector -c d is first imaginary output vector -c trigs is precalculated table of sines " cosines -c inc1 is addressing increment for a and b -c inc2 is addressing increment for c and d -c inc3 is addressing increment between a"s & b"s -c inc4 is addressing increment between c"s & d"s -c lot is the number of vectors -c n is length of vectors -c ifac is current factor of n -c la is product of previous factors -c - data sin36/0.587785252292473/,cos36/0.809016994374947/, - * sin72/0.951056516295154/,cos72/0.309016994374947/, - * sin60/0.866025403784437/ -c - m=n/ifac - iink=m*inc1 - jink=la*inc2 - jump=(ifac-1)*jink - ibase=0 - jbase=0 - igo=ifac-1 - if (igo.gt.4) return - go to (10,50,90,130),igo -c -c coding for factor 2 -c - 10 ia=1 - ja=1 - ib=ia+iink - jb=ja+jink - do 20 l=1,la - i=ibase - j=jbase -cdir$ ivdep - do 15 ijk=1,lot - c(ja+j)=a(ia+i)+a(ib+i) - d(ja+j)=b(ia+i)+b(ib+i) - c(jb+j)=a(ia+i)-a(ib+i) - d(jb+j)=b(ia+i)-b(ib+i) - i=i+inc3 - j=j+inc4 - 15 continue - ibase=ibase+inc1 - jbase=jbase+inc2 - 20 continue - if (la.eq.m) return - la1=la+1 - jbase=jbase+jump - do 40 k=la1,m,la - kb=k+k-2 - c1=trigs(kb+1) - s1=trigs(kb+2) - do 30 l=1,la - i=ibase - j=jbase -cdir$ ivdep - do 25 ijk=1,lot - c(ja+j)=a(ia+i)+a(ib+i) - d(ja+j)=b(ia+i)+b(ib+i) - c(jb+j)=c1*(a(ia+i)-a(ib+i))-s1*(b(ia+i)-b(ib+i)) - d(jb+j)=s1*(a(ia+i)-a(ib+i))+c1*(b(ia+i)-b(ib+i)) - i=i+inc3 - j=j+inc4 - 25 continue - ibase=ibase+inc1 - jbase=jbase+inc2 - 30 continue - jbase=jbase+jump - 40 continue - return -c -c coding for factor 3 -c - 50 ia=1 - ja=1 - ib=ia+iink - jb=ja+jink - ic=ib+iink - jc=jb+jink - do 60 l=1,la - i=ibase - j=jbase -cdir$ ivdep - do 55 ijk=1,lot - c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i)) - d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i)) - c(jb+j)=(a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i))) - c(jc+j)=(a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i))) - d(jb+j)=(b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i))) - d(jc+j)=(b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i))) - i=i+inc3 - j=j+inc4 - 55 continue - ibase=ibase+inc1 - jbase=jbase+inc2 - 60 continue - if (la.eq.m) return - la1=la+1 - jbase=jbase+jump - do 80 k=la1,m,la - kb=k+k-2 - kc=kb+kb - c1=trigs(kb+1) - s1=trigs(kb+2) - c2=trigs(kc+1) - s2=trigs(kc+2) - do 70 l=1,la - i=ibase - j=jbase -cdir$ ivdep - do 65 ijk=1,lot - c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i)) - d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i)) - c(jb+j)= - * c1*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))) - * -s1*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i)))) - d(jb+j)= - * s1*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))) - * +c1*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i)))) - c(jc+j)= - * c2*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))) - * -s2*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i)))) - d(jc+j)= - * s2*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))) - * +c2*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i)))) - i=i+inc3 - j=j+inc4 - 65 continue - ibase=ibase+inc1 - jbase=jbase+inc2 - 70 continue - jbase=jbase+jump - 80 continue - return -c -c coding for factor 4 -c - 90 ia=1 - ja=1 - ib=ia+iink - jb=ja+jink - ic=ib+iink - jc=jb+jink - id=ic+iink - jd=jc+jink - do 100 l=1,la - i=ibase - j=jbase -cdir$ ivdep - do 95 ijk=1,lot - c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i)) - c(jc+j)=(a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i)) - d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i)) - d(jc+j)=(b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)) - c(jb+j)=(a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i)) - c(jd+j)=(a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i)) - d(jb+j)=(b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)) - d(jd+j)=(b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)) - i=i+inc3 - j=j+inc4 - 95 continue - ibase=ibase+inc1 - jbase=jbase+inc2 - 100 continue - if (la.eq.m) return - la1=la+1 - jbase=jbase+jump - do 120 k=la1,m,la - kb=k+k-2 - kc=kb+kb - kd=kc+kb - c1=trigs(kb+1) - s1=trigs(kb+2) - c2=trigs(kc+1) - s2=trigs(kc+2) - c3=trigs(kd+1) - s3=trigs(kd+2) - do 110 l=1,la - i=ibase - j=jbase -cdir$ ivdep - do 105 ijk=1,lot - c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i)) - d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i)) - c(jc+j)= - * c2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))) - * -s2*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i))) - d(jc+j)= - * s2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))) - * +c2*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i))) - c(jb+j)= - * c1*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))) - * -s1*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i))) - d(jb+j)= - * s1*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))) - * +c1*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i))) - c(jd+j)= - * c3*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))) - * -s3*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i))) - d(jd+j)= - * s3*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))) - * +c3*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i))) - i=i+inc3 - j=j+inc4 - 105 continue - ibase=ibase+inc1 - jbase=jbase+inc2 - 110 continue - jbase=jbase+jump - 120 continue - return -c -c coding for factor 5 -c - 130 ia=1 - ja=1 - ib=ia+iink - jb=ja+jink - ic=ib+iink - jc=jb+jink - id=ic+iink - jd=jc+jink - ie=id+iink - je=jd+jink - do 140 l=1,la - i=ibase - j=jbase -cdir$ ivdep - do 135 ijk=1,lot - c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i)) - d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i)) - c(jb+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) - * -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))) - c(je+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) - * +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))) - d(jb+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) - * +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))) - d(je+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) - * -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))) - c(jc+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) - * -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))) - c(jd+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) - * +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))) - d(jc+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) - * +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))) - d(jd+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) - * -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))) - i=i+inc3 - j=j+inc4 - 135 continue - ibase=ibase+inc1 - jbase=jbase+inc2 - 140 continue - if (la.eq.m) return - la1=la+1 - jbase=jbase+jump - do 160 k=la1,m,la - kb=k+k-2 - kc=kb+kb - kd=kc+kb - ke=kd+kb - c1=trigs(kb+1) - s1=trigs(kb+2) - c2=trigs(kc+1) - s2=trigs(kc+2) - c3=trigs(kd+1) - s3=trigs(kd+2) - c4=trigs(ke+1) - s4=trigs(ke+2) - do 150 l=1,la - i=ibase - j=jbase -cdir$ ivdep - do 145 ijk=1,lot - c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i)) - d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i)) - c(jb+j)= - * c1*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) - * -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))) - * -s1*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) - * +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))) - d(jb+j)= - * s1*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) - * -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))) - * +c1*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) - * +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))) - c(je+j)= - * c4*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) - * +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))) - * -s4*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) - * -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))) - d(je+j)= - * s4*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i))) - * +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))) - * +c4*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i))) - * -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))) - c(jc+j)= - * c2*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) - * -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))) - * -s2*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) - * +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))) - d(jc+j)= - * s2*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) - * -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))) - * +c2*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) - * +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))) - c(jd+j)= - * c3*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) - * +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))) - * -s3*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) - * -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))) - d(jd+j)= - * s3*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i))) - * +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))) - * +c3*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i))) - * -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))) - i=i+inc3 - j=j+inc4 - 145 continue - ibase=ibase+inc1 - jbase=jbase+inc2 - 150 continue - jbase=jbase+jump - 160 continue - return - end - - - - - diff --git a/src/physics/spcam/crm/gammafff.c b/src/physics/spcam/crm/gammafff.c deleted file mode 100644 index 67f30643c4..0000000000 --- a/src/physics/spcam/crm/gammafff.c +++ /dev/null @@ -1,18 +0,0 @@ -/* - gamma-function for Fortran - (C) Marat Khairoutdinov */ - -#include -#include - -#ifdef __cplusplus -extern "C" { -#endif - -float gammafff(float *x) {return (float)exp(lgamma(*x));} - -float gammafff_(float *x) {return (float)exp(lgamma(*x));} - -#ifdef __cplusplus -} -#endif diff --git a/src/physics/spcam/crm_physics.F90 b/src/physics/spcam/crm_physics.F90 deleted file mode 100644 index 8812d2be72..0000000000 --- a/src/physics/spcam/crm_physics.F90 +++ /dev/null @@ -1,2503 +0,0 @@ -module crm_physics -!----------------------------------------------------------------------- -! Purpose: -! -! Provides the CAM interface to the crm code. -! -! Revision history: -! June, 2009, Minghuai Wang: -! crm_physics_tend -! July, 2009, Minghuai Wang: m2005_effradius -! -!--------------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8, shr_kind_cs - use ppgrid, only: pcols, pver, pverp -#ifdef CRM - use cam_abortutils, only: endrun - use physics_types, only: physics_state, physics_tend - use constituents, only: cnst_add, cnst_get_ind, cnst_set_spec_class, cnst_spec_class_cldphysics, & - cnst_spec_class_gas, cnst_name, cnst_longname, sflxnam, apcnst, bpcnst, pcnst - use modal_aerosol_properties_mod, only: modal_aerosol_properties - use modal_aerosol_state_mod, only: modal_aerosol_state - -#ifdef m2005 - use module_ecpp_ppdriver2, only: papampollu_init - use crmx_ecppvars, only: NCLASS_CL,ncls_ecpp_in,NCLASS_PR -#endif - - implicit none - private - save - - character(len=2) :: spcam_direction='NS' ! SPCAM 2D orientation - - public :: crm_physics_tend, crm_physics_register, crm_physics_init - public :: crm_implements_cnst, crm_init_cnst - public :: m2005_effradius - - integer :: crm_u_idx, crm_v_idx, crm_w_idx, crm_t_idx - integer :: crm_qt_idx, crm_nc_idx, crm_qr_idx, crm_nr_idx, crm_qi_idx, crm_ni_idx - integer :: crm_qs_idx, crm_ns_idx, crm_qg_idx, crm_ng_idx, crm_qc_idx, crm_qp_idx, crm_qn_idx - integer :: crm_t_rad_idx, crm_qv_rad_idx, crm_qc_rad_idx, crm_qi_rad_idx, crm_cld_rad_idx - integer :: crm_nc_rad_idx, crm_ni_rad_idx, crm_qs_rad_idx, crm_ns_rad_idx, crm_qrad_idx - integer :: crm_qaerwat_idx, crm_dgnumwet_idx - integer :: prec_dp_idx, snow_dp_idx, prec_sh_idx, snow_sh_idx - integer :: prec_sed_idx, snow_sed_idx, prec_pcw_idx, snow_pcw_idx - integer :: cldo_idx, cld_idx, cldtop_idx - integer :: rei_idx, rel_idx, rprdtot_idx, nevapr_idx, prain_idx - integer :: wsedl_idx, dei_idx, des_idx, mu_idx, lambdac_idx - integer :: rate1_cw2pr_st_idx - integer :: qme_idx, icwmrdp_idx, rprddp_idx, icwmrsh_idx, rprdsh_idx - integer :: nevapr_shcu_idx, nevapr_dpcu_idx, ast_idx - integer :: fice_idx,acldy_cen_idx, cmfmc_sh_idx - integer :: clubb_buffer_idx, tk_crm_idx, tke_idx, kvm_idx, kvh_idx, pblh_idx, tpert_idx - integer :: sh_frac_idx, dp_frac_idx - - integer :: & - ixcldliq, &! cloud liquid amount index - ixcldice, &! cloud ice amount index - ixnumliq, &! cloud liquid number index - ixnumice ! cloud ice water index - - integer :: nmodes - - integer, parameter :: ncnst = 4 ! Number of constituents - integer :: ncnst_use - character(len=8), parameter :: & ! Constituent names - cnst_names(ncnst) = (/'CLDLIQ', 'CLDICE','NUMLIQ','NUMICE'/) - - logical :: use_spcam, prog_modal_aero, do_clubb_sgs - logical :: is_spcam_m2005, is_spcam_sam1mom - - integer :: crm_nx_ny - - type(modal_aerosol_properties), pointer :: aero_props =>null() -#endif - -!======================================================================================================== -contains -!======================================================================================================== - -!--------------------------------------------------------------------------------------------------------- -subroutine crm_physics_register() -#ifdef CRM -!------------------------------------------------------------------------------------------------------- -! -! Purpose: add necessary fileds into physics buffer -! -!-------------------------------------------------------------------------------------------------------- - use spmd_utils, only: masterproc - use physconst, only: mwdry, cpair - use physics_buffer, only: dyn_time_lvls, pbuf_add_field, dtype_r8 - use phys_control, only: phys_getopts, cam_physpkg_is - use crmdims, only: crm_nx, crm_ny, crm_nz, crm_dx, crm_dy, crm_dt, nclubbvars - use cam_history_support,only: add_hist_coord - use crmx_setparm_mod, only: setparm - use rad_constituents, only: rad_cnst_get_info - - is_spcam_m2005 = cam_physpkg_is('spcam_m2005') - is_spcam_sam1mom = cam_physpkg_is('spcam_sam1mom') - - call phys_getopts( use_spcam_out = use_spcam) - call phys_getopts( prog_modal_aero_out = prog_modal_aero) - call phys_getopts( do_clubb_sgs_out = do_clubb_sgs) - - call rad_cnst_get_info(0, nmodes=nmodes) - - ! Register microphysics constituents and save indices. - - ncnst_use = 2 - call cnst_add(cnst_names(1), mwdry, cpair, 0._r8, ixcldliq, & - longname='Grid box averaged cloud liquid amount', is_convtran1=.true.) - call cnst_add(cnst_names(2), mwdry, cpair, 0._r8, ixcldice, & - longname='Grid box averaged cloud ice amount', is_convtran1=.true.) - if (is_spcam_m2005) then - call cnst_add(cnst_names(3), mwdry, cpair, 0._r8, ixnumliq, & - longname='Grid box averaged cloud liquid number', is_convtran1=.false.) - call cnst_add(cnst_names(4), mwdry, cpair, 0._r8, ixnumice, & - longname='Grid box averaged cloud ice number', is_convtran1=.false.) - ncnst_use = 4 - end if - - if(masterproc) then - print*,'_________________________________________' - print*,'_ Super-parameterization run ____________' - print*,'crm_nx=',crm_nx,' crm_ny=',crm_ny,' crm_nz=',crm_nz - print*,'crm_dx=',crm_dx,' crm_dy=',crm_dy,' crm_dt=',crm_dt - if (is_spcam_sam1mom) print*,'Microphysics: SAM1MOM' - if (is_spcam_m2005) print*,'Microphysics: M2005' - print*,'_________________________________________' - end if - - if (do_clubb_sgs) then - call pbuf_add_field('CLUBB_BUFFER','global', dtype_r8, (/pcols,crm_nx,crm_ny,crm_nz+1,nclubbvars/), clubb_buffer_idx) - call pbuf_add_field('tke', 'global', dtype_r8, (/pcols, pverp/), tke_idx) - call pbuf_add_field('kvm', 'global', dtype_r8, (/pcols, pverp/), kvm_idx) - call pbuf_add_field('kvh', 'global', dtype_r8, (/pcols, pverp/), kvh_idx) - call pbuf_add_field('pblh', 'global', dtype_r8, (/pcols, pverp/), pblh_idx) - call pbuf_add_field('tpert', 'global', dtype_r8, (/pcols, pverp/), tpert_idx) - end if - - call setparm() - - call pbuf_add_field('CRM_U', 'global', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz/), crm_u_idx) - call pbuf_add_field('CRM_V', 'global', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz/), crm_v_idx) - call pbuf_add_field('CRM_W', 'global', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz/), crm_w_idx) - call pbuf_add_field('CRM_T', 'global', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz/), crm_t_idx) - call pbuf_add_field('CLDO', 'global', dtype_r8, (/pcols, pver, dyn_time_lvls/), cldo_idx) - call pbuf_add_field('CLD', 'global', dtype_r8, (/pcols, pver, dyn_time_lvls/), cld_idx) - call pbuf_add_field('AST', 'global', dtype_r8, (/pcols, pver, dyn_time_lvls/), ast_idx) - - call pbuf_add_field('CRM_T_RAD', 'physpkg', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz/), crm_t_rad_idx) - call pbuf_add_field('CRM_QV_RAD', 'physpkg', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz/), crm_qv_rad_idx) - call pbuf_add_field('CRM_QC_RAD', 'physpkg', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz/), crm_qc_rad_idx) - call pbuf_add_field('CRM_QI_RAD', 'physpkg', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz/), crm_qi_rad_idx) - call pbuf_add_field('CRM_CLD_RAD', 'physpkg', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz/), crm_cld_rad_idx) - call pbuf_add_field('CRM_QRAD', 'global', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz/), crm_qrad_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) - call pbuf_add_field('PREC_SH', 'physpkg', dtype_r8, (/pcols/), prec_sh_idx) - call pbuf_add_field('SNOW_SH', 'physpkg', dtype_r8, (/pcols/), snow_sh_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) - 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('CLDTOP', 'physpkg', dtype_r8, (/pcols,1/), cldtop_idx ) - call pbuf_add_field('RPRDTOT', 'physpkg' ,dtype_r8, (/pcols,pver/), rprdtot_idx ) - call pbuf_add_field('ICWMRSH', 'physpkg' ,dtype_r8, (/pcols,pver/), icwmrsh_idx ) - call pbuf_add_field('RPRDSH', 'physpkg' ,dtype_r8, (/pcols,pver/), rprdsh_idx ) - call pbuf_add_field('NEVAPR_SHCU', 'physpkg' ,dtype_r8, (/pcols,pver/), nevapr_shcu_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('REI', 'physpkg', dtype_r8, (/pcols,pver/), rei_idx) - call pbuf_add_field('REL', 'physpkg', dtype_r8, (/pcols,pver/), rel_idx) - call pbuf_add_field('NEVAPR', 'physpkg', dtype_r8, (/pcols,pver/), nevapr_idx) - call pbuf_add_field('PRAIN', 'physpkg', dtype_r8, (/pcols,pver/), prain_idx) - call pbuf_add_field('WSEDL', 'physpkg', dtype_r8, (/pcols,pver/), wsedl_idx) - call pbuf_add_field('QME', 'physpkg', dtype_r8, (/pcols,pver/), qme_idx) - call pbuf_add_field('DEI', 'physpkg', dtype_r8, (/pcols,pver/), dei_idx) - call pbuf_add_field('DES', 'physpkg', dtype_r8, (/pcols,pver/), des_idx) - call pbuf_add_field('MU', 'physpkg', dtype_r8, (/pcols,pver/), mu_idx) - call pbuf_add_field('LAMBDAC', 'physpkg', dtype_r8, (/pcols,pver/), lambdac_idx) - call pbuf_add_field('CMFMC_SH', 'physpkg' ,dtype_r8, (/pcols,pverp/), cmfmc_sh_idx ) - - call pbuf_add_field('FICE', 'physpkg', dtype_r8, (/pcols,pver/), fice_idx) - - if (prog_modal_aero) then - call pbuf_add_field('RATE1_CW2PR_ST','physpkg', dtype_r8, (/pcols,pver/), rate1_cw2pr_st_idx) - call pbuf_add_field('CRM_QAERWAT', 'physpkg', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz, nmodes/), crm_qaerwat_idx) - call pbuf_add_field('CRM_DGNUMWET', 'physpkg', dtype_r8, (/pcols,crm_nx, crm_ny, crm_nz, nmodes/), crm_dgnumwet_idx) - endif - - if (is_spcam_m2005) then - call pbuf_add_field('CRM_NC_RAD', 'physpkg', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_nc_rad_idx) - call pbuf_add_field('CRM_NI_RAD', 'physpkg', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_ni_rad_idx) - call pbuf_add_field('CRM_QS_RAD', 'physpkg', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_qs_rad_idx) - call pbuf_add_field('CRM_NS_RAD', 'physpkg', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_ns_rad_idx) - - ! Fields for crm_micro array - call pbuf_add_field('CRM_QT', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_qt_idx) - call pbuf_add_field('CRM_NC', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_nc_idx) - call pbuf_add_field('CRM_QR', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_qr_idx) - call pbuf_add_field('CRM_NR', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_nr_idx) - call pbuf_add_field('CRM_QI', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_qi_idx) - call pbuf_add_field('CRM_NI', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_ni_idx) - call pbuf_add_field('CRM_QS', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_qs_idx) - call pbuf_add_field('CRM_NS', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_ns_idx) - call pbuf_add_field('CRM_QG', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_qg_idx) - call pbuf_add_field('CRM_NG', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_ng_idx) - call pbuf_add_field('CRM_QC', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_qc_idx) - else - call pbuf_add_field('CRM_QT', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_qt_idx) - call pbuf_add_field('CRM_QP', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_qp_idx) - call pbuf_add_field('CRM_QN', 'global', dtype_r8, (/pcols, crm_nx, crm_ny, crm_nz/), crm_qn_idx) - endif - - - if (is_spcam_m2005) then - call pbuf_add_field('TK_CRM', 'global', dtype_r8, (/pcols, pver/), tk_crm_idx) - ! total (all sub-classes) cloudy fractional area in previous time step - call pbuf_add_field('ACLDY_CEN', 'global', dtype_r8, (/pcols,pver/), acldy_cen_idx) - endif - -! Adding crm dimensions to cam history - call add_hist_coord('crm_nx' ,crm_nx, 'CRM NX') - call add_hist_coord('crm_ny' ,crm_ny, 'CRM NY') - call add_hist_coord('crm_nz' ,crm_nz, 'CRM NZ') - call add_hist_coord('crm_z1' ,crm_nz+1,'CRM_Z1') - - call add_hist_coord('pverp' ,pverp, 'pverp ') - call add_hist_coord('pver' ,pver, 'pver ') - -! ifdef needed because of NCLASS_CL -#ifdef m2005 - call add_hist_coord('NCLASS_CL' ,NCLASS_CL,'NCLASS_CL') - call add_hist_coord('ncls_ecpp_in' ,ncls_ecpp_in,'ncls_ecpp_in') - call add_hist_coord('NCLASS_PR' ,NCLASS_PR,'NCLASS_PR') -#endif - -#endif - -end subroutine crm_physics_register -!========================================================================================================= - -subroutine crm_physics_init(pbuf2d) -!------------------------------------------------------------------------------------------------------- -! -! Purpose: initialize some variables, and add necessary fileds into output fields -! -!-------------------------------------------------------------------------------------------------------- - use physics_buffer, only: physics_buffer_desc, pbuf_set_field, pbuf_get_index -#ifdef CRM - use physconst, only: tmelt, rair, cpair, rh2o, latvap, latice - use constituents, only: pcnst, cnst_species_class, cnst_spec_class_gas - use cam_history, only: addfld, add_default, horiz_only - use crmdims, only: crm_nx, crm_ny, crm_nz - use ndrop, only: ndrop_init - use gas_wetdep_opts, only: gas_wetdep_method - use micro_pumas_utils, only: micro_pumas_utils_init - use time_manager, only: is_first_step - - use cam_history, only: fieldname_len -#ifdef MODAL_AERO - use modal_aero_data, only: cnst_name_cw, ntot_amode, & - lmassptr_amode, lmassptrcw_amode, & - nspec_amode, numptr_amode, numptrcw_amode -#endif - -#endif - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - -#ifdef CRM - integer :: l, lphase, lspec - character(len=fieldname_len+3) :: fieldname - character(128) :: long_name - character(8) :: unit - -! local variables - integer :: i, m, mm - integer :: icldphy ! index for cloud physic species (water vapor and cloud hydrometers) - - character(len=128):: errstring ! return status (non-blank for error return) - - crm_nx_ny = crm_nx*crm_ny - - !------------------------- - ! Make sure gas_wetdep_method is set to 'MOZ' as 'NEU' is not currently supported by SPCAM - ! 'MOZ' for spcam_sam1mom - ! 'OFF' for spcam_m2005 - if (is_spcam_sam1mom) then - if (gas_wetdep_method /= 'MOZ') call endrun( "crm_physics: gas_wetdep_method must be set to 'MOZ' ") - elseif (is_spcam_m2005) then - if (gas_wetdep_method /= 'OFF') call endrun( "crm_physics: gas_wetdep_method must be set to 'OFF' ") - else - call endrun( "crm_physics: don't know how gas_wetdep_method should be set") - endif - - !------------------------- - ! Initialize the micro_pumas_utils - ! Value of dcs in MG 1.0 is 400.e-6_r8 - call micro_pumas_utils_init(r8, rair, rh2o, cpair, tmelt, latvap, latice, 400.e-6_r8, errstring) - - !------------------------- - ! Register general history fields - do m = 1, ncnst_use - call cnst_get_ind(cnst_names(m), mm) - if ( any(mm == (/ ixcldliq, ixcldice /)) ) 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 /)) ) 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( "crm_physics: Could not call addfld for constituent with unknown units.") - endif - end do - - do m=1, pcnst - if(cnst_name(m) == 'DMS') then - call addfld('DMSCONV', (/ 'lev' /), 'A', 'kg/kg/s', 'DMS tendency from ZM convection') - end if - if(cnst_name(m) == 'SO2') then - call addfld('SO2CONV', (/ 'lev' /), 'A', 'kg/kg/s', 'SO2 tendency from ZM convection') - end if - end do - - call addfld ('CRM_TK', (/'crm_nx','crm_ny','crm_nz'/), 'A', 'm^2/s', 'Eddy viscosity from CRM') - call addfld ('CRM_TKH', (/'crm_nx','crm_ny','crm_nz'/), 'A', 'm^2/s', 'Eddy viscosity from CRM') - - call addfld ('SPCLD3D ', (/ 'lev' /), 'A', 'fraction', 'cloud fraction on GCM grids') - call addfld ('MU_CRM ', (/ 'lev' /), 'A', 'Pa/s', 'mass flux up from CRM') - call addfld ('MD_CRM ', (/ 'lev' /), 'A', 'Pa/s', 'mass flux down from CRM') - call addfld ('DU_CRM ', (/ 'lev' /), 'A', '/s', 'detrainment from updraft from CRM') - call addfld ('EU_CRM ', (/ 'lev' /), 'A', '/s', 'entraiment rate from updraft') - call addfld ('ED_CRM ', (/ 'lev' /), 'A', '/s', 'entraiment rate from downdraft') - call addfld ('SPQRL ', (/ 'lev' /), 'A', 'K/s', 'long-wave heating rate') - call addfld ('SPQRS ', (/ 'lev' /), 'A', 'K/s', 'short-wave heating rate') - call addfld ('LENGC ', (/ 'ilev' /), 'A', 'm ', 'Mixing length scale for the calcuation of vertical difusivity') - - call addfld ('SPKVH ',(/ 'ilev' /), 'A', 'm2/s ', 'Vertical diffusivity used in dropmixnuc in the MMF call') - call addfld ('SPLCLOUD ',(/ 'lev' /), 'A', ' ', 'Liquid cloud fraction') - call add_default ('SPKVH ', 1, ' ') - call add_default ('SPLCLOUD ', 1, ' ') - - call addfld ('SPCLDTOT', horiz_only, 'A', 'fraction', 'Vertically-integrated total cloud from CRM' ) - call addfld ('SPCLDLOW', horiz_only, 'A', 'fraction', 'Vertically-integrated low cloud from CRM' ) - call addfld ('SPCLDMED', horiz_only, 'A', 'fraction', 'Vertically-integrated mid-level cloud from CRM' ) - call addfld ('SPCLDHGH', horiz_only, 'A', 'fraction', 'Vertically-integrated high cloud from CRM' ) - call add_default ('SPCLDTOT', 1, ' ') - call add_default ('SPCLDLOW', 1, ' ') - call add_default ('SPCLDMED', 1, ' ') - call add_default ('SPCLDHGH', 1, ' ') - - call addfld(apcnst(ixcldliq), (/ 'lev' /), 'A', 'kg/kg ', trim(cnst_name(ixcldliq))//' after physics' ) - call addfld(bpcnst(ixcldliq), (/ 'lev' /), 'A', 'kg/kg ', trim(cnst_name(ixcldliq))//' before physics' ) - call addfld(apcnst(ixcldice), (/ 'lev' /), 'A', 'kg/kg ', trim(cnst_name(ixcldice))//' after physics' ) - call addfld(bpcnst(ixcldice), (/ 'lev' /), 'A', 'kg/kg ', trim(cnst_name(ixcldice))//' before physics' ) - - call addfld ('PRES ',(/ 'lev' /), 'A', 'Pa ','Pressure' ) - call addfld ('DPRES ',(/ 'lev' /), 'A', 'Pa ','Pressure thickness of layer' ) - call addfld ('SPDT ',(/ 'lev' /), 'A', 'K/s ','T tendency due to CRM' ) - call addfld ('SPDQ ',(/ 'lev' /), 'A', 'kg/kg/s ','Q tendency due to CRM' ) - call addfld ('SPDQC ',(/ 'lev' /), 'A', 'kg/kg/s ','QC tendency due to CRM' ) - call addfld ('SPDQI ',(/ 'lev' /), 'A', 'kg/kg/s ','QI tendency due to CRM' ) - call addfld ('SPMC ',(/ 'lev' /), 'A', 'kg/m2/s ','Total mass flux from CRM' ) - call addfld ('SPMCUP ',(/ 'lev' /), 'A', 'kg/m2/s ','Updraft mass flux from CRM' ) - call addfld ('SPMCDN ',(/ 'lev' /), 'A', 'kg/m2/s ','Downdraft mass flux from CRM' ) - call addfld ('SPMCUUP ',(/ 'lev' /), 'A', 'kg/m2/s ','Unsaturated updraft mass flux from CRM' ) - call addfld ('SPMCUDN ',(/ 'lev' /), 'A', 'kg/m2/s ','Unsaturated downdraft mass flux from CRM') - call addfld ('SPQC ',(/ 'lev' /), 'A', 'kg/kg ','Cloud water from CRM' ) - call addfld ('SPQI ',(/ 'lev' /), 'A', 'kg/kg ','Cloud ice from CRM' ) - call addfld ('SPQS ',(/ 'lev' /), 'A', 'kg/kg ','Snow from CRM' ) - call addfld ('SPQG ',(/ 'lev' /), 'A', 'kg/kg ','Graupel from CRM' ) - call addfld ('SPQR ',(/ 'lev' /), 'A', 'kg/kg ','Rain from CRM' ) - call addfld ('SPQTFLX ',(/ 'lev' /), 'A', 'kg/m2/s ','Nonprecip. water flux from CRM' ) - call addfld ('SPUFLX ',(/ 'lev' /), 'A', 'm2/s2 ','x-momentum flux from CRM' ) - call addfld ('SPVFLX ',(/ 'lev' /), 'A', 'm2/s2 ','y-momentum flux from CRM' ) - call addfld ('SPQTFLXS',(/ 'lev' /), 'A', 'kg/m2/s ','SGS Nonprecip. water flux from CRM' ) - call addfld ('SPTKE ',(/ 'lev' /), 'A', 'kg/m/s2 ','Total TKE in CRM' ) - call addfld ('SPTKES ',(/ 'lev' /), 'A', 'kg/m/s2 ','SGS TKE in CRM' ) - call addfld ('SPTK ',(/ 'lev' /), 'A', 'm2/s ','SGS TK in CRM' ) - call addfld ('SPQPFLX ',(/ 'lev' /), 'A', 'kg/m2/s ','Precip. water flux from CRM' ) - call addfld ('SPPFLX ',(/ 'lev' /), 'A', 'm/s ','Precipitation flux from CRM' ) - call addfld ('SPQTLS ',(/ 'lev' /), 'A', 'kg/kg/s ','L.S. Vapor Tendency from CRM' ) - call addfld ('SPQTTR ',(/ 'lev' /), 'A', 'kg/kg/s ','Nonprec. water transport from CRM' ) - call addfld ('SPQPTR ',(/ 'lev' /), 'A', 'kg/kg/s ','Prec. water transport from CRM' ) - call addfld ('SPQPEVP ',(/ 'lev' /), 'A', 'kg/kg/s ','Prec. water evaporation from CRM' ) - call addfld ('SPQPFALL',(/ 'lev' /), 'A', 'kg/kg/s ','Prec. water fall-out from CRM' ) - call addfld ('SPQPSRC ',(/ 'lev' /), 'A', 'kg/kg/s ','Prec. water source from CRM' ) - call addfld ('SPTLS ',(/ 'lev' /), 'A', 'kg/kg/s ','L.S. LIWSE Tendency from CRM' ) - call addfld ('TIMINGF ', horiz_only, 'A', ' ','CRM CPU usage efficiency: 1 - ideal' ) - call addfld ('CLOUDTOP',(/ 'lev' /), 'A', ' ','Cloud Top PDF' ) - - !------------------------- - ! Register m2005 history fields - if (is_spcam_m2005) then - call addfld ('SPNC ',(/ 'lev' /), 'A', '/kg ','Cloud water dropet number from CRM') - call addfld ('SPNI ',(/ 'lev' /), 'A', '/kg ','Cloud ice crystal number from CRM') - call addfld ('SPNS ',(/ 'lev' /), 'A', '/kg ','Snow particle number from CRM') - call addfld ('SPNG ',(/ 'lev' /), 'A', '/kg ','Graupel particle number from CRM') - call addfld ('SPNR ',(/ 'lev' /), 'A', '/kg ','Rain particle number from CRM') - call add_default ('SPNC ', 1, ' ') - call add_default ('SPNI ', 1, ' ') - call add_default ('SPNS ', 1, ' ') - call add_default ('SPNG ', 1, ' ') - call add_default ('SPNR ', 1, ' ') - - call addfld ('CRM_FLIQ ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '1 ','Frequency of Occurrence of Liquid' ) - call addfld ('CRM_FICE ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '1 ','Frequency of Occurrence of Ice' ) - call addfld ('CRM_FRAIN',(/'crm_nx','crm_ny','crm_nz'/), 'A', '1 ','Frequency of Occurrence of Rain' ) - call addfld ('CRM_FSNOW',(/'crm_nx','crm_ny','crm_nz'/), 'A', '1 ','Frequency of Occurrence of Snow' ) - call addfld ('CRM_FGRAP',(/'crm_nx','crm_ny','crm_nz'/), 'A', '1 ','Frequency of Occurrence of Graupel' ) - call addfld ('CRM_QS ',(/'crm_nx','crm_ny','crm_nz'/), 'A', 'kg/kg ','Snow mixing ratio from CRM' ) - call addfld ('CRM_QG ',(/'crm_nx','crm_ny','crm_nz'/), 'A', 'kg/kg ','Graupel mixing ratio from CRM' ) - call addfld ('CRM_QR ',(/'crm_nx','crm_ny','crm_nz'/), 'A', 'kg/kg ','Rain mixing ratio from CRM' ) - - call addfld ('CRM_NC ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/kg ','Cloud water dropet number from CRM' ) - call addfld ('CRM_NI ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/kg ','Cloud ice crystal number from CRM' ) - call addfld ('CRM_NS ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/kg ','Snow particle number from CRM' ) - call addfld ('CRM_NG ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/kg ','Graupel particle number from CRM' ) - call addfld ('CRM_NR ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/kg ','Rain particle number from CRM' ) - - ! below is for *instantaneous* crm output - call addfld ('CRM_AUT ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/s ','Autoconversion cloud waterfrom CRM' ) - call addfld ('CRM_ACC ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/s ','Accretion cloud water from CRM' ) - call addfld ('CRM_EVPC ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/s ','Evaporation cloud water from CRM' ) - call addfld ('CRM_EVPR ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/s ','Evaporation rain from CRM' ) - call addfld ('CRM_MLT ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/s ','Melting ice snow graupel from CRM' ) - call addfld ('CRM_SUB ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/s ','Sublimation ice snow graupel from CRM' ) - call addfld ('CRM_DEP ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/s ','Deposition ice snow graupel from CRM' ) - call addfld ('CRM_CON ',(/'crm_nx','crm_ny','crm_nz'/), 'A', '/s ','Condensation cloud water from CRM' ) - - ! below is for *gcm-grid and time-step-avg* process output - call addfld ('A_AUT ',(/ 'lev' /), 'A', '/s ','Avg autoconversion cloud water from CRM' ) - call addfld ('A_ACC ',(/ 'lev' /), 'A', '/s ','Avg accretion cloud water from CRM' ) - call addfld ('A_EVPC ',(/ 'lev' /), 'A', '/s ','Avg evaporation cloud water from CRM' ) - call addfld ('A_EVPR ',(/ 'lev' /), 'A', '/s ','Avg evaporation rain from CRM' ) - call addfld ('A_MLT ',(/ 'lev' /), 'A', '/s ','Avg melting ice snow graupel from CRM' ) - call addfld ('A_SUB ',(/ 'lev' /), 'A', '/s ','Avg sublimation ice snow graupel from CRM' ) - call addfld ('A_DEP ',(/ 'lev' /), 'A', '/s ','Avg deposition ice snow graupel from CRM' ) - call addfld ('A_CON ',(/ 'lev' /), 'A', '/s ','Avg condensation cloud water from CRM' ) - - call addfld ('CRM_REL ', (/'crm_nx','crm_ny','crm_nz'/), 'A', 'micrometers', 'cloud scale droplet effective radius') - call addfld ('CRM_REI ', (/'crm_nx','crm_ny','crm_nz'/), 'A', 'micrometers', 'cloud scale ice crystal effective radius') - call addfld ('CRM_DEI ', (/'crm_nx','crm_ny','crm_nz'/), 'A', 'micrometers', 'cloud scale Mitchell ice effective diameter') - call addfld ('CRM_DES ', (/'crm_nx','crm_ny','crm_nz'/), 'A', 'micrometers', 'cloud scale snow effective diameter') - call addfld ('CRM_MU ', (/'crm_nx','crm_ny','crm_nz'/), 'A', 'micrometers', & - 'cloud scale droplet size distribution shape parameter for radiation') - call addfld ('CRM_LAMBDA',(/'crm_nx','crm_ny','crm_nz'/), 'A', 'micrometers', & - 'cloud scale slope of droplet distribution for radiation') - call addfld ('CRM_TAU ', (/'crm_nx','crm_ny','crm_nz'/), 'A', '1', 'cloud scale cloud optical depth' ) - call addfld ('CRM_WVAR' , (/'crm_nx','crm_ny','crm_nz'/), 'A', 'm/s', 'vertical velocity variance from CRM') - - call addfld ('CRM_FSNT', (/'crm_nx','crm_ny'/), 'A', 'unitless', 'net TOA shortwave fluxes at CRM grids') - call addfld ('CRM_FSNTC', (/'crm_nx','crm_ny'/), 'A', 'unitless', 'net TOA clear-sky shortwave fluxes at CRM grids') - call addfld ('CRM_FSNS', (/'crm_nx','crm_ny'/), 'A', 'unitless', 'net surface shortwave fluxes at CRM grids') - call addfld ('CRM_FSNSC', (/'crm_nx','crm_ny'/), 'A', 'unitless', & - 'net surface clear-sky shortwave fluxes at CRM grids') - call addfld ('CRM_FLNT', (/'crm_nx','crm_ny'/), 'A', 'unitless', 'net TOA longwave fluxes at CRM grids') - call addfld ('CRM_FLNTC', (/'crm_nx','crm_ny'/), 'A', 'unitless', 'net TOA clear-sky longwave fluxes at CRM grids') - call addfld ('CRM_FLNS', (/'crm_nx','crm_ny'/), 'A', 'unitless', 'net surface longwave fluxes at CRM grids') - call addfld ('CRM_FLNSC', (/'crm_nx','crm_ny'/), 'A', 'unitless', & - 'net surface clear-sky longwave fluxes at CRM grids') - - call addfld ('CRM_AODVIS', (/'crm_nx','crm_ny'/), 'A', 'unitless', 'Aerosol optical depth at 550nm in CRM grids',& - flag_xyfill=.true.) - call addfld ('CRM_AOD400', (/'crm_nx','crm_ny'/), 'A', 'unitless', 'Aerosol optical depth at 400nm in CRM grids',& - flag_xyfill=.true.) - call addfld ('CRM_AOD700', (/'crm_nx','crm_ny'/), 'A', 'unitless', 'Aerosol optical depth at 700nm in CRM grids', & - flag_xyfill=.true.) - call addfld ('CRM_AODVISZ',(/'crm_nx','crm_ny','crm_nz'/), 'A', 'unitless', & - 'Aerosol optical depth at each layer at 500nm in CRM grids', flag_xyfill=.true.) - call addfld ('AOD400', horiz_only, 'A', 'unitless', 'Aerosol optical depth at 400nm', & - flag_xyfill=.true.) - call addfld ('AOD700', horiz_only, 'A', 'unitless', 'Aerosol optical depth at 700nm', & - flag_xyfill=.true.) - call add_default ('AOD400', 1, ' ') - call add_default ('AOD700', 1, ' ') - endif - - !------------------------- - ! Register CLUBB history fields - if (do_clubb_sgs) then - call addfld ('UP2 ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'm^2/s^2', 'u prime ^2 from clubb') - call addfld ('VP2 ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'm^2/s^2', 'v prime ^2 from clubb') - call addfld ('WPRTP ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'mkg/skg', 'w prime * rt prime from clubb') - call addfld ('WPTHLP ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'mK/s', 'w prime * th_l prime from clubb') - call addfld ('WP2 ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'm^2/s^2', 'w prime ^2 from clubb') - call addfld ('WP3 ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'm^3/s^3', 'w prime ^3 from clubb') - call addfld ('RTP2 ', (/'crm_nx','crm_ny','crm_z1'/), 'A', '(kg/kg)2', 'r_t prime ^2 from clubb') - call addfld ('THLP2 ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'K^2', 'th_l_prime ^2 from clubb') - call addfld ('RTPTHLP ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'kgK/kg', 'r_t prime * th_l prime from clubb') - call addfld ('UPWP ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'm^2/s^2', 'u prime * w prime from clubb') - call addfld ('VPWP ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'm^2/s^2', 'v prime * w prime from clubb') - call addfld ('CRM_CLD ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'fraction', 'cloud fraction from clubb') - call addfld ('T_TNDCY ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'K/s', 't tendency from clubb') - call addfld ('QV_TNDCY ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'kg/kg/s', 'water vapor tendency from clubb') - call addfld ('QC_TNDCY ', (/'crm_nx','crm_ny','crm_z1'/), 'A', 'kg/kg/s', 'liquid condensate tendency from clubb') - call addfld ('CLUBB_TK', (/'crm_nx','crm_ny','crm_nz'/), 'A', 'm^2/s', 'Eddy viscosity from clubb') - call addfld ('CLUBB_TKH', (/'crm_nx','crm_ny','crm_nz'/), 'A', 'm^2/s', 'Eddy viscosity from clubb') - call addfld ('CRM_RELVAR', (/'crm_nx','crm_ny','crm_nz'/), 'A', '', 'cloud water relative variance from clubb') - call addfld ('ACCRE_ENHAN', (/'crm_nx','crm_ny','crm_nz'/), 'A', '', 'Accretion enhancment from clubb') - call addfld ('QCLVAR', (/'crm_nx','crm_ny','crm_nz'/), 'A', '(kg/kg)^2', 'cloud water variance from clubb') - ! add GCM-scale output - call addfld ('SPUP2', (/ 'lev' /), 'A', 'm^2/s^2', 'u prime ^2 from clubb on GCM grids') - call addfld ('SPVP2', (/ 'lev' /), 'A', 'm^2/s^2', 'v prime ^2 from clubb on GCM grids') - call addfld ('SPWPRTP', (/ 'lev' /), 'A', 'mkg/skg', 'w prime * rt prime from clubb on GCM grids') - call addfld ('SPWPTHLP', (/ 'lev' /), 'A', 'mK/s', 'w prime * th_l prime from clubb on GCM grids') - call addfld ('SPWP2', (/ 'lev' /), 'A', 'm^2/s^2', 'w prime ^2 from clubb on GCM grids') - call addfld ('SPWP3', (/ 'lev' /), 'A', 'm^3/s^3', 'w prime ^3 from clubb on GCM grids') - call addfld ('SPRTP2', (/ 'lev' /), 'A', '(kg/kg)2', 'r_t prime ^2 from clubb on GCM grids') - call addfld ('SPTHLP2', (/ 'lev' /), 'A', 'K^2', 'th_l_prime ^2 from clubb on GCM grids') - call addfld ('SPRTPTHLP', (/ 'lev' /), 'A', 'kgK/kg', 'r_t prime * th_l prime from clubb on GCM grids') - call addfld ('SPUPWP', (/ 'lev' /), 'A', 'm^2/s^2', 'u prime * w prime from clubb on GCM grids') - call addfld ('SPVPWP', (/ 'lev' /), 'A', 'm^2/s^2', 'v prime * w prime from clubb on GCM grids') - call addfld ('SPCRM_CLD ', (/ 'lev' /), 'A', 'fraction', 'cloud fraction from clubb on GCM grids') - call addfld ('SPT_TNDCY ', (/ 'lev' /), 'A', 'K/s', 't tendency from clubb on GCM grids') - call addfld ('SPQV_TNDCY ', (/ 'lev' /), 'A', 'kg/kg/s', 'water vapor tendency from clubb on GCM grids') - call addfld ('SPQC_TNDCY ', (/ 'lev' /), 'A', 'kg/kg/s', 'liquid condensate tendency from clubb on GCM grids') - call addfld ('SPCLUBB_TK', (/ 'lev' /), 'A', 'm^2/s', 'Eddy viscosity from clubb on GCM grids') - call addfld ('SPCLUBB_TKH', (/ 'lev' /), 'A', 'm^2/s', 'Eddy viscosity from clubb on GCM grids') - call addfld ('SPRELVAR', (/ 'lev' /), 'A', '', 'cloud water relative variance from clubb on GCM grids') - call addfld ('SPACCRE_ENHAN',(/ 'lev' /), 'A', '', 'Accretion enhancment from clubb on GCM grids') - call addfld ('SPQCLVAR', (/ 'lev' /), 'A', '', 'cloud water variance from clubb on GCM grids') - endif - - - !------------------------- - ! Register ECPP history fields - ! ifdef needed because of ECPP parameters such as NCLASS_CL and ncls_ecpp_in and papampollu_init -#ifdef m2005 - if (is_spcam_m2005) then - - call papampollu_init () - - call addfld ('ABND ', (/'ilev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'fraction', & - 'cloud fraction for each sub-sub class for full time period at layer boundary') - call addfld ('ABND_TF ', (/'ilev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'fraction', & - 'cloud fraction for each sub-sub class for end-portion of time period at layer boundary') - call addfld ('MASFBND ', (/'ilev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'kg/m2/s', & - 'sub-class vertical mass flux (kg/m2/s) at layer boundary') - call addfld ('ACEN ', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'fraction', & - 'cloud fraction for each sub-sub class for full time period at layer center') - call addfld ('ACEN_TF ', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'fraction', & - 'cloud fraction for each sub-sub class for end-portion of time period at layer center') - call addfld ('RHCEN ', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'fraction', & - 'relative humidity for each sub-sub calss at layer center') - call addfld ('QCCEN ', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'kg/kg', & - 'cloud water for each sub-sub class at layer center') - call addfld ('QICEN ', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'kg/kg', & - 'cloud ice for each sub-sub class at layer center') - call addfld ('QSINK_AFCEN', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', '/s', & - 'cloud water loss rate from precip. using cloud water after precip. for each sub-sub class at layer center') - call addfld ('QSINK_BFCEN', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', '/s', & - 'cloud water loss rate from precip. using cloud water before precip. for each sub-sub class at layer center') - call addfld ('QSINK_AVGCEN', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', '/s', & - 'cloud water loss rate from precip. using averaged cloud water and precip. rate for each sub-sub class at layer center') - call addfld ('PRAINCEN', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'kg/kg/s', & - ' cloud water loss rate from precipitation (kg/kg/s) for each sub-sub class at layer center') - call addfld ('PRECRCEN', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'kg/m2/s', & - 'liquid (rain) precipitation rate for each sub-sub class at layer center') - call addfld ('PRECSCEN', (/'lev ','NCLASS_CL ','ncls_ecpp_in','NCLASS_PR '/), 'A', 'kg/m2/s', & - 'solid (snow, graupel,...) precipitation rate for each sub-sub class at layer center') - call addfld ('WUPTHRES', (/ 'ilev' /), 'A', 'm/s', 'vertical velocity threshold for updraft') - call addfld ('WDNTHRES', (/ 'ilev' /), 'A', 'm/s', 'vertical velocity threshold for dndraft') - call addfld ('WWQUI_CEN', (/ 'lev' /), 'A', 'm2/s2', 'vertical velocity variance in the quiescent class, layer center') - call addfld ('WWQUI_CLD_CEN', (/ 'lev' /), 'A', 'm2/s2', & - 'vertical velocity variance in the cloudy quiescent class, layer center') - call addfld ('WWQUI_BND', (/ 'ilev' /), 'A', 'm2/s2', & - 'vertical velocity variance in the quiescent class, layer boundary') - call addfld ('WWQUI_CLD_BND', (/ 'ilev' /), 'A', 'm2/s2', & - 'vertical velocity variance in the cloudy quiescent class, layer boundary') - endif -#endif - - !------------------------- - ! Register modal aerosol history fields - ! ifdef needed because of use of cnst_name_cw which not defined if not modal aerosols -#ifdef MODAL_AERO - if (prog_modal_aero) then - - aero_props => modal_aerosol_properties() - if (.not.associated(aero_props)) then - call endrun('crm_physics_init: modal_aerosol_properties constructor failed') - end if - call ndrop_init(aero_props) - - do m=1, pcnst - if(cnst_species_class(m).eq.cnst_spec_class_gas) then - fieldname = trim(cnst_name(m)) // '_mixnuc1sp' - long_name = trim(cnst_name(m)) // ' dropmixnuc mixnuc column tendency in the mmf one ' - call addfld( fieldname, horiz_only, 'A', unit, long_name) - call add_default( fieldname, 1, ' ' ) - end if - end do - - endif - -#endif - - ! These variables do not vary in CRM - call pbuf_set_field (pbuf2d, prec_dp_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, prec_sh_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, snow_sh_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, snow_dp_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, prec_sed_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, snow_sed_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, prec_pcw_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, snow_pcw_idx, 0.0_r8) - - - call addfld ('CRM_U ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'm/s ', 'CRM x-wind' ) - call addfld ('CRM_V ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'm/s ', 'CRM y-wind' ) - call addfld ('CRM_W ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'm/s ', 'CRM z-wind' ) - call addfld ('CRM_T ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'K ', 'CRM Temperature' ) - call addfld ('CRM_QV ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'kg/kg ', 'CRM Water Vapor' ) - call addfld ('CRM_QC ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'kg/kg ', 'CRM Cloud Water' ) - call addfld ('CRM_QI ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'kg/kg ', 'CRM Cloud Ice' ) - call addfld ('CRM_QPC ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'kg/kg ', 'CRM Precipitating Water' ) - call addfld ('CRM_QPI ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'kg/kg ', 'CRM Precipitating Ice' ) - call addfld ('CRM_PREC',(/'crm_nx','crm_ny'/), 'I', 'm/s ', 'CRM Precipitation Rate' ) - call addfld ('CRM_QRS ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'K/s ', 'CRM Shortwave radiative heating rate') - call addfld ('CRM_QRL ',(/'crm_nx','crm_ny', 'crm_nz'/), 'I', 'K/s ', 'CRM Longwave radiative heating rate' ) - - call add_default ('SPDT ', 1, ' ') - call add_default ('SPDQ ', 1, ' ') - call add_default ('SPDQC ', 1, ' ') - call add_default ('SPDQI ', 1, ' ') - call add_default ('SPMC ', 1, ' ') - call add_default ('SPMCUP ', 1, ' ') - call add_default ('SPMCDN ', 1, ' ') - call add_default ('SPMCUUP ', 1, ' ') - call add_default ('SPMCUDN ', 1, ' ') - call add_default ('SPQC ', 1, ' ') - call add_default ('SPQI ', 1, ' ') - call add_default ('SPQS ', 1, ' ') - call add_default ('SPQG ', 1, ' ') - call add_default ('SPQR ', 1, ' ') - call add_default ('SPQTFLX ', 1, ' ') - call add_default ('SPQTFLXS', 1, ' ') - call add_default ('SPTKE ', 1, ' ') - call add_default ('SPTKES ', 1, ' ') - call add_default ('SPTK ', 1, ' ') - call add_default ('SPQPFLX ', 1, ' ') - call add_default ('SPPFLX ', 1, ' ') - call add_default ('SPQTLS ', 1, ' ') - call add_default ('SPQTTR ', 1, ' ') - call add_default ('SPQPTR ', 1, ' ') - call add_default ('SPQPEVP ', 1, ' ') - call add_default ('SPQPFALL', 1, ' ') - call add_default ('SPQPSRC ', 1, ' ') - call add_default ('SPTLS ', 1, ' ') - call add_default ('CLOUDTOP', 1, ' ') - call add_default ('TIMINGF ', 1, ' ') - - sh_frac_idx = pbuf_get_index('SH_FRAC') - dp_frac_idx = pbuf_get_index('DP_FRAC') - call pbuf_set_field (pbuf2d, sh_frac_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, dp_frac_idx, 0.0_r8) - - call pbuf_set_field (pbuf2d, cmfmc_sh_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, rprdsh_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, icwmrsh_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, nevapr_shcu_idx, 0.0_r8) - - call pbuf_set_field (pbuf2d, icwmrdp_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, fice_idx, 0.0_r8) - - call pbuf_set_field (pbuf2d, prain_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, rprdtot_idx, 0.0_r8) - call pbuf_set_field (pbuf2d, nevapr_idx, 0.0_r8) - - if (is_first_step()) then - call pbuf_set_field (pbuf2d, ast_idx, 0.0_r8) - end if -#endif -end subroutine crm_physics_init - -!========================================================================================================= - -function crm_implements_cnst(name) - - ! Return true if specified constituent is implemented by the - ! microphysics package - - character(len=*), intent(in) :: name ! constituent name - logical :: crm_implements_cnst ! return value - -#ifdef CRM - !----------------------------------------------------------------------- - - crm_implements_cnst = any(name == cnst_names) - -#endif -end function crm_implements_cnst - -!=============================================================================== - -subroutine crm_init_cnst(name, q) - - ! Initialize the microphysics constituents, if they are - ! not read from the initial file. - - character(len=*), intent(in) :: name ! constituent name - real(r8), intent(out) :: q(:,:) ! mass mixing ratio (gcol, plev) - !----------------------------------------------------------------------- - -#ifdef CRM - if (crm_implements_cnst(name)) q = 0.0_r8 -#endif - -end subroutine crm_init_cnst - -!=============================================================================== - -!--------------------------------------------------------------------------------------------------------- - subroutine crm_physics_tend(ztodt, state, tend, ptend, pbuf, cam_in) - -!------------------------------------------------------------------------------------------ -! Purpose: to update state from CRM physics. -! -! Revision history: -! -! June, 2009, Minghuai Wang: -! These codes are taken out from tphysbc.F90 -! in the spcam3.5, developed by Marat Khairoutdinov -! (mkhairoutdin@ms.cc.sunysb.edu). Here we try to follow the procedure -! in 'Interface to Column Physics and Chemistry packages' to implement -! the CRM physics. -! July, 13, 2009, Minghuai Wang: -! Hydrometer numbers are outputed from SAM when Morrison's microphysics is used, -! and will be used in the radiative transfer code to calculate radius. -! July, 15, 2009, Minghuai Wang: -! Get modal aerosol, and use it in the SAM. -! -!------------------------------------------------------------------------------------------- -#ifdef CRM - use shr_spfn_mod, only: gamma => shr_spfn_gamma - use time_manager, only: is_first_step, get_nstep - use cam_history, only: outfld - use perf_mod - use crmdims, only: crm_nx, crm_ny, crm_nz - use physconst, only: cpair, latvap, gravit - use constituents, only: pcnst, cnst_get_ind - use crmx_crm_module, only: crm - use crmx_microphysics, only: nmicro_fields - use physconst, only: latvap - use check_energy, only: check_energy_cam_chng - use phys_grid, only: get_rlat_all_p, get_rlon_all_p, get_lon_all_p, get_lat_all_p - use modal_aero_calcsize, only: modal_aero_calcsize_sub - use micro_pumas_utils, only: size_dist_param_liq, mg_liq_props, mincld, qsmall - -#ifdef MODAL_AERO - use crmclouds_camaerosols, only: crmclouds_mixnuc_tend, spcam_modal_aero_wateruptake_dr -#endif -#ifdef m2005 - use module_ecpp_ppdriver2, only: parampollu_driver2 - use crmx_ecppvars, only: NCLASS_CL, ncls_ecpp_in, NCLASS_PR - use module_data_ecpp1, only: dtstep_pp_input -#endif -#ifdef SPCAM_CLUBB_SGS - use cloud_cover_diags, only: cloud_cover_diags_out - use pkg_cldoptics, only: cldovrlap -#endif - -#endif - - use physics_buffer, only: physics_buffer_desc, pbuf_old_tim_idx, pbuf_get_index, dyn_time_lvls, pbuf_get_field - use physics_types, only: physics_state, physics_tend, physics_ptend, physics_update, physics_ptend_init, & - physics_state_copy, physics_ptend_sum, physics_ptend_scale - use camsrfexch, only: cam_in_t - - real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) - type(physics_state), intent(in) :: state - type(physics_tend), intent(in) :: tend - type(physics_ptend ), intent(out) :: ptend - type(physics_buffer_desc),pointer :: pbuf(:) - type (cam_in_t), intent(in) :: cam_in - -#ifdef CRM - - type(physics_state) :: state_loc ! local copy of state - type(physics_tend) :: tend_loc ! local copy of tend - type(physics_ptend) :: ptend_loc ! local copy of ptend - - ! convective precipitation variables - real(r8), pointer :: prec_dp(:) ! total precipitation from ZM convection [m/s] - real(r8), pointer :: snow_dp(:) ! snow from ZM convection [m/s] - - real(r8), pointer :: nc_rad(:,:,:,:) ! rad cloud water droplet number [#/kg] - real(r8), pointer :: ni_rad(:,:,:,:) ! rad cloud ice crystal number [#/kg] - real(r8), pointer :: qs_rad(:,:,:,:) ! rad cloud snow mass [kg/kg] - real(r8), pointer :: ns_rad(:,:,:,:) ! rad cloud snow crystal number [#/kg] - real(r8), pointer :: cld_rad(:,:,:,:) ! cloud fraction - - real(r8), pointer :: t_rad (:,:,:,:) ! rad temperuture - real(r8), pointer :: qv_rad(:,:,:,:) ! rad vapor - real(r8), pointer :: qc_rad(:,:,:,:) ! rad cloud water - real(r8), pointer :: qi_rad(:,:,:,:) ! rad cloud ice - real(r8), pointer :: crm_qrad(:,:,:,:) - real(r8), pointer :: clubb_buffer (:,:,:,:,:) - - real(r8),pointer :: cldtop_pbuf(:) ! cloudtop location for pbuf - - real(r8),pointer :: tk_crm_ecpp(:,:) - real(r8),pointer :: acldy_cen_tbeg(:,:) ! cloud fraction - real(r8), pointer, dimension(:,:) :: cldo - -! -!--------------------------- Local variables ----------------------------------------------------------- -! - integer lchnk ! chunk identifier - integer ncol ! number of atmospheric columns - - integer nstep ! time steps - - real(r8) qc_crm (pcols,crm_nx, crm_ny, crm_nz) - real(r8) qi_crm (pcols,crm_nx, crm_ny, crm_nz) - real(r8) qpc_crm(pcols,crm_nx, crm_ny, crm_nz) - real(r8) qpi_crm(pcols,crm_nx, crm_ny, crm_nz) - - real(r8),allocatable :: crm_cld(:,:,:,:) - real(r8),allocatable :: clubb_tk(:,:,:,:) - real(r8),allocatable :: clubb_tkh(:,:,:,:) - real(r8),allocatable :: relvar(:,:,:,:) - real(r8),allocatable :: accre_enhan(:,:,:,:) - real(r8),allocatable :: qclvar(:,:,:,:) - - real(r8) crm_tk(pcols,crm_nx, crm_ny, crm_nz) - real(r8) crm_tkh(pcols,crm_nx, crm_ny, crm_nz) - real(r8) cld3d_crm(pcols, crm_nx, crm_ny, crm_nz) ! 3D instaneous cloud fraction - real(r8) prec_crm(pcols,crm_nx, crm_ny) - real(r8) mctot(pcols,pver) ! total cloud mass flux - real(r8) mcup(pcols,pver) ! cloud updraft mass flux - real(r8) mcdn(pcols,pver) ! cloud downdraft mass flux - real(r8) mcuup(pcols,pver) ! unsaturated updraft mass flux - real(r8) mcudn(pcols,pver) ! unsaturated downdraft mass flux - real(r8) spqc(pcols,pver) ! cloud water - real(r8) spqi(pcols,pver) ! cloud ice - real(r8) spqs(pcols,pver) ! snow - real(r8) spqg(pcols,pver) ! graupel - real(r8) spqr(pcols,pver) ! rain - real(r8) spnc(pcols,pver) ! cloud water droplet (#/kg) - real(r8) spni(pcols,pver) ! cloud ice crystal number (#/kg) - real(r8) spns(pcols,pver) ! snow particle number (#/kg) - real(r8) spng(pcols,pver) ! graupel particle number (#/kg) - real(r8) spnr(pcols,pver) ! rain particle number (#/kg) - real(r8) wvar_crm (pcols,crm_nx, crm_ny, crm_nz) ! vertical velocity variance (m/s) - - real(r8) aut_crm (pcols,crm_nx, crm_ny, crm_nz) ! Cloud water autoconversion (1/s) - real(r8) acc_crm (pcols,crm_nx, crm_ny, crm_nz) ! Cloud water accretion by rain (1/s) - real(r8) evpc_crm (pcols,crm_nx, crm_ny, crm_nz) ! Cloud water evaporation (1/s) - real(r8) evpr_crm (pcols,crm_nx, crm_ny, crm_nz) ! Rain evaporation (1/s) - real(r8) mlt_crm (pcols,crm_nx, crm_ny, crm_nz) ! Ice, snow, graupel melting (1/s) - real(r8) sub_crm (pcols,crm_nx, crm_ny, crm_nz) ! Ice, snow, graupel sublimation (1/s) - real(r8) dep_crm (pcols,crm_nx, crm_ny, crm_nz) ! Ice, snow, graupel deposition (1/s) - real(r8) con_crm (pcols,crm_nx, crm_ny, crm_nz) ! Cloud water condensation (1/s) - real(r8) aut_crm_a (pcols,pver) ! Cloud water autoconversion (1/s) - real(r8) acc_crm_a (pcols,pver) ! Cloud water accretion by rain (1/s) - real(r8) evpc_crm_a (pcols,pver) ! Cloud water evaporation (1/s) - real(r8) evpr_crm_a (pcols,pver) ! Rain evaporation (1/s) - real(r8) mlt_crm_a (pcols,pver) ! Ice, snow, graupel melting (1/s) - real(r8) sub_crm_a (pcols,pver) ! Ice, snow, graupel sublimation (1/s) - real(r8) dep_crm_a (pcols,pver) ! Ice, snow, graupel deposition (1/s) - real(r8) con_crm_a (pcols,pver) ! Cloud water condensation (1/s) - - real(r8) flux_qt(pcols,pver) ! nonprecipitating water flux - real(r8) flux_u(pcols,pver) ! x-momentum flux - real(r8) flux_v(pcols,pver) ! y-momentum flux - real(r8) fluxsgs_qt(pcols,pver) ! sgs nonprecipitating water flux - real(r8) tkez(pcols,pver) ! tke profile [kg/m/s2] - real(r8) tkesgsz(pcols,pver) ! sgs tke profile [kg/m/s2] - real(r8) flux_qp(pcols,pver) ! precipitating water flux - real(r8) precflux(pcols,pver) ! precipitation flux - real(r8) qt_ls(pcols,pver) ! water tendency due to large-scale - real(r8) qt_trans(pcols,pver) ! nonprecip water tendency due to transport - real(r8) qp_trans(pcols,pver) ! precip water tendency due to transport - real(r8) qp_fall(pcols,pver) ! precip water tendency due to fall-out - real(r8) qp_evp(pcols,pver) ! precip water tendency due to evap - real(r8) qp_src(pcols,pver) ! precip water tendency due to conversion - real(r8) t_ls(pcols,pver) ! tendency of crm's liwse due to large-scale - real(r8) cldtop(pcols,pver) - real(r8) cwp (pcols,pver) ! in-cloud cloud (total) water path (kg/m2) - real(r8) gicewp(pcols,pver) ! grid-box cloud ice water path (g/m2) - real(r8) gliqwp(pcols,pver) ! grid-box cloud liquid water path (g/m2) - real(r8) gwp (pcols,pver) ! grid-box cloud (total) water path (kg/m2) - real(r8) tgicewp(pcols) ! Vertically integrated ice water path (kg/m2 - real(r8) tgliqwp(pcols) ! Vertically integrated liquid water path (kg/m2) - real(r8) cicewp(pcols,pver) ! in-cloud cloud ice water path (kg/m2) - real(r8) cliqwp(pcols,pver) ! in-cloud cloud liquid water path (kg/m2) - real(r8) tgwp (pcols) ! Vertically integrated (total) cloud water path (kg/m2) - real(r8) precc(pcols) ! convective precipitation [m/s] - real(r8) precl(pcols) ! large scale precipitation [m/s] - real(r8) precsc(pcols) ! convecitve snow [m/s] - real(r8) precsl(pcols) ! convective snow [m/s] - real(r8) cltot(pcols) ! Diagnostic total cloud cover - real(r8) cllow(pcols) ! Diagnostic low cloud cover - real(r8) clmed(pcols) ! Diagnostic mid cloud cover - real(r8) clhgh(pcols) ! Diagnostic hgh cloud cover - real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables - real(r8) ul(pver) - real(r8) vl(pver) - - real(r8) :: mu_crm(pcols,pver) - real(r8) :: md_crm(pcols,pver) - real(r8) :: du_crm(pcols,pver) - real(r8) :: eu_crm(pcols,pver) - real(r8) :: ed_crm(pcols,pver) - real(r8) :: tk_crm(pcols,pver) - real(r8) :: jt_crm(pcols) - real(r8) :: mx_crm(pcols) - real(r8) :: ideep_crm(pcols) - - - integer itim - real(r8), pointer, dimension(:,:) :: cld ! cloud fraction - - real(r8),allocatable :: na(:) ! aerosol number concentration [/m3] - real(r8),allocatable :: va(:) ! aerosol voume concentration [m3/m3] - real(r8),allocatable :: hy(:) ! aerosol bulk hygroscopicity - real(r8),allocatable :: naermod(:,:) ! Aerosol number concentration [/m3] - real(r8),allocatable :: vaerosol(:,:) ! aerosol volume concentration [m3/m3] - real(r8),allocatable :: hygro(:,:) ! hygroscopicity of aerosol mode - integer phase ! phase to determine whether it is interstitial, cloud-borne, or the sum. - - real(r8) cs(pcols, pver) ! air density [kg/m3] - - real(r8),allocatable :: qicecen(:,:,:,:,:) ! cloud ice (kg/kg) - real(r8),allocatable :: qlsink_afcen(:,:,:,:,:) ! cloud water loss rate from precipitation calculated - ! cloud water before precipitatinog (/s) - real(r8),allocatable :: qlsink_bfcen(:,:,:,:,:) ! cloud water loss rate from precipitation calculated - ! cloud water before precipitatinog (/s) - real(r8),allocatable :: qlsink_avgcen(:,:,:,:,:) ! cloud water loss rate from precipitation calculated - ! from praincen and qlcoudcen averaged over - ! ntavg1_ss time step (/s) - real(r8),allocatable :: praincen(:,:,:,:,:) ! cloud water loss rate from precipitation (kg/kg/s) - real(r8),allocatable :: wupthresh_bnd(:,:) - real(r8),allocatable :: wdownthresh_bnd(:,:) - - ! CRM column radiation stuff: - real(r8) prectend(pcols) ! tendency in precipitating water and ice - real(r8) precstend(pcols) ! tendency in precipitating ice - real(r8) icesink(pcols) ! sink of - real(r8) tau00 ! surface stress - real(r8) wnd ! surface wnd - real(r8) bflx ! surface buoyancy flux (Km/s) - real(r8) taux_crm(pcols) ! zonal CRM surface stress perturbation - real(r8) tauy_crm(pcols) ! merid CRM surface stress perturbation - real(r8) z0m(pcols) ! surface momentum roughness length - real(r8), pointer, dimension(:,:) :: qrs, qrl ! rad heating rates - real(r8), pointer, dimension(:,:,:,:) :: crm_u - real(r8), pointer, dimension(:,:,:,:) :: crm_v - real(r8), pointer, dimension(:,:,:,:) :: crm_w - real(r8), pointer, dimension(:,:,:,:) :: crm_t - real(r8), pointer, dimension(:,:,:,:) :: crm_qt - real(r8), pointer, dimension(:,:,:,:) :: crm_qp - real(r8), pointer, dimension(:,:,:,:) :: crm_qn - real(r8), pointer, dimension(:,:,:,:) :: crm_nc - real(r8), pointer, dimension(:,:,:,:) :: crm_qr - real(r8), pointer, dimension(:,:,:,:) :: crm_nr - real(r8), pointer, dimension(:,:,:,:) :: crm_qi - real(r8), pointer, dimension(:,:,:,:) :: crm_ni - real(r8), pointer, dimension(:,:,:,:) :: crm_qs - real(r8), pointer, dimension(:,:,:,:) :: crm_ns - real(r8), pointer, dimension(:,:,:,:) :: crm_qg - real(r8), pointer, dimension(:,:,:,:) :: crm_ng - real(r8), pointer, dimension(:,:,:,:) :: crm_qc - - real(r8), allocatable, dimension(:,:,:,:,:) :: crm_micro - - integer :: pblh_idx - real(r8), pointer, dimension(:) :: pblh - - real(r8), pointer, dimension(:,:) :: wsedl - - real(r8),allocatable :: acen(:,:,:,:,:) ! cloud fraction for each sub-sub class for full time period - real(r8),allocatable :: acen_tf(:,:,:,:,:) ! cloud fraction for end-portion of time period - real(r8),allocatable :: rhcen(:,:,:,:,:) ! relative humidity (0-1) - real(r8),allocatable :: qcloudcen(:,:,:,:,:) ! cloud water (kg/kg) - real(r8),allocatable :: qlsinkcen(:,:,:,:,:) ! cloud water loss rate from precipitation (/s??) - real(r8),allocatable :: precrcen(:,:,:,:,:) ! liquid (rain) precipitation rate (kg/m2/s) - real(r8),allocatable :: precsolidcen(:,:,:,:,:) ! solid (rain) precipitation rate (kg/m2/s) - real(r8),allocatable :: wwqui_cen(:,:) ! vertical velocity variance in quiescent class (m2/s2) - real(r8),allocatable :: wwqui_cloudy_cen(:,:) ! vertical velocity variance in quiescent, and cloudy class (m2/s2) - ! at layer boundary - real(r8),allocatable :: abnd(:,:,:,:,:) ! cloud fraction for each sub-sub class for full time period - real(r8),allocatable :: abnd_tf(:,:,:,:,:) ! cloud fraction for end-portion of time period - real(r8),allocatable :: massflxbnd(:,:,:,:,:) ! sub-class vertical mass flux (kg/m2/s) at layer bottom boundary. - real(r8),allocatable :: wwqui_bnd(:,:) ! vertical velocity variance in quiescent class (m2/s2) - real(r8),allocatable :: wwqui_cloudy_bnd(:,:) ! vertical velocity variance in quiescent, and cloudy class (m2/s2) - - integer, pointer :: nmxrgn(:) ! Number of maximally overlapped regions - real(r8), pointer :: pmxrgn(:,:) ! Maximum values of pressure for each - - real(r8), allocatable :: spup2(:,:) - real(r8), allocatable :: spvp2(:,:) - real(r8), allocatable :: spwprtp(:,:) - real(r8), allocatable :: spwpthlp(:,:) - real(r8), allocatable :: spwp2(:,:) - real(r8), allocatable :: spwp3(:,:) - real(r8), allocatable :: sprtp2(:,:) - real(r8), allocatable :: spthlp2(:,:) - real(r8), allocatable :: sprtpthlp(:,:) - real(r8), allocatable :: spupwp(:,:) - real(r8), allocatable :: spvpwp(:,:) - real(r8), allocatable :: spcrm_cld(:,:) - real(r8), allocatable :: spt_tndcy(:,:) - real(r8), allocatable :: spqv_tndcy(:,:) - real(r8), allocatable :: spqc_tndcy(:,:) - real(r8), allocatable :: spclubb_tk(:,:) - real(r8), allocatable :: spclubb_tkh(:,:) - real(r8), allocatable :: sprelvar(:,:) - real(r8), allocatable :: spaccre_enhan(:,:) - real(r8), allocatable :: spqclvar(:,:) - - real(r8) :: spcld3d (pcols,pver) - - real(r8) :: tmp4d(pcols,crm_nx, crm_ny, crm_nz) - real(r8) :: tmp2d(pcols,pver) - - ! Surface fluxes - real(r8) :: fluxu0 ! surface momenment fluxes - real(r8) :: fluxv0 ! surface momenment fluxes - real(r8) :: fluxt0 ! surface sensible heat fluxes - real(r8) :: fluxq0 ! surface latent heat fluxes - real(r8) :: dtstep_pp ! time step for the ECPP (seconds) - integer :: necpp ! the number of GCM time step in which ECPP is called once. - - - real(r8) radflux(pcols) ! radiative fluxes from radiation calculation (qrs + qrl) - - real(r8) qtot(pcols, 3) ! total water - real(r8) qt_hydro(pcols, 2) ! total hydrometer - real(r8) qt_cloud(pcols, 3) ! total cloud water - real(r8) qtv(pcols, 3) ! total water vapor - real(r8) qli_hydro(pcols, 2) ! column-integraetd rain + snow + graupel - real(r8) qi_hydro(pcols, 2) ! column-integrated snow water + graupel water - real(r8) sfactor - - real(r8) zero(pcols) ! zero - real(r8) timing_factor(pcols) ! factor for crm cpu-usage: 1 means no subcycling - - real(r8) qtotcrm(pcols, 20) ! the toal water calculated in crm.F90 - - real(r8), parameter :: rhow = 1000._r8 - real(r8), parameter :: bc = 2._r8 - real(r8) :: t, mu, acn, dumc, dunc, pgam, lamc - real(r8) :: dunc_arr(pcols,pver) - - integer ii, jj - integer iii - integer i, k, m - integer ifld - logical :: ls, lu, lv, lq(pcnst) - - type(modal_aerosol_state), pointer :: aero_state - - integer :: errnum - character(len=shr_kind_cs) :: errstr - - zero = 0.0_r8 -!======================================================== -!======================================================== -! CRM (Superparameterization). -! Author: Marat Khairoutdinov (mkhairoutdin@ms.cc.sunysb.edu) -!======================================================== - - call t_startf ('crm') - - allocate(crm_micro(pcols,crm_nx,crm_ny,crm_nz,nmicro_fields+1)) - - ! Initialize stuff: - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - - ls = .TRUE. - lq(:) = .FALSE. - lq(1) = .TRUE. - lq(ixcldliq) = .TRUE. - lq(ixcldice) = .TRUE. - lu = .FALSE. - lv = .FALSE. - call physics_ptend_init(ptend, state%psetcols, 'crm', lu=lu, lv=lv, ls=ls, lq=lq) ! Initialize output physics_ptend object - call physics_ptend_init(ptend_loc, state%psetcols, 'crm', lu=lu, lv=lv, ls=ls, lq=lq) ! Initialize local physics_ptend object - - nstep = get_nstep() - - lchnk = state%lchnk - ncol = state%ncol - - itim = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim/), kount=(/pcols,pver,1/)) - - call physics_state_copy(state, state_loc) - tend_loc = tend - - !------------------------- - ! Set up general fields - call pbuf_get_field (pbuf, crm_u_idx, crm_u) - call pbuf_get_field (pbuf, crm_v_idx, crm_v) - call pbuf_get_field (pbuf, crm_w_idx, crm_w) - call pbuf_get_field (pbuf, crm_t_idx, crm_t) - call pbuf_get_field (pbuf, crm_qrad_idx, crm_qrad) - call pbuf_get_field (pbuf, crm_t_rad_idx, t_rad) - call pbuf_get_field (pbuf, crm_qv_rad_idx, qv_rad) - call pbuf_get_field (pbuf, crm_qc_rad_idx, qc_rad) - call pbuf_get_field (pbuf, crm_qi_rad_idx, qi_rad) - call pbuf_get_field (pbuf, crm_cld_rad_idx, cld_rad) - - call pbuf_get_field (pbuf, prec_dp_idx, prec_dp) - call pbuf_get_field (pbuf, snow_dp_idx, snow_dp) - - - !------------------------- - ! setup CLUBB fields - if (do_clubb_sgs) then - allocate(nmxrgn (pcols)) - allocate(pmxrgn (pcols,pverp)) - allocate(spup2 (pcols, pver)) - allocate(spvp2 (pcols, pver)) - allocate(spwprtp (pcols, pver)) - allocate(spwpthlp (pcols, pver)) - allocate(spwp2 (pcols, pver)) - allocate(spwp3 (pcols, pver)) - allocate(sprtp2 (pcols, pver)) - allocate(spthlp2 (pcols, pver)) - allocate(sprtpthlp (pcols, pver)) - allocate(spupwp (pcols, pver)) - allocate(spvpwp (pcols, pver)) - allocate(spcrm_cld (pcols, pver)) - allocate(spt_tndcy (pcols, pver)) - allocate(spqv_tndcy (pcols, pver)) - allocate(spqc_tndcy (pcols, pver)) - allocate(spclubb_tk (pcols, pver)) - allocate(spclubb_tkh (pcols, pver)) - allocate(sprelvar (pcols, pver)) - allocate(spaccre_enhan (pcols, pver)) - allocate(spqclvar (pcols, pver)) - allocate(crm_cld (pcols,crm_nx, crm_ny, crm_nz+1)) - allocate(clubb_tk (pcols,crm_nx, crm_ny, crm_nz)) - allocate(clubb_tkh (pcols,crm_nx, crm_ny, crm_nz)) - allocate(relvar (pcols,crm_nx, crm_ny, crm_nz)) - allocate(accre_enhan (pcols,crm_nx, crm_ny, crm_nz)) - allocate(qclvar (pcols,crm_nx, crm_ny, crm_nz)) - - call pbuf_get_field (pbuf, clubb_buffer_idx, clubb_buffer) - - endif - - !------------------------- - ! Setup m2005 fields - if (is_spcam_m2005) then - allocate(na (pcols)) - allocate(va (pcols)) - allocate(hy (pcols)) - allocate(naermod (pver, nmodes)) - allocate(vaerosol (pver, nmodes)) - allocate(hygro (pver, nmodes)) - - call pbuf_get_field(pbuf, crm_nc_rad_idx, nc_rad) - call pbuf_get_field(pbuf, crm_ni_rad_idx, ni_rad) - call pbuf_get_field(pbuf, crm_qs_rad_idx, qs_rad) - call pbuf_get_field(pbuf, crm_ns_rad_idx, ns_rad) - call pbuf_get_field(pbuf, crm_qt_idx, crm_qt) - call pbuf_get_field(pbuf, crm_nc_idx, crm_nc) - call pbuf_get_field(pbuf, crm_qr_idx, crm_qr) - call pbuf_get_field(pbuf, crm_nr_idx, crm_nr) - call pbuf_get_field(pbuf, crm_qi_idx, crm_qi) - call pbuf_get_field(pbuf, crm_ni_idx, crm_ni) - call pbuf_get_field(pbuf, crm_qs_idx, crm_qs) - call pbuf_get_field(pbuf, crm_ns_idx, crm_ns) - call pbuf_get_field(pbuf, crm_qg_idx, crm_qg) - call pbuf_get_field(pbuf, crm_ng_idx, crm_ng) - call pbuf_get_field(pbuf, crm_qc_idx, crm_qc) - - !------------------------- - ! Setup sam1mom fields - else if (is_spcam_sam1mom) then - call pbuf_get_field(pbuf, crm_qt_idx, crm_qt) - call pbuf_get_field(pbuf, crm_qp_idx, crm_qp) - call pbuf_get_field(pbuf, crm_qn_idx, crm_qn) - endif - - - !------------------------- - ! Setup ECPP fields - ! ifdef needed because of use of NCLASS_CL -#ifdef m2005 - if (is_spcam_m2005) then - allocate(acen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(acen_tf (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(rhcen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(qcloudcen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(qlsinkcen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(precrcen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(precsolidcen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(wwqui_cen (pcols, pver)) - allocate(wwqui_cloudy_cen (pcols, pver)) - - ! at layer boundary - allocate(abnd (pcols,pver+1,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(abnd_tf (pcols,pver+1,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(massflxbnd (pcols,pver+1,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(wwqui_bnd (pcols, pver+1)) - allocate(wwqui_cloudy_bnd (pcols, pver+1)) - - allocate(qicecen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(qlsink_afcen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(qlsink_bfcen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(qlsink_avgcen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(praincen (pcols,pver,NCLASS_CL,ncls_ecpp_in,NCLASS_PR)) - allocate(wupthresh_bnd (pcols, pverp)) - allocate(wdownthresh_bnd (pcols, pverp)) - - call pbuf_get_field(pbuf, tk_crm_idx, tk_crm_ecpp) - call pbuf_get_field(pbuf, acldy_cen_idx, acldy_cen_tbeg) - - if(is_first_step())then - acldy_cen_tbeg(:ncol,:) = cld(:ncol, :) - end if - - end if - - aero_state => modal_aerosol_state( state_loc, pbuf ) - if (.not.associated(aero_state)) then - call endrun('crm_physics_tend : modal_aerosol_state constructor failed') - end if -#endif - - !------------------------- - ! Initialize all aerosol and gas species - ! When ECPP is used, dropmixnuc and all transport(deep and shallow) are done in ECPP. - if (is_spcam_sam1mom) then - state_loc%q(:ncol, :pver, :pcnst) = 1.e-36_r8 - ! set the values which SPCAM uses back to state - state_loc%q(:ncol, :pver, 1) = state%q(:ncol, :pver, 1) - state_loc%q(:ncol, :pver, ixcldice) = state%q(:ncol, :pver, ixcldice) - state_loc%q(:ncol, :pver, ixcldliq) = state%q(:ncol, :pver, ixcldliq) - endif - - !------------------------- - !------------------------- - ! On the first_step, initialize values only and do not call CRM - !------------------------- - !------------------------- - if(is_first_step()) then - do k=1,crm_nz - m = pver-k+1 - do i=1,ncol - - if (spcam_direction == 'NS') then - if(crm_ny.eq.1) then ! change domain orientation only for 2D CRM - crm_u(i,:,:,k) = state_loc%v(i,m) - crm_v(i,:,:,k) = state_loc%u(i,m) - else - crm_u(i,:,:,k) = state_loc%u(i,m) - crm_v(i,:,:,k) = state_loc%v(i,m) - end if - else if( spcam_direction == 'WE') then - crm_u(i,:,:,k) = state_loc%u(i,m) - crm_v(i,:,:,k) = state_loc%v(i,m) - endif - - crm_w(i,:,:,k) = 0._r8 - crm_t(i,:,:,k) = state_loc%t(i,m) - - if (is_spcam_sam1mom) then - crm_qt(i,:,:,k) = state_loc%q(i,m,1)+state_loc%q(i,m,ixcldliq)+state_loc%q(i,m,ixcldice) - crm_qp(i,:,:,k) = 0.0_r8 - crm_qn(i,:,:,k) = state_loc%q(i,m,ixcldliq)+state_loc%q(i,m,ixcldice) - - else if (is_spcam_m2005) then - crm_qt(i,:,:,k) = state_loc%q(i,m,1)+state_loc%q(i,m,ixcldliq) - crm_nc(i,:,:,k) = 0.0_r8 - crm_qr(i,:,:,k) = 0.0_r8 - crm_nr(i,:,:,k) = 0.0_r8 - crm_qi(i,:,:,k) = state_loc%q(i,m,ixcldice) - crm_ni(i,:,:,k) = 0.0_r8 - crm_qs(i,:,:,k) = 0.0_r8 - crm_ns(i,:,:,k) = 0.0_r8 - crm_qg(i,:,:,k) = 0.0_r8 - crm_ng(i,:,:,k) = 0.0_r8 - crm_qc(i,:,:,k) = state_loc%q(i,m,ixcldliq) - - - nc_rad(i,:,:,k) = 0._r8 - ni_rad(i,:,:,k) = 0._r8 - qs_rad(i,:,:,k) = 0.0_r8 - ns_rad(i,:,:,k) = 0.0_r8 - wvar_crm(i,:,:,k) = 0.0_r8 - aut_crm(i,:,:,k) = 0.0_r8 - acc_crm(i,:,:,k) = 0.0_r8 - evpc_crm(i,:,:,k) = 0.0_r8 - evpr_crm(i,:,:,k) = 0.0_r8 - mlt_crm(i,:,:,k) = 0.0_r8 - sub_crm(i,:,:,k) = 0.0_r8 - dep_crm(i,:,:,k) = 0.0_r8 - con_crm(i,:,:,k) = 0.0_r8 - endif - - if (do_clubb_sgs) then - ! In the inital run, variables are set in clubb_sgs_setup at the first time step - clubb_buffer(i,:,:,k,:) = 0.0_r8 - endif - - crm_qrad (i,:,:,k) = 0._r8 - qc_crm (i,:,:,k) = 0._r8 - qi_crm (i,:,:,k) = 0._r8 - qpc_crm(i,:,:,k) = 0._r8 - qpi_crm(i,:,:,k) = 0._r8 - t_rad (i,:,:,k) = state_loc%t(i,m) - qv_rad (i,:,:,k) = state_loc%q(i,m,1) - qc_rad (i,:,:,k) = 0._r8 - qi_rad (i,:,:,k) = 0._r8 - cld_rad(i,:,:,k) = 0._r8 - end do - end do - - ! use radiation from grid-cell mean radctl on first time step - prec_crm (:,:,:) = 0._r8 - ptend_loc%q(:,:,1) = 0._r8 - ptend_loc%q(:,:,ixcldliq) = 0._r8 - ptend_loc%q(:,:,ixcldice) = 0._r8 - ptend_loc%s(:,:) = 0._r8 - precc(:) = 0._r8 - precl(:) = 0._r8 - precsc(:) = 0._r8 - precsl(:) = 0._r8 - cltot(:) = 0._r8 - clhgh(:) = 0._r8 - clmed(:) = 0._r8 - cllow(:) = 0._r8 - cld(:,:) = 0._r8 - cldtop(:,:) = 0._r8 - gicewp(:,:) = 0._r8 - gliqwp(:,:) = 0._r8 - mctot(:,:) = 0._r8 - mcup(:,:) = 0._r8 - mcdn(:,:) = 0._r8 - mcuup(:,:) = 0._r8 - mcudn(:,:) = 0._r8 - spqc(:,:) = 0._r8 - spqi(:,:) = 0._r8 - spqs(:,:) = 0._r8 - spqg(:,:) = 0._r8 - spqr(:,:) = 0._r8 - cld3d_crm (:,:,:,:) = 0._r8 - flux_qt(:,:) = 0._r8 - flux_u(:,:) = 0._r8 - flux_v(:,:) = 0._r8 - fluxsgs_qt(:,:) = 0._r8 - tkez(:,:) = 0._r8 - tkesgsz(:,:) = 0._r8 - flux_qp(:,:) = 0._r8 - precflux(:,:) = 0._r8 - qt_ls(:,:) = 0._r8 - qt_trans(:,:) = 0._r8 - qp_trans(:,:) = 0._r8 - qp_fall(:,:) = 0._r8 - qp_evp(:,:) = 0._r8 - qp_src(:,:) = 0._r8 - z0m(:) = 0._r8 - taux_crm(:) = 0._r8 - tauy_crm(:) = 0._r8 - t_ls(:,:) = 0._r8 - - - if (is_spcam_m2005) then - spnc(:,:) = 0._r8 - spni(:,:) = 0._r8 - spns(:,:) = 0._r8 - spng(:,:) = 0._r8 - spnr(:,:) = 0._r8 - aut_crm_a(:,:) = 0._r8 - acc_crm_a(:,:) = 0._r8 - evpc_crm_a(:,:) = 0._r8 - evpr_crm_a(:,:) = 0._r8 - mlt_crm_a(:,:) = 0._r8 - sub_crm_a(:,:) = 0._r8 - dep_crm_a(:,:) = 0._r8 - con_crm_a(:,:) = 0._r8 - abnd = 0.0_r8 - abnd_tf = 0.0_r8 - massflxbnd = 0.0_r8 - acen = 0.0_r8 - acen_tf = 0.0_r8 - rhcen = 0.0_r8 - qcloudcen = 0.0_r8 - qicecen = 0.0_r8 - qlsinkcen = 0.0_r8 - precrcen = 0.0_r8 - precsolidcen = 0.0_r8 - wupthresh_bnd = 0.0_r8 - wdownthresh_bnd = 0.0_r8 - qlsink_afcen = 0.0_r8 - qlsink_bfcen = 0.0_r8 - qlsink_avgcen = 0.0_r8 - praincen = 0.0_r8 - - ! default is clear, non-precipitating, and quiescent class - abnd(:,:,1,1,1) = 1.0_r8 - abnd_tf(:,:,1,1,1) = 1.0_r8 - acen(:,:,1,1,1) = 1.0_r8 - acen_tf(:,:,1,1,1) = 1.0_r8 - wwqui_cen = 0.0_r8 - wwqui_bnd = 0.0_r8 - wwqui_cloudy_cen = 0.0_r8 - wwqui_cloudy_bnd = 0.0_r8 - tk_crm = 0.0_r8 - - ! turbulence - cs(:ncol, 1:pver) = state_loc%pmid(:ncol, 1:pver)/(287.15_r8*state_loc%t(:ncol, 1:pver)) - - endif - - !------------------------- - !------------------------- - ! not is_first_step - !------------------------- - !------------------------- - - else - ptend_loc%q(:,:,1) = 0._r8 - ptend_loc%q(:,:,ixcldliq) = 0._r8 - ptend_loc%q(:,:,ixcldice) = 0._r8 - ptend_loc%s(:,:) = 0._r8 - cwp = 0._r8 - gicewp = 0._r8 - gliqwp = 0._r8 - cltot = 0._r8 - clhgh = 0._r8 - clmed = 0._r8 - cllow = 0._r8 - - qc_crm = 0._r8 - qi_crm = 0._r8 - qpc_crm = 0._r8 - qpi_crm = 0._r8 - prec_crm = 0._r8 - - ! Populate the internal crm_micro array - if (is_spcam_sam1mom) then - crm_micro(:,:,:,:,1) = crm_qt(:,:,:,:) - crm_micro(:,:,:,:,2) = crm_qp(:,:,:,:) - crm_micro(:,:,:,:,3) = crm_qn(:,:,:,:) - else if (is_spcam_m2005) then - crm_micro(:,:,:,:,1) = crm_qt(:,:,:,:) - crm_micro(:,:,:,:,2) = crm_nc(:,:,:,:) - crm_micro(:,:,:,:,3) = crm_qr(:,:,:,:) - crm_micro(:,:,:,:,4) = crm_nr(:,:,:,:) - crm_micro(:,:,:,:,5) = crm_qi(:,:,:,:) - crm_micro(:,:,:,:,6) = crm_ni(:,:,:,:) - crm_micro(:,:,:,:,7) = crm_qs(:,:,:,:) - crm_micro(:,:,:,:,8) = crm_ns(:,:,:,:) - crm_micro(:,:,:,:,9) = crm_qg(:,:,:,:) - crm_micro(:,:,:,:,10) = crm_ng(:,:,:,:) - crm_micro(:,:,:,:,11) = crm_qc(:,:,:,:) - - ! initialize gcm-time-step-avg output at start of each time step - aut_crm_a = 0.0_r8 - acc_crm_a = 0.0_r8 - evpc_crm_a = 0.0_r8 - evpr_crm_a = 0.0_r8 - mlt_crm_a = 0.0_r8 - sub_crm_a = 0.0_r8 - dep_crm_a = 0.0_r8 - con_crm_a = 0.0_r8 - endif - - call t_startf ('crm_call') - - do m=1,crm_nz - k = pver-m+1 - do i = 1,ncol - crm_qrad(i,:,:,m) = crm_qrad(i,:,:,m) / state_loc%pdel(i,k) ! for energy conservation - end do - end do - - if (is_spcam_m2005) then - cs(1:ncol, 1:pver) = state_loc%pmid(1:ncol, 1:pver)/(287.15_r8*state_loc%t(1:ncol, 1:pver)) - end if - - do i = 1,ncol - - tau00 = sqrt(cam_in%wsx(i)**2 + cam_in%wsy(i)**2) - wnd = sqrt(state_loc%u(i,pver)**2 + state_loc%v(i,pver)**2) - bflx = cam_in%shf(i)/cpair + 0.61_r8*state_loc%t(i,pver)*cam_in%lhf(i)/latvap - fluxu0 = cam_in%wsx(i) !N/m2 - fluxv0 = cam_in%wsy(i) !N/m2 - fluxt0 = cam_in%shf(i)/cpair ! K Kg/ (m2 s) - fluxq0 = cam_in%lhf(i)/latvap ! Kg/(m2 s) - - ! - ! calculate total water before calling crm - ! total hydrometer water (rain, snow, and graupel) - if (is_spcam_m2005) then - qt_hydro(i, 1) = 0.0_r8 - qli_hydro(i, 1) = 0.0_r8 - qi_hydro(i, 1) = 0.0_r8 - do m=1, crm_nz - k=pver-m+1 - do ii=1, crm_nx - do jj=1, crm_ny - qt_hydro(i,1) = qt_hydro(i,1)+(crm_qr(i,ii,jj,m)+crm_qs(i,ii,jj,m)+crm_qg(i,ii,jj,m)) * & - state_loc%pdel(i,k)/gravit - qli_hydro(i,1) = qli_hydro(i,1)+(crm_qr(i,ii,jj,m)+crm_qs(i,ii,jj,m)+crm_qg(i,ii,jj,m)) * & - state_loc%pdel(i,k)/gravit - qi_hydro(i,1) = qi_hydro(i,1)+(crm_qs(i,ii,jj,m)+crm_qg(i,ii,jj,m)) * state_loc%pdel(i,k)/gravit - end do - end do - end do - qt_hydro(i,1) = qt_hydro(i,1) / (crm_nx_ny) - qli_hydro(i,1) = qli_hydro(i,1) / (crm_nx_ny) - qi_hydro(i,1) = qi_hydro(i,1) / (crm_nx_ny) - - ! total cloud water and total water vapor - qt_cloud(i,1) = 0._r8 - qtv(i,1) = 0._r8 - do k=1, pver - qt_cloud(i,1) = qt_cloud(i,1) + (state_loc%q(i,k,ixcldliq)+state_loc%q(i,k,ixcldice)) * state_loc%pdel(i,k)/gravit - qtv(i,1) = qtv(i,1) + state_loc%q(i,k,1) * state_loc%pdel(i,k)/gravit - end do - - ! total water - qtot(i,1) = qt_hydro(i,1) + qt_cloud(i,1) + qtv(i,1) - - else if (is_spcam_sam1mom) then - qli_hydro(i, 1) = 0.0_r8 - qi_hydro(i, 1) = 0.0_r8 - do m=1, crm_nz - k=pver-m+1 - do ii=1, crm_nx - do jj=1, crm_ny - sfactor = max(0._r8,min(1._r8,(crm_t(i,ii,jj,m)-268.16_r8)*1._r8/(283.16_r8-268.16_r8))) - qli_hydro(i,1) = qli_hydro(i,1)+crm_qp(i,ii,jj,m) * state_loc%pdel(i,k)/gravit - qi_hydro(i,1) = qi_hydro(i,1)+crm_qp(i,ii,jj,m) * (1-sfactor) * state_loc%pdel(i,k)/gravit - end do - end do - end do - qli_hydro(i,1) = qli_hydro(i,1) / (crm_nx_ny) - qi_hydro(i,1) = qi_hydro(i,1) / (crm_nx_ny) - - ! total cloud water and total water vapor, and energy - qt_cloud(i,1) = 0._r8 - qtv(i,1) = 0._r8 - do k=1, pver - qt_cloud(i,1) = qt_cloud(i,1) + (state_loc%q(i,k,ixcldliq)+state_loc%q(i,k,ixcldice)) * state_loc%pdel(i,k)/gravit - qtv(i,1) = qtv(i,1) + state_loc%q(i,k,1) * state_loc%pdel(i,k)/gravit - end do - endif - -! ifdef required because of loadaer -#ifdef MODAL_AERO - if (prog_modal_aero) then - do k=1, pver - phase = 1 ! interstital aerosols only - do m=1, nmodes - call aero_state%loadaer( aero_props, & - i, i, k, & - m, cs, phase, na, va, & - hy, errnum, errstr ) - naermod(k, m) = na(i) - vaerosol(k, m) = va(i) - hygro(k, m) = hy(i) - if (errnum/=0) then - call endrun('crm_physics_tend : '//trim(errstr)) - end if - end do - end do - endif -#endif - - if (spcam_direction == 'NS') then - if(crm_ny.eq.1) then - ul(:) = state_loc%v(i,:) ! change orientation only if 2D CRM - vl(:) = state_loc%u(i,:) - else - ul(:) = state_loc%u(i,:) - vl(:) = state_loc%v(i,:) - end if - else if (spcam_direction == 'WE') then - ul(:) = state_loc%u(i,:) - vl(:) = state_loc%v(i,:) - endif - - call crm (lchnk, i, & - state_loc%t(i,:), state_loc%q(i,:,1), state_loc%q(i,:,ixcldliq), state_loc%q(i,:,ixcldice), & - ul(:), vl(:), & - state_loc%ps(i), state_loc%pmid(i,:), state_loc%pdel(i,:), state_loc%phis(i), & - state_loc%zm(i,:), state_loc%zi(i,:), ztodt, pver, & - ptend_loc%q(i,:,1), ptend_loc%q(i,:,ixcldliq),ptend_loc%q(i,:,ixcldice), ptend_loc%s(i,:), & - crm_u(i,:,:,:), crm_v(i,:,:,:), crm_w(i,:,:,:), crm_t(i,:,:,:), crm_micro(i,:,:,:,:), & - crm_qrad(i,:,:,:), & - qc_crm(i,:,:,:), qi_crm(i,:,:,:), qpc_crm(i,:,:,:), qpi_crm(i,:,:,:), & - prec_crm(i,:,:), t_rad(i,:,:,:), qv_rad(i,:,:,:), & - qc_rad(i,:,:,:), qi_rad(i,:,:,:), cld_rad(i,:,:,:), cld3d_crm(i, :, :, :), & -#ifdef m2005 - nc_rad(i,:,:,:), ni_rad(i,:,:,:), qs_rad(i,:,:,:), ns_rad(i,:,:,:), wvar_crm(i,:,:,:), & - aut_crm(i,:,:,:), acc_crm(i,:,:,:), evpc_crm(i,:,:,:), evpr_crm(i,:,:,:), mlt_crm(i,:,:,:), & - sub_crm(i,:,:,:), dep_crm(i,:,:,:), con_crm(i,:,:,:), & - aut_crm_a(i,:), acc_crm_a(i,:), evpc_crm_a(i,:), evpr_crm_a(i,:), mlt_crm_a(i,:), & - sub_crm_a(i,:), dep_crm_a(i,:), con_crm_a(i,:), & -#endif - precc(i), precl(i), precsc(i), precsl(i), & - cltot(i), clhgh(i), clmed(i), cllow(i), cld(i,:), cldtop(i,:), & - gicewp(i,:), gliqwp(i,:), & - mctot(i,:), mcup(i,:), mcdn(i,:), mcuup(i,:), mcudn(i,:), & - spqc(i,:), spqi(i,:), spqs(i,:), spqg(i,:), spqr(i,:), & -#ifdef m2005 - spnc(i,:), spni(i,:), spns(i,:), spng(i,:), spnr(i,:), & -#ifdef MODAL_AERO - naermod, vaerosol, hygro, & -#endif -#endif -#ifdef SPCAM_CLUBB_SGS - clubb_buffer(i,:,:,:,:), & - crm_cld(i,:, :, :), & - clubb_tk(i, :, :, :), clubb_tkh(i, :, :, :), & - relvar(i,:, :, :), accre_enhan(i, :, :, :), qclvar(i, :, :, :), & -#endif - crm_tk(i, :, :, :), crm_tkh(i, :, :, :), & - mu_crm(i,:), md_crm(i,:), du_crm(i,:), eu_crm(i,:), & - ed_crm(i,:), jt_crm(i), mx_crm(i), & -#ifdef m2005 - abnd(i,:,:,:,:), abnd_tf(i,:,:,:,:), massflxbnd(i,:,:,:,:), acen(i,:,:,:,:), acen_tf(i,:,:,:,:), & - rhcen(i,:,:,:,:), qcloudcen(i,:,:,:,:), qicecen(i,:,:,:,:), qlsink_afcen(i,:,:,:,:), & - precrcen(i,:,:,:,:), precsolidcen(i,:,:,:,:), & - qlsink_bfcen(i,:,:,:,:), qlsink_avgcen(i,:,:,:,:), praincen(i,:,:,:,:), & - wupthresh_bnd(i,:), wdownthresh_bnd(i,:), & - wwqui_cen(i,:), wwqui_bnd(i,:), wwqui_cloudy_cen(i,:), wwqui_cloudy_bnd(i,:), & -#endif - tkez(i,:), tkesgsz(i,:), tk_crm(i, :), & - flux_u(i,:), flux_v(i,:), flux_qt(i,:), fluxsgs_qt(i,:), flux_qp(i,:), & - precflux(i,:), qt_ls(i,:), qt_trans(i,:), qp_trans(i,:), qp_fall(i,:), & - qp_evp(i,:), qp_src(i,:), t_ls(i,:), prectend(i), precstend(i), & - cam_in%ocnfrac(i), wnd, tau00, bflx, & - fluxu0, fluxv0, fluxt0, fluxq0, & - taux_crm(i), tauy_crm(i), z0m(i), timing_factor(i), qtotcrm(i, :) ) - - ! Retrieve the values back out of the internal crm array structure - if (is_spcam_sam1mom) then - crm_qt(i,:,:,:) = crm_micro(i,:,:,:,1) - crm_qp(i,:,:,:) = crm_micro(i,:,:,:,2) - crm_qn(i,:,:,:) = crm_micro(i,:,:,:,3) - else if (is_spcam_m2005) then - crm_qt(i,:,:,:) = crm_micro(i,:,:,:,1) - crm_nc(i,:,:,:) = crm_micro(i,:,:,:,2) - crm_qr(i,:,:,:) = crm_micro(i,:,:,:,3) - crm_nr(i,:,:,:) = crm_micro(i,:,:,:,4) - crm_qi(i,:,:,:) = crm_micro(i,:,:,:,5) - crm_ni(i,:,:,:) = crm_micro(i,:,:,:,6) - crm_qs(i,:,:,:) = crm_micro(i,:,:,:,7) - crm_ns(i,:,:,:) = crm_micro(i,:,:,:,8) - crm_qg(i,:,:,:) = crm_micro(i,:,:,:,9) - crm_ng(i,:,:,:) = crm_micro(i,:,:,:,10) - crm_qc(i,:,:,:) = crm_micro(i,:,:,:,11) - endif - end do ! i (loop over ncol) - - call t_stopf('crm_call') - - ! There is no separate convective and stratiform precip for CRM: - precc(:ncol) = precc(:ncol) + precl(:ncol) - precl(:ncol) = 0._r8 - precsc(:ncol) = precsc(:ncol) + precsl(:ncol) - precsl(:ncol) = 0._r8 - - prec_dp(:ncol)= precc(:ncol) - snow_dp(:ncol)= precsc(:ncol) - - do m=1,crm_nz - k = pver-m+1 - do i = 1,ncol - crm_qrad(i,:,:,m) = crm_qrad(i,:,:,m) * state_loc%pdel(i,k) ! for energy conservation - end do - end do - - call outfld('PRES ',state_loc%pmid ,pcols ,lchnk ) - call outfld('DPRES ',state_loc%pdel ,pcols ,lchnk ) - call outfld('CRM_U ',crm_u ,pcols ,lchnk ) - call outfld('CRM_V ',crm_v ,pcols ,lchnk ) - call outfld('CRM_W ',crm_w ,pcols ,lchnk ) - call outfld('CRM_T ',crm_t ,pcols ,lchnk ) - call outfld('CRM_QC ',qc_crm ,pcols ,lchnk ) - call outfld('CRM_QI ',qi_crm ,pcols ,lchnk ) - call outfld('CRM_QPC ',qpc_crm ,pcols ,lchnk ) - call outfld('CRM_QPI ',qpi_crm ,pcols ,lchnk ) - call outfld('CRM_PREC',prec_crm ,pcols ,lchnk ) - call outfld('CRM_TK ', crm_tk(:, :, :, :) ,pcols ,lchnk ) - call outfld('CRM_TKH', crm_tkh(:, :, :, :) ,pcols ,lchnk ) - - if (is_spcam_sam1mom) then - tmp4d(:ncol,:,:,:) = crm_qt(:ncol,:,:,:)-qc_crm(:ncol,:,:,:)-qi_crm(:ncol,:,:,:) - call outfld('CRM_QV ',tmp4d,pcols ,lchnk ) - else if (is_spcam_m2005) then - tmp4d(:ncol,:,:,:) = crm_qt(:ncol,:,:,:)-qc_crm(:ncol,:,:,:) - call outfld('CRM_QV ',tmp4d, pcols ,lchnk ) - endif - - - if (is_spcam_m2005) then - call outfld('CRM_NC ', crm_nc ,pcols ,lchnk) - call outfld('CRM_NI ', crm_ni ,pcols ,lchnk) - call outfld('CRM_NR ', crm_nr ,pcols ,lchnk) - call outfld('CRM_NS ', crm_ns ,pcols ,lchnk) - call outfld('CRM_NG ', crm_ng ,pcols ,lchnk) - call outfld('CRM_WVAR', wvar_crm ,pcols ,lchnk) - call outfld('CRM_QR ', crm_qr ,pcols ,lchnk) - call outfld('CRM_QS ', crm_qs ,pcols ,lchnk) - call outfld('CRM_QG ', crm_qg ,pcols ,lchnk) - call outfld('CRM_AUT', aut_crm ,pcols ,lchnk) - call outfld('CRM_ACC', acc_crm ,pcols ,lchnk) - call outfld('CRM_EVPC', evpc_crm ,pcols ,lchnk) - call outfld('CRM_EVPR', evpr_crm ,pcols ,lchnk) - call outfld('CRM_MLT', mlt_crm ,pcols ,lchnk) - call outfld('CRM_SUB', sub_crm ,pcols ,lchnk) - call outfld('CRM_DEP', dep_crm ,pcols ,lchnk) - call outfld('CRM_CON', con_crm ,pcols ,lchnk) - - ! output for time-mean-avg - call outfld('A_AUT', aut_crm_a , pcols ,lchnk) - call outfld('A_ACC', acc_crm_a , pcols ,lchnk) - call outfld('A_EVPC', evpc_crm_a , pcols ,lchnk) - call outfld('A_EVPR', evpr_crm_a , pcols ,lchnk) - call outfld('A_MLT', mlt_crm_a , pcols ,lchnk) - call outfld('A_SUB', sub_crm_a , pcols ,lchnk) - call outfld('A_DEP', dep_crm_a , pcols ,lchnk) - call outfld('A_CON', con_crm_a , pcols ,lchnk) - endif - - if(do_clubb_sgs) then - call outfld('UP2 ' , clubb_buffer(:, :, :, :, 1) ,pcols ,lchnk) - call outfld('VP2 ' , clubb_buffer(:, :, :, :, 2) ,pcols ,lchnk) - call outfld('WPRTP ' , clubb_buffer(:, :, :, :, 3) ,pcols ,lchnk) - call outfld('WPTHLP ' , clubb_buffer(:, :, :, :, 4) ,pcols ,lchnk) - call outfld('WP2 ' , clubb_buffer(:, :, :, :, 5) ,pcols ,lchnk) - call outfld('WP3 ' , clubb_buffer(:, :, :, :, 6) ,pcols ,lchnk) - call outfld('RTP2 ' , clubb_buffer(:, :, :, :, 7) ,pcols ,lchnk) - call outfld('THLP2 ' , clubb_buffer(:, :, :, :, 8) ,pcols ,lchnk) - call outfld('RTPTHLP ' , clubb_buffer(:, :, :, :, 9) ,pcols ,lchnk) - call outfld('UPWP ' , clubb_buffer(:, :, :, :, 10) ,pcols ,lchnk) - call outfld('VPWP ' , clubb_buffer(:, :, :, :, 11) ,pcols ,lchnk) - call outfld('CRM_CLD ' , clubb_buffer(:, :, :, :, 12) ,pcols ,lchnk) - call outfld('T_TNDCY ' , clubb_buffer(:, :, :, :, 13) ,pcols ,lchnk) - call outfld('QC_TNDCY' , clubb_buffer(:, :, :, :, 14) ,pcols ,lchnk) - call outfld('QV_TNDCY' , clubb_buffer(:, :, :, :, 15) ,pcols ,lchnk) - call outfld('CLUBB_TK ', clubb_tk(:, :, :, :) ,pcols ,lchnk) - call outfld('CLUBB_TKH', clubb_tkh(:, :, :, :) ,pcols ,lchnk) - call outfld('CRM_RELVAR', relvar(:, :, :, :) ,pcols ,lchnk) - call outfld('QCLVAR' , qclvar(:, :, :, :) ,pcols ,lchnk) - call outfld('ACCRE_ENHAN', accre_enhan(:, :, :, :) ,pcols ,lchnk) - - spup2 = 0.0_r8; spvp2 = 0.0_r8; spwprtp = 0.0_r8; spwpthlp = 0.0_r8 - spwp2 = 0.0_r8; spwp3 = 0.0_r8; sprtp2 = 0.0_r8; spthlp2 = 0.0_r8 - sprtpthlp = 0.0_r8; spupwp = 0.0_r8; spvpwp = 0.0_r8; spcrm_cld = 0.0_r8 - spt_tndcy = 0.0_r8; spqc_tndcy = 0.0_r8; spqv_tndcy = 0.0_r8 - spclubb_tk = 0.0_r8; spclubb_tkh = 0.0_r8 - sprelvar = 0.0_r8; spaccre_enhan = 0.0_r8; spqclvar = 0.0_r8 - - do i=1, ncol - do jj=1, crm_ny - do ii=1, crm_nx - do m=1, crm_nz+1 - k = pver-m+1 - spup2(i,k) = spup2(i,k) + clubb_buffer(i, ii, jj, m, 1) / (crm_nx_ny) - spvp2(i,k) = spvp2(i,k) + clubb_buffer(i, ii, jj, m, 2) / (crm_nx_ny) - spwprtp(i,k) = spwprtp(i,k) + clubb_buffer(i, ii, jj, m, 3) / (crm_nx_ny) - spwpthlp(i,k) = spwpthlp(i,k) + clubb_buffer(i, ii, jj, m, 4) / (crm_nx_ny) - spwp2(i,k) = spwp2(i,k) + clubb_buffer(i, ii, jj, m, 5) / (crm_nx_ny) - spwp3(i,k) = spwp3(i,k) + clubb_buffer(i, ii, jj, m, 6) / (crm_nx_ny) - sprtp2(i,k) = sprtp2(i,k) + clubb_buffer(i, ii, jj, m, 7) / (crm_nx_ny) - spthlp2(i,k) = spthlp2(i,k) + clubb_buffer(i, ii, jj, m, 8) / (crm_nx_ny) - sprtpthlp(i,k) = sprtpthlp(i,k) + clubb_buffer(i, ii, jj, m, 9) / (crm_nx_ny) - spupwp(i,k) = spupwp(i,k) + clubb_buffer(i, ii, jj, m, 10) / (crm_nx_ny) - spupwp(i,k) = spupwp(i,k) + clubb_buffer(i, ii, jj, m, 11) / (crm_nx_ny) - spcrm_cld(i,k) = spcrm_cld(i,k) + clubb_buffer(i, ii, jj, m, 12) / (crm_nx_ny) - spt_tndcy(i,k) = spt_tndcy(i,k) + clubb_buffer(i, ii, jj, m, 13) / (crm_nx_ny) - spqc_tndcy(i,k) = spqc_tndcy(i,k) + clubb_buffer(i, ii, jj, m, 14) / (crm_nx_ny) - spqv_tndcy(i,k) = spqv_tndcy(i,k) + clubb_buffer(i, ii, jj, m, 15) / (crm_nx_ny) - end do - do m=1, crm_nz - k = pver-m+1 - spclubb_tk(i,k) = spclubb_tk(i,k) + clubb_tk(i, ii, jj, m) / (crm_nx_ny) - spclubb_tkh(i,k) = spclubb_tkh(i,k) + clubb_tkh(i, ii, jj, m) / (crm_nx_ny) - sprelvar(i,k) = sprelvar(i,k) + relvar(i, ii, jj, m) / (crm_nx_ny) - spaccre_enhan(i,k) = spaccre_enhan(i,k) + accre_enhan(i, ii, jj, m) / (crm_nx_ny) - spqclvar(i,k) = spqclvar(i,k) + qclvar(i, ii, jj, m) / (crm_nx_ny) - end do - end do - end do - end do - - call outfld('SPUP2', spup2 ,pcols ,lchnk) - call outfld('SPVP2', spvp2 ,pcols ,lchnk) - call outfld('SPWPRTP', spwprtp ,pcols ,lchnk) - call outfld('SPWPTHLP', spwpthlp ,pcols ,lchnk) - call outfld('SPWP2', spwp2 ,pcols ,lchnk) - call outfld('SPWP3', spwp3 ,pcols ,lchnk) - call outfld('SPRTP2', sprtp2 ,pcols ,lchnk) - call outfld('SPTHLP2', spthlp2 ,pcols ,lchnk) - call outfld('SPRTPTHLP', sprtpthlp ,pcols ,lchnk) - call outfld('SPUPWP', spupwp ,pcols ,lchnk) - call outfld('SPVPWP', spvpwp ,pcols ,lchnk) - call outfld('SPCRM_CLD', spcrm_cld ,pcols ,lchnk) - call outfld('SPT_TNDCY', spt_tndcy ,pcols ,lchnk) - call outfld('SPQC_TNDCY', spqc_tndcy ,pcols ,lchnk) - call outfld('SPQV_TNDCY', spqv_tndcy ,pcols ,lchnk) - call outfld('SPCLUBB_TK ', spclubb_tk ,pcols ,lchnk) - call outfld('SPCLUBB_TKH', spclubb_tkh ,pcols ,lchnk) - call outfld('SPRELVAR', sprelvar ,pcols, lchnk) - call outfld('SPACCRE_ENHAN', spaccre_enhan ,pcols, lchnk) - call outfld('SPQCLVAR', spqclvar ,pcols, lchnk) - endif ! if do_clubb_sgs - - spcld3d = 0.0_r8 - do i=1, ncol - do jj=1, crm_ny - do ii=1, crm_nx - do m=1, crm_nz - k = pver-m+1 - spcld3d(i,k) = spcld3d(i,k) + cld3d_crm(i,ii,jj,m) / (crm_nx_ny) - end do - end do - end do - end do - call outfld('SPCLD3D', spcld3d, pcols, lchnk) - - ifld = pbuf_get_index('QRL') - call pbuf_get_field(pbuf, ifld, qrl) - ifld = pbuf_get_index('QRS') - call pbuf_get_field(pbuf, ifld, qrs) - do k =1 , pver - do i = 1, ncol - qrs(i,k) = qrs(i,k)/state_loc%pdel(i,k) - qrl(i,k) = qrl(i,k)/state_loc%pdel(i,k) - end do - end do - - ! - ! add radiation tendencies to levels above CRM domain and 2 top CRM levels - ! The radiation tendencies in the top 4 GCM levels are set to be zero in the CRM - ptend_loc%s(:ncol, :pver-crm_nz+2) = qrs(:ncol,:pver-crm_nz+2)+qrl(:ncol,:pver-crm_nz+2) - - - ! calculate the radiative fluxes from the radiation calculation - ! This will be used to check energe conservations - radflux(:) = 0.0_r8 - do k=1, pver - do i=1, ncol - radflux(i) = radflux(i) + (qrs(i,k)+qrl(i,k)) * state_loc%pdel(i,k)/gravit - end do - end do - - ftem(:ncol,:pver) = (ptend_loc%s(:ncol,:pver)-qrs(:ncol,:pver)-qrl(:ncol,:pver))/cpair - - tmp2d(:ncol,:) = qrl(:ncol,:)/cpair - call outfld('SPQRL ',tmp2d ,pcols ,lchnk) - - tmp2d(:ncol,:) = qrs(:ncol,:)/cpair - call outfld('SPQRS ',tmp2d ,pcols ,lchnk) - - call outfld('SPDT ',ftem ,pcols ,lchnk) - call outfld('SPDQ ',ptend_loc%q(1,1,1) ,pcols ,lchnk) - call outfld('SPDQC ',ptend_loc%q(1,1,ixcldliq) ,pcols ,lchnk) - call outfld('SPDQI ',ptend_loc%q(1,1,ixcldice) ,pcols ,lchnk) - call outfld('SPMC ',mctot ,pcols ,lchnk) - call outfld('SPMCUP ',mcup ,pcols ,lchnk) - call outfld('SPMCDN ',mcdn ,pcols ,lchnk) - call outfld('SPMCUUP ',mcuup ,pcols ,lchnk) - call outfld('SPMCUDN ',mcudn ,pcols ,lchnk) - call outfld('SPQC ',spqc ,pcols ,lchnk) - call outfld('SPQI ',spqi ,pcols ,lchnk) - call outfld('SPQS ',spqs ,pcols ,lchnk) - call outfld('SPQG ',spqg ,pcols ,lchnk) - call outfld('SPQR ',spqr ,pcols ,lchnk) - call outfld('SPQTFLX ',flux_qt ,pcols ,lchnk) - call outfld('SPUFLX ',flux_u ,pcols ,lchnk) - call outfld('SPVFLX ',flux_v ,pcols ,lchnk) - call outfld('SPTKE ',tkez ,pcols ,lchnk) - call outfld('SPTKES ',tkesgsz ,pcols ,lchnk) - call outfld('SPTK ',tk_crm ,pcols ,lchnk) - call outfld('SPQTFLXS',fluxsgs_qt ,pcols ,lchnk) - call outfld('SPQPFLX ',flux_qp ,pcols ,lchnk) - call outfld('SPPFLX ',precflux ,pcols ,lchnk) - call outfld('SPQTLS ',qt_ls ,pcols ,lchnk) - call outfld('SPQTTR ',qt_trans ,pcols ,lchnk) - call outfld('SPQPTR ',qp_trans ,pcols ,lchnk) - call outfld('SPQPEVP ',qp_evp ,pcols ,lchnk) - call outfld('SPQPFALL',qp_fall ,pcols ,lchnk) - call outfld('SPQPSRC ',qp_src ,pcols ,lchnk) - call outfld('SPTLS ',t_ls ,pcols ,lchnk) - call outfld('CLOUDTOP',cldtop ,pcols ,lchnk) - call outfld('TIMINGF ',timing_factor ,pcols ,lchnk) - - if (is_spcam_m2005) then - call outfld('SPNC ',spnc ,pcols ,lchnk) - call outfld('SPNI ',spni ,pcols ,lchnk) - call outfld('SPNS ',spns ,pcols ,lchnk) - call outfld('SPNG ',spng ,pcols ,lchnk) - call outfld('SPNR ',spnr ,pcols ,lchnk) - endif - - if (.not. do_clubb_sgs) then - call outfld('CLDTOT ',cltot ,pcols,lchnk) - call outfld('CLDHGH ',clhgh ,pcols,lchnk) - call outfld('CLDMED ',clmed ,pcols,lchnk) - call outfld('CLDLOW ',cllow ,pcols,lchnk) - call outfld('CLOUD ',cld, pcols,lchnk) - end if - - ! - ! Compute liquid water paths (for diagnostics only) - tgicewp(:ncol) = 0._r8 - tgliqwp(:ncol) = 0._r8 - do k=1,pver - do i = 1,ncol - cicewp(i,k) = gicewp(i,k) * 1.0e-3_r8 / max(0.01_r8,cld(i,k)) ! In-cloud ice water path. g/m2 --> kg/m2 - cliqwp(i,k) = gliqwp(i,k) * 1.0e-3_r8 / max(0.01_r8,cld(i,k)) ! In-cloud liquid water path. g/m2 --> kg/m2 - tgicewp(i) = tgicewp(i) + gicewp(i,k) *1.0e-3_r8 ! grid cell mean ice water path. g/m2 --> kg/m2 - tgliqwp(i) = tgliqwp(i) + gliqwp(i,k) *1.0e-3_r8 ! grid cell mean ice water path. g/m2 --> kg/m2 - end do - end do - tgwp(:ncol) = tgicewp(:ncol) + tgliqwp(:ncol) - gwp(:ncol,:pver) = gicewp(:ncol,:pver) + gliqwp(:ncol,:pver) - cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) - - - call outfld('SPCLDTOT',cltot ,pcols,lchnk) - call outfld('SPCLDHGH',clhgh ,pcols,lchnk) - call outfld('SPCLDMED',clmed ,pcols,lchnk) - call outfld('SPCLDLOW',cllow ,pcols,lchnk) - - if(do_clubb_sgs) then - ! Determine parameters for maximum/random overlap -#ifdef SPCAM_CLUBB_SGS - call cldovrlap(lchnk, ncol, state%pint, cld, nmxrgn, pmxrgn) - call cloud_cover_diags_out(lchnk, ncol, cld, state%pmid, nmxrgn, pmxrgn ) -#endif - deallocate(pmxrgn) - deallocate(nmxrgn) - deallocate(spup2) - deallocate(spvp2) - deallocate(spwprtp) - deallocate(spwpthlp) - deallocate(spwp2) - deallocate(spwp3) - deallocate(sprtp2) - deallocate(spthlp2) - deallocate(sprtpthlp) - deallocate(spupwp) - deallocate(spvpwp) - deallocate(spcrm_cld) - deallocate(spt_tndcy) - deallocate(spqv_tndcy) - deallocate(spqc_tndcy) - deallocate(spclubb_tk) - deallocate(spclubb_tkh) - deallocate(sprelvar) - deallocate(spaccre_enhan) - deallocate(spqclvar) - deallocate(crm_cld) - deallocate(clubb_tk) - deallocate(clubb_tkh) - deallocate(relvar) - deallocate(accre_enhan) - deallocate(qclvar) - endif - - call outfld('CLOUDTOP',cldtop, pcols,lchnk) - call outfld('GCLDLWP' ,gwp , pcols,lchnk) - call outfld('TGCLDCWP',tgwp , pcols,lchnk) - call outfld('TGCLDLWP',tgliqwp, pcols,lchnk) - call outfld('TGCLDIWP',tgicewp, pcols,lchnk) - call outfld('ICLDTWP' ,cwp , pcols,lchnk) - call outfld('ICLDIWP' ,cicewp , pcols,lchnk) - - ! Calculate fields which are needed elsewhere in CAM - call pbuf_get_Field(pbuf, ast_idx, cld) ! AST gets values in cld - - ! Find the cldtop for the physics buffer looking for the first location that has a value in the CRM cldtop field - call pbuf_get_field(pbuf, cldtop_idx, cldtop_pbuf) - cldtop_pbuf = pver - do i=1,ncol - do k=1,pver - if (cldtop(i,k) > 1._r8/(crm_nx_ny)) then - cldtop_pbuf(i)=k - exit - end if - end do - end do - - cs(:ncol, 1:pver) = state_loc%pmid(:ncol, 1:pver) / (287.15_r8*state_loc%t(:ncol, 1:pver)) - - call pbuf_get_Field(pbuf, wsedl_idx, wsedl) - if (is_spcam_m2005) then - dunc_arr(:,:) = state_loc%q(:,:,ixnumliq)/ max(mincld,cld(:,:)) - else - dunc_arr(:ncol,1:pver) = 100.e6_r8 / cs(:ncol,1:pver) - end if - do i=1,ncol - do k=1,pver - t = state_loc%t(i,k) - mu = 1.496e-6_r8 * t**1.5_r8/(t+120._r8) - acn = gravit*rhow/(18._r8*mu) - dumc = min( state_loc%q(i,k,ixcldliq) / max(mincld,cld(i,k)),0.005_r8 ) - dunc = dunc_arr(i,k) - call size_dist_param_liq(mg_liq_props, dumc,dunc,cs(i,k),pgam,lamc) - if (dumc >= qsmall) then - wsedl(i,k)=acn*gamma(4._r8+bc+pgam)/(lamc**bc*gamma(pgam+4._r8)) - else - wsedl(i,k)=0._r8 - endif - end do - end do - - if (is_spcam_m2005) then - - ! For convective transport - do i=1, ncol - ideep_crm(i) = i*1.0_r8 - end do - endif - call outfld('MU_CRM ', mu_crm, pcols, lchnk) - call outfld('MD_CRM ', md_crm, pcols, lchnk) - call outfld('EU_CRM ', eu_crm, pcols, lchnk) - call outfld('DU_CRM ', du_crm, pcols, lchnk) - call outfld('ED_CRM ', ed_crm, pcols, lchnk) - -! NAG requires ifdef because tk_crm_ecpp dereferened when not allocated -#ifdef m2005 - if (is_spcam_m2005) then - - qlsinkcen = qlsink_avgcen - - ! copy local tk_crm into pbuf copy - tk_crm_ecpp = tk_crm - - call outfld('ACEN ' , acen , pcols, lchnk) - call outfld('ABND ' , abnd , pcols, lchnk) - call outfld('ACEN_TF ' , acen_tf , pcols, lchnk) - call outfld('ABND_TF ' , abnd_tf , pcols, lchnk) - call outfld('MASFBND ' , massflxbnd , pcols, lchnk) - call outfld('RHCEN ' , rhcen , pcols, lchnk) - call outfld('QCCEN ' , qcloudcen , pcols, lchnk) - call outfld('QICEN ' , qicecen , pcols, lchnk) - call outfld('QSINK_AFCEN' , qlsink_afcen , pcols, lchnk) - call outfld('PRECRCEN' , precrcen , pcols, lchnk) - call outfld('PRECSCEN' , precsolidcen , pcols, lchnk) - call outfld('WUPTHRES' , wupthresh_bnd , pcols, lchnk) - call outfld('WDNTHRES' , wdownthresh_bnd , pcols, lchnk) - call outfld('WWQUI_CEN' , wwqui_cen , pcols, lchnk) - call outfld('WWQUI_CLD_CEN', wwqui_cloudy_cen , pcols, lchnk) - call outfld('WWQUI_BND' , wwqui_bnd , pcols, lchnk) - call outfld('WWQUI_CLD_BND', wwqui_cloudy_bnd , pcols, lchnk) - call outfld('QSINK_BFCEN' , qlsink_bfcen , pcols, lchnk) - call outfld('QSINK_AVGCEN' , qlsink_avgcen , pcols, lchnk) - call outfld('PRAINCEN' , praincen , pcols, lchnk) - endif -#endif - - if (is_spcam_m2005) then - call cnst_get_ind('NUMLIQ', ixnumliq) - call cnst_get_ind('NUMICE', ixnumice) - ptend_loc%lq(ixnumliq) = .TRUE. - ptend_loc%lq(ixnumice) = .TRUE. - ptend_loc%q(:, :, ixnumliq) = 0._r8 - ptend_loc%q(:, :, ixnumice) = 0._r8 - - do i = 1, ncol - do k=1, crm_nz - m= pver-k+1 - do ii=1, crm_nx - do jj=1, crm_ny - ptend_loc%q(i,m,ixnumliq) = ptend_loc%q(i,m,ixnumliq) + crm_nc(i,ii,jj,k) - ptend_loc%q(i,m,ixnumice) = ptend_loc%q(i,m,ixnumice) + crm_ni(i,ii,jj,k) - end do - end do - ptend_loc%q(i,m,ixnumliq) = (ptend_loc%q(i,m,ixnumliq)/(crm_nx_ny) - state_loc%q(i,m,ixnumliq))/ztodt - ptend_loc%q(i,m,ixnumice) = (ptend_loc%q(i,m,ixnumice)/(crm_nx_ny) - state_loc%q(i,m,ixnumice))/ztodt - end do - end do - end if - - ! Sum into overall ptend - call physics_ptend_sum(ptend_loc, ptend, ncol) - - call physics_update(state_loc, ptend_loc, ztodt, tend_loc) - - ! calculate column water of rain, snow and graupel - if(is_spcam_m2005) then - do i=1, ncol - qt_hydro(i, 2) = 0.0_r8 - qli_hydro(i, 2) = 0.0_r8 - qi_hydro(i, 2) = 0.0_r8 - qtot(i, 3) = 0.0_r8 - qt_cloud(i, 3) = 0.0_r8 - qtv(i, 3) = 0.0_r8 - do m=1, crm_nz - k=pver-m+1 - do ii=1, crm_nx - do jj=1, crm_ny - qt_hydro(i,2) = qt_hydro(i,2) + (crm_qr(i,ii,jj,m)+crm_qs(i,ii,jj,m)+crm_qg(i,ii,jj,m)) * & - state_loc%pdel(i,k)/gravit - qli_hydro(i,2) = qli_hydro(i,2) + (crm_qr(i,ii,jj,m)+crm_qs(i,ii,jj,m)+crm_qg(i,ii,jj,m)) * & - state_loc%pdel(i,k)/gravit - qi_hydro(i,2) = qi_hydro(i,2) + (crm_qs(i,ii,jj,m)+crm_qg(i,ii,jj,m)) * & - state_loc%pdel(i,k)/gravit - qtot(i, 3) = qtot(i,3) + (crm_qr(i,ii,jj,m)+crm_qs(i,ii,jj,m)+crm_qg(i,ii,jj,m)) * & - state_loc%pdel(i,k)/gravit + (crm_qt(i,ii,jj,m)+crm_qi(i,ii,jj,m)) * state_loc%pdel(i,k)/gravit - qt_cloud(i, 3) = qt_cloud(i, 3) + (crm_qt(i,ii,jj,m)+crm_qi(i,ii,jj,m)) * & - state_loc%pdel(i,k)/gravit - end do - end do - end do - qt_hydro(i,2) = qt_hydro(i,2) / (crm_nx_ny) - qli_hydro(i,2) = qli_hydro(i,2) / (crm_nx_ny) - qi_hydro(i,2) = qi_hydro(i,2) / (crm_nx_ny) - qtot(i, 3) = qtot(i, 3) / (crm_nx_ny) - qt_cloud(i, 3) = qt_cloud(i, 3) / (crm_nx_ny) - end do - else if(is_spcam_sam1mom) then - do i=1, ncol - qli_hydro(i, 2) = 0.0_r8 - qi_hydro(i, 2) = 0.0_r8 - do m=1, crm_nz - k=pver-m+1 - do ii=1, crm_nx - do jj=1, crm_ny - sfactor = max(0._r8,min(1._r8,(crm_t(i,ii,jj,m)-268.16_r8)*1._r8/(283.16_r8-268.16_r8))) - qli_hydro(i,2) = qli_hydro(i,2)+crm_qp(i,ii,jj,m) * state_loc%pdel(i,k)/gravit - qi_hydro(i,2) = qi_hydro(i,2) +crm_qp(i,ii,jj,m) * (1-sfactor) * state_loc%pdel(i,k)/gravit - end do - end do - end do - qli_hydro(i,2) = qli_hydro(i,2) / (crm_nx_ny) - qi_hydro(i,2) = qi_hydro(i,2) / (crm_nx_ny) - - ! total cloud water and total water vapor, and energy - qt_cloud(i,2) = 0._r8 - qtv(i,2) = 0._r8 - do k=1, pver - qt_cloud(i,2) = qt_cloud(i,2) + (state_loc%q(i,k,ixcldliq)+state_loc%q(i,k,ixcldice)) * state_loc%pdel(i,k)/gravit - qtv(i,2) = qtv(i,2) + state_loc%q(i,k,1) * state_loc%pdel(i,k)/gravit - end do - end do - end if - - ! check water and energy conservation - call check_energy_cam_chng(state_loc, tend_loc, "crm_tend", nstep, ztodt, zero, & - prec_dp(:ncol)+(qli_hydro(:ncol,2)-qli_hydro(:ncol,1))/ztodt/1000._r8, & - snow_dp(:ncol)+(qi_hydro(:ncol,2)-qi_hydro(:ncol,1))/ztodt/1000._r8, radflux) - - ! - ! calculate total water after crm update - ! total hydrometer water (rain, snow, and graupel) - if (is_spcam_m2005) then - do i=1, ncol - - ! total cloud water and total water vapor - qt_cloud(i,2) = 0._r8 - qtv(i,2) = 0._r8 - do k=1, pver - qt_cloud(i,2) = qt_cloud(i,2) + (state_loc%q(i,k,ixcldliq)+state_loc%q(i,k,ixcldice)) * state_loc%pdel(i,k)/gravit - qtv(i,2) = qtv(i,2) + state_loc%q(i,k,1) * state_loc%pdel(i,k)/gravit - end do - ! total water - qtot(i,2) = qt_hydro(i,2) + qt_cloud(i,2) + qtv(i,2) - - ! to check water conservations - if(abs((qtot(i,2)+(precc(i)+precl(i))*1000_r8*ztodt)-qtot(i,1))/qtot(i,1).gt.1.0e-5_r8) then - write(0, *) 'water before crm call', i, lchnk, qtot(i,1), qtv(i,1), qt_cloud(i,1), qt_hydro(i,1) - write(0, *) 'water after crm call', i, lchnk, qtot(i,2)+(precc(i)+precl(i))*1000*ztodt, & - qtv(i,2), qt_cloud(i,2), qt_hydro(i,2), (precc(i)+precl(i))*1000*ztodt - write(0, *) 'water, nstep, crm call2', nstep, i, lchnk, & - ((qtot(i,2)+(precc(i)+precl(i))*1000_r8*ztodt)-qtot(i,1))/qtot(i,1) - write(0, *) 'water, calcualted in crm.F90', i, lchnk, qtotcrm(i, 1), qtotcrm(i, 9), & - qtot(i, 3)+(precc(i)+precl(i))*1000_r8*ztodt, qt_cloud(i, 3), qtv(i,2)+qt_cloud(i,2) - write(0, *) 'water, temperature', i, lchnk, state_loc%t(i,pver) - end if - end do ! end i - endif - - end if ! (is_first_step()) - - call t_stopf('crm') - -! ifdef needed because of use of dtstep_pp_input and spcam_modal_aero_wateruptake_dr -#ifdef m2005 - if (is_spcam_m2005) then - call t_startf('bc_aerosols_mmf') - - where(qc_rad(:ncol,:,:,:crm_nz)+qi_rad(:ncol,:,:,:crm_nz) > 1.0e-10_r8) - cld_rad(:ncol,:,:,:crm_nz) = cld_rad(:ncol,:,:,:crm_nz) - elsewhere - cld_rad(:ncol,:,:,:crm_nz) = 0.0_r8 - endwhere - - ! temporarily turn on all lq, so it is allocated - lq(:) = .true. - call physics_ptend_init(ptend_loc, state_loc%psetcols, 'crm_physics', lq=lq) - - ! set all ptend%lq to false as they will be set in modal_aero_calcsize_sub - ptend%lq(:) = .false. - call modal_aero_calcsize_sub (state_loc, ptend_loc, ztodt, pbuf) - call spcam_modal_aero_wateruptake_dr(state_loc, pbuf) - - ! Wet deposition is done in ECPP, - ! So tendency from wet depostion is not updated in mz_aero_wet_intr (mz_aerosols_intr.F90) - ! tendency from other parts of crmclouds_aerosol_wet_intr are still updated here. - - ! Sum into overall ptend - call physics_ptend_sum(ptend_loc, ptend, ncol) - call physics_update(state_loc, ptend_loc, ztodt, tend_loc) - - - pblh_idx = pbuf_get_index('pblh') - call pbuf_get_field(pbuf, pblh_idx, pblh) - - ! - ! ECPP is called at every 3rd GCM time step. - ! GCM time step is 10 minutes, and ECPP time step is 30 minutes. - ! - dtstep_pp = dtstep_pp_input - necpp = dtstep_pp/ztodt - - ! Only call ECPP every necpp th time step - ! !!!BE CAUTIOUS (Minghuai Wang, 2017-02)!!!!: - ! ptend_loc from crmclouds_mixnuc_tend and parampollu_driver2 has - ! to be multiplied by necpp, as the updates in state occure in tphysbc_spcam, - ! and the normal time step used in tphysbc_spcam is short - ! and ECPP time step is longer (by a facotr of ncecpp). - ! Otherwise, this will lead to underestimation in wet scavenging. - ! - if(nstep.ne.0 .and. mod(nstep, necpp).eq.0) then - call t_startf('crmclouds_mixnuc') - - call crmclouds_mixnuc_tend (aero_props, aero_state, state_loc, ptend_loc, dtstep_pp, cam_in%cflx, pblh, pbuf, & - wwqui_cen, wwqui_cloudy_cen, wwqui_bnd, wwqui_cloudy_bnd) - - ! scale ptend_loc by necpp - call physics_ptend_scale(ptend_loc, necpp*1.0_r8, ncol) - ! Sum into overall ptend - call physics_ptend_sum(ptend_loc, ptend, ncol) - call physics_update(state_loc, ptend_loc, ztodt, tend_loc) - call t_stopf('crmclouds_mixnuc') - - call t_startf('ecpp') - call parampollu_driver2(aero_props, state_loc, ptend_loc, pbuf, dtstep_pp, dtstep_pp, & - acen, abnd, acen_tf, abnd_tf, massflxbnd, & - rhcen, qcloudcen, qlsinkcen, precrcen, precsolidcen, acldy_cen_tbeg ) - ! scale ptend_loc by necpp - call physics_ptend_scale(ptend_loc, necpp*1.0_r8, ncol) - ! Sum into overall ptend - call physics_ptend_sum(ptend_loc, ptend, ncol) - call physics_update(state_loc, ptend_loc, ztodt, tend_loc) - call t_stopf ('ecpp') - end if - - - call t_stopf('bc_aerosols_mmf') - endif ! /*m2005*/ - - deallocate(aero_state) - nullify(aero_state) -#endif - - ! save for old cloud fraction in the MMF simulations - cldo(:ncol, :) = cld(:ncol, :) - - deallocate(crm_micro) - - if (is_spcam_m2005) then - deallocate(acen) - deallocate(acen_tf) - deallocate(rhcen) - deallocate(qcloudcen) - deallocate(qlsinkcen) - deallocate(precrcen) - deallocate(precsolidcen) - deallocate(wwqui_cen) - deallocate(wwqui_cloudy_cen) - deallocate(abnd) - deallocate(abnd_tf) - deallocate(massflxbnd) - deallocate(wwqui_bnd) - deallocate(wwqui_cloudy_bnd) - deallocate(qicecen) - deallocate(qlsink_afcen) - deallocate(qlsink_bfcen) - deallocate(qlsink_avgcen) - deallocate(praincen) - deallocate(wupthresh_bnd) - deallocate(wdownthresh_bnd) - - deallocate(na) - deallocate(va) - deallocate(hy) - deallocate(naermod) - deallocate(vaerosol) - deallocate(hygro) - end if - -#endif - -end subroutine crm_physics_tend - -!===================================================================================================== - -subroutine m2005_effradius(ql, nl,qi,ni,qs, ns, cld, pres, tk, effl, effi, effl_fn, deffi, lamcrad, pgamrad, des) -!----------------------------------------------------------------------------------------------------- -! -! This subroutine is used to calculate droplet and ice crystal effective radius, which will be used -! in the CAM radiation code. The method to calcualte effective radius is taken out of the Morrision's -! two momenent scheme from M2005MICRO_GRAUPEL. It is also very similar with the subroutine of effradius in -! the module of cldwat2m in the CAM source codes. -! -! Adopted by Minghuai Wang (Minghuai.Wang@pnl.gov). -! -!----------------------------------------------------------------------------------------------------- - ! ----------------------------------------------------------- ! - ! Calculate effective radius for pass to radiation code ! - ! If no cloud water, default value is 10 micron for droplets, ! - ! 25 micron for cloud ice. ! - ! Be careful of the unit of effective radius : [micro meter] ! - ! ----------------------------------------------------------- ! - use shr_spfn_mod, only: gamma => shr_spfn_gamma - implicit none - - real(r8), intent(in) :: ql ! Mean LWC of pixels [ kg/kg ] - real(r8), intent(in) :: nl ! Grid-mean number concentration of cloud liquid droplet [#/kg] - real(r8), intent(in) :: qi ! Mean IWC of pixels [ kg/kg ] - real(r8), intent(in) :: ni ! Grid-mean number concentration of cloud ice droplet [#/kg] - real(r8), intent(in) :: qs ! mean snow water content [kg/kg] - real(r8), intent(in) :: ns ! Mean snow crystal number concnetration [#/kg] - real(r8), intent(in) :: cld ! Physical stratus fraction - real(r8), intent(in) :: pres ! Air pressure [Pa] - real(r8), intent(in) :: tk ! air temperature [K] - - real(r8), intent(out) :: effl ! Effective radius of cloud liquid droplet [micro-meter] - real(r8), intent(out) :: effi ! Effective radius of cloud ice droplet [micro-meter] - real(r8), intent(out) :: effl_fn ! effl for fixed number concentration of nlic = 1.e8 - real(r8), intent(out) :: deffi ! ice effective diameter for optics (radiation) - real(r8), intent(out) :: pgamrad ! gamma parameter for optics (radiation) - real(r8), intent(out) :: lamcrad ! slope of droplet distribution for optics (radiation) - real(r8), intent(out) :: des ! snow effective diameter for optics (radiation) [micro-meter] - -#ifdef CRM - real(r8) qlic ! In-cloud LWC [kg/m3] - real(r8) qiic ! In-cloud IWC [kg/m3] - real(r8) nlic ! In-cloud liquid number concentration [#/kg] - real(r8) niic ! In-cloud ice number concentration [#/kg] - - real(r8) cldm ! Constrained stratus fraction [no] - real(r8) mincld ! Minimum stratus fraction [no] - - real(r8) lami, laml, lammax, lammin, pgam, lams, lammaxs, lammins - - real(r8) dcs !autoconversion size threshold [meter] - real(r8) di, ci ! cloud ice mass-diameter relationship - real(r8) ds, cs ! snow crystal mass-diameter relationship - real(r8) qsmall - real(r8) rho ! air density [kg/m3] - real(r8) rhow ! liquid water density [kg/m3] - real(r8) rhoi ! ice density [kg/m3] - real(r8) rhos ! snow density [kg/m3] - real(r8) res ! effective snow diameters - real(r8) pi - - ! ---------------- ! - ! Main computation ! - ! ---------------- ! - - pi = 3.1415926535897932384626434_r8 - qsmall = 1.0e-14_r8 ! in the SAM source code (module_mp_graupel) - rhow = 997._r8 ! in module_mp_graupel, SAM - rhoi = 500._r8 ! in both CAM and SAM - - dcs = 125.e-6_r8 ! in module_mp_graupel, SAM - ci = rhoi * pi/6._r8 - di = 3._r8 - - ! for snow water - rhos = 100._r8 ! in both SAM and CAM5 - cs = rhos*pi/6._r8 - ds = 3._r8 - - - rho = pres / (287.15_r8*tk) ! air density [kg/m3] - - mincld = 0.0001_r8 - cldm = max(cld,mincld) - qlic = min(5.e-3_r8,max(0._r8,ql/cldm)) - qiic = min(5.e-3_r8,max(0._r8,qi/cldm)) - nlic = max(nl,0._r8)/cldm - niic = max(ni,0._r8)/cldm - -!------------------------------------------------------ -! Effective diameters of snow crystals -!------------------------------------------------------ - if(qs.gt.1.0e-7_r8) then - lammaxs=1._r8/10.e-6_r8 - lammins=1._r8/2000.e-6_r8 - lams = (gamma(1._r8+ds)*cs * ns/qs)**(1._r8/ds) - lams = min(lammaxs,max(lams,lammins)) - res = 1.5_r8/lams*1.0e6_r8 - else - res = 500._r8 - end if - - ! - ! from Hugh Morrision: rhos/917 accouts for assumptions about - ! ice density in the Mitchell optics. - ! - des = res * rhos/917._r8 *2._r8 - - ! ------------------------------------- ! - ! Effective radius of cloud ice droplet ! - ! ------------------------------------- ! - - if( qiic.ge.qsmall ) then - niic = min(niic,qiic*1.e20_r8) - lammax = 1._r8/1.e-6_r8 ! in module_mp_graupel, SAM - lammin = 1._r8/(2._r8*dcs+100.e-6_r8) ! in module_mp_graupel, SAM - lami = (gamma(1._r8+di)*ci*niic/qiic)**(1._r8/di) - lami = min(lammax,max(lami,lammin)) - effi = 1.5_r8/lami*1.e6_r8 - else - effi = 25._r8 - endif - - !--hm ice effective radius for david mitchell's optics - !--ac morrison indicates that this is effective diameter - !--ac morrison indicates 917 (for the density of pure ice..) - deffi = effi *rhoi/917._r8*2._r8 - - ! ---------------------------------------- ! - ! Effective radius of cloud liquid droplet ! - ! ---------------------------------------- ! - - if( qlic.ge.qsmall ) then - ! Matin et al., 1994 (JAS) formula for pgam (the same is used in both CAM and SAM). - ! See also Morrison and Grabowski (2007, JAS, Eq. (2)) - nlic = min(nlic,qlic*1.e20_r8) - - ! set the minimum droplet number as 20/cm3. - - pgam = 0.0005714_r8*(nlic*rho/1.e6_r8) + 0.2714_r8 - pgam = 1._r8/(pgam**2)-1._r8 - pgam = min(10._r8,max(pgam,2._r8)) ! in module_mp_graupel, SAM - laml = (pi/6._r8*rhow*nlic*gamma(pgam+4._r8)/(qlic*gamma(pgam+1._r8)))**(1._r8/3._r8) - lammin = (pgam+1._r8)/50.e-6_r8 ! in cldwat2m, CAM - lammax = (pgam+1._r8)/2.e-6_r8 ! in cldwat2m, CAM ! cldwat2m should be used, - ! if lammax is too large, this will lead to crash in - ! src/physics/rrtmg/cloud_rad_props.F90 because - ! klambda-1 can be zero in gam_liquid_lw and gam_liquid_sw - ! and g_lambda(kmu,klambda-1) will not be defined. - - laml = min(max(laml,lammin),lammax) - effl = gamma(pgam+4._r8)/gamma(pgam+3._r8)/laml/2._r8*1.e6_r8 ! in module_mp_graupel, SAM - lamcrad = laml - pgamrad = pgam - else - ! chose 10. over 25, since 10 is a more reasonable value for liquid droplet - effl = 10._r8 ! in cldwat2m, CAM - lamcrad = 0.0_r8 - pgamrad = 0.0_r8 - endif - - ! ---------------------------------------------------------------------- ! - ! Recalculate effective radius for constant number, in order to separate ! - ! first and second indirect effects. Assume constant number of 10^8 kg-1 ! - ! ---------------------------------------------------------------------- ! - - nlic = 1.e8_r8 - if( qlic.ge.qsmall ) then - ! Matin et al., 1994 (JAS) formula for pgam (the same is used in both CAM and SAM). - ! See also Morrison and Grabowski (2007, JAS, Eq. (2)) - nlic = min(nlic,qlic*1.e20_r8) - pgam = 0.0005714_r8*(nlic/1.e6_r8/rho) + 0.2714_r8 - pgam = 1._r8/(pgam**2)-1._r8 - pgam = min(10._r8,max(pgam,2._r8)) ! in module_mp_graupel, SAM - laml = (pi/6._r8*rhow*nlic*gamma(pgam+4._r8)/(qlic*gamma(pgam+1._r8)))**(1._r8/3._r8) - lammin = (pgam+1._r8)/60.e-6_r8 ! in module_mp_graupel, SAM - lammax = (pgam+1._r8)/1.e-6_r8 ! in module_mp_graupel, SAM - - laml = min(max(laml,lammin),lammax) - effl_fn = gamma(pgam+4._r8)/gamma(pgam+3._r8)/laml/2._r8*1.e6_r8 ! in module_mp_graupel, SAM - else - ! chose 10. over 25, since 10 is a more reasonable value for liquid droplet. - effl_fn = 10._r8 ! in cldwat2m, CAM - endif - - return -#endif -end subroutine m2005_effradius - -end module crm_physics diff --git a/src/physics/spcam/crmclouds_camaerosols.F90 b/src/physics/spcam/crmclouds_camaerosols.F90 deleted file mode 100644 index 43889eaeeb..0000000000 --- a/src/physics/spcam/crmclouds_camaerosols.F90 +++ /dev/null @@ -1,756 +0,0 @@ -module crmclouds_camaerosols -#if (defined CRM) -#if (defined MODAL_AERO) -!--------------------------------------------------------------------------------------------- -! Purpose: -! -! Provides the necessary subroutines to use cloud fields from the CRM model to drive the -! aerosol-related subroutines in CAM. Several taskes: -! i) to fill the physics buffers with those diagnosed from the CRM clouds. -! ii) to provide the interface for some physics prcoesses, such as droplet activaiton, -! and convetive transport. -! -! An alternative (and better?) approach is to use the ECPP (explicit-cloud parameterized-pollutant). -! This will be done later. -! -! Revision history: -! July, 27, 2009: Minghuai Wang -! -!-------------------------------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid - use cam_abortutils, only: endrun - use crmdims, only: crm_nx, crm_ny, crm_nz - use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_index, pbuf_old_tim_idx - use physics_types, only: physics_state, physics_state_copy, physics_ptend - use ref_pres, only: top_lev => clim_modal_aero_top_lev - use wv_saturation, only: qsat_water - implicit none - private - save - - public :: spcam_modal_aero_wateruptake_dr - public :: crmclouds_mixnuc_tend - public :: crmclouds_diag - public :: crmclouds_convect_tend - -!====================================================================================================== -contains - -subroutine spcam_modal_aero_wateruptake_dr(state,pbuf) - -!----------------------------------------------------------------------- -! -! SPCAM specific driver for modal aerosol water uptake code. -! -!----------------------------------------------------------------------- - - use time_manager, only: is_first_step - use modal_aero_wateruptake,only: modal_aero_wateruptake_sub - use physconst, only: pi, rhoh2o - use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_props, rad_cnst_get_aer_props - - - ! Arguments - type(physics_state), target, intent(in) :: state ! Physics state variables - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - - ! local variables - - real(r8), parameter :: third = 1._r8/3._r8 - real(r8), parameter :: pi43 = pi*4.0_r8/3.0_r8 - - integer :: ncol ! number of columns - - integer :: i, k, m - integer :: nmodes - integer :: nspec - integer :: mm - - integer :: dgnumwet_idx, qaerwat_idx, wetdens_ap_idx, cld_idx - - integer :: dgnum_idx = 0 - integer :: hygro_idx = 0 - integer :: dryvol_idx = 0 - integer :: dryrad_idx = 0 - integer :: drymass_idx = 0 - integer :: so4dryvol_idx = 0 - integer :: naer_idx = 0 - - real(r8), allocatable :: wtrvol_grid(:,:,:) ! single-particle-mean water volume in wet aerosol (m3) - real(r8), allocatable :: wetvol_grid(:,:,:) ! single-particle-mean wet volume (m3) - real(r8), allocatable :: ncount_clear(:,:,:) ! to count the fraction of clear sky part - - real(r8), pointer :: h2ommr_crm(:,:,:,:) ! specfic humidity in CRM domain - real(r8), pointer :: t_crm(:,:,:,:) ! temperature at the CRM domain - real(r8), pointer :: cldn_crm(:,:,:,:) ! cloud fraction in CRM domain - real(r8), pointer :: qaerwat_crm(:, :, :, :, :) ! aerosol water at CRM domain - real(r8), pointer :: dgncur_awet_crm(:, :, :, :, :) ! wet mode diameter at CRM domain - - real(r8),allocatable :: es_crm(:) ! saturation vapor pressure - real(r8),allocatable :: qs_crm(:) ! saturation specific humidity - real(r8),allocatable :: cldnt(:,:) ! temporal variables - real(r8),allocatable :: rh_crm(:,:,:,:) ! Relative humidity at the CRM grid - real(r8),allocatable :: specdens_1(:) - - real(r8),pointer :: dgncur_a(:,:,:) - real(r8),pointer :: drymass(:,:,:) - real(r8),pointer :: dryrad(:,:,:) - - - real(r8), pointer :: dgncur_awet(:,:,:) - real(r8), pointer :: wetdens(:,:,:) - real(r8), pointer :: qaerwat(:,:,:) - - real(r8), pointer :: h2ommr(:,:) ! specific humidity - real(r8), pointer :: t(:,:) ! temperatures (K) - real(r8), pointer :: pmid(:,:) ! layer pressure (Pa) - real(r8), pointer :: cldn(:,:) ! layer cloud fraction (0-1) - - real(r8), allocatable :: maer(:,:,:) ! aerosol wet mass MR (including water) (kg/kg-air) - real(r8), allocatable :: wetvol(:,:,:) ! single-particle-mean wet volume (m3) - real(r8), allocatable :: wtrvol(:,:,:) ! single-particle-mean water volume in wet aerosol (m3) - real(r8), allocatable :: wtpct(:,:,:) ! sulfate aerosol composition, weight % H2SO4 - real(r8), allocatable :: sulden(:,:,:) ! sulfate aerosol mass density (g/cm3) - - real(r8), pointer :: hygro(:,:,:) ! volume-weighted mean hygroscopicity (--) - real(r8), pointer :: naer(:,:,:) ! aerosol number MR (bounded!) (#/kg-air) - real(r8), pointer :: dryvol(:,:,:) ! single-particle-mean dry volume (m3) - real(r8), pointer :: so4dryvol(:,:,:) ! dry volume of sulfate in single aerosol (m3) - - real(r8) :: specdens, so4specdens - integer :: troplev(pcols) - - real(r8), allocatable :: rhcrystal(:) - real(r8), allocatable :: rhdeliques(:) - - real(r8) :: es(pcols) ! saturation vapor pressure - real(r8) :: qs(pcols) ! saturation specific humidity - - - - real(r8) :: rh(pcols,pver) ! relative humidity (0-1) - - - real(r8), allocatable :: wetrad(:,:,:) ! wet radius of aerosol (m) - - integer :: ii, jj, l - integer :: idx - integer :: itim_old - - - !----------------------------------------------------------------------- - - ncol = state%ncol - - call rad_cnst_get_info(0, nmodes=nmodes) - - allocate(& - es_crm(pcols), & - qs_crm(pcols), & - cldnt(pcols, pver), & - rh_crm(pcols, crm_nx, crm_ny, pver), & - wtrvol_grid(pcols,pver,nmodes), & - wetvol_grid(pcols,pver,nmodes), & - ncount_clear(pcols,pver,nmodes), & - dgncur_a(pcols,pver,nmodes), & - drymass(pcols,pver,nmodes), & - specdens_1(nmodes) ) - - allocate( & - wetrad(pcols,pver,nmodes), & - wetvol(pcols,pver,nmodes), & - wtrvol(pcols,pver,nmodes), & - wtpct(pcols,pver,nmodes), & - sulden(pcols,pver,nmodes), & - rhcrystal(nmodes), & - rhdeliques(nmodes) ) - - wtpct(:,:,:) = 75._r8 - sulden(:,:,:) = 1.923_r8 - - dgnum_idx = pbuf_get_index('DGNUM') - hygro_idx = pbuf_get_index('HYGRO') - dryvol_idx = pbuf_get_index('DRYVOL') - dryrad_idx = pbuf_get_index('DRYRAD') - drymass_idx = pbuf_get_index('DRYMASS') - so4dryvol_idx = pbuf_get_index('SO4DRYVOL') - naer_idx = pbuf_get_index('NAER') - dgnumwet_idx = pbuf_get_index('DGNUMWET') - qaerwat_idx = pbuf_get_index('QAERWAT') - wetdens_ap_idx = pbuf_get_index('WETDENS_AP') - cld_idx = pbuf_get_index('CLD') - - - idx = pbuf_get_index('CRM_QV_RAD') - call pbuf_get_field (pbuf, idx, h2ommr_crm) - idx = pbuf_get_index('CRM_T_RAD') - call pbuf_get_field (pbuf, idx, t_crm) - idx = pbuf_get_index('CRM_CLD_RAD') - call pbuf_get_field (pbuf, idx, cldn_crm) - idx = pbuf_get_index('CRM_QAERWAT') - call pbuf_get_field (pbuf, idx, qaerwat_crm) - idx = pbuf_get_index('CRM_DGNUMWET') - call pbuf_get_field (pbuf, idx, dgncur_awet_crm) - - ncount_clear = 0.0_r8 - wtrvol_grid = 0.0_r8 - wetvol_grid = 0.0_r8 - - call pbuf_get_field(pbuf, hygro_idx, hygro) - call pbuf_get_field(pbuf, dryvol_idx, dryvol) - call pbuf_get_field(pbuf, dryrad_idx, dryrad) - call pbuf_get_field(pbuf, drymass_idx, drymass) - call pbuf_get_field(pbuf, so4dryvol_idx, so4dryvol) - call pbuf_get_field(pbuf, naer_idx, naer) - - call pbuf_get_field(pbuf, dgnum_idx, dgncur_a ) - call pbuf_get_field(pbuf, dgnumwet_idx, dgncur_awet ) - call pbuf_get_field(pbuf, wetdens_ap_idx, wetdens) - call pbuf_get_field(pbuf, qaerwat_idx, qaerwat) - - dgncur_awet(:,:,:) = dgncur_a(:,:,:) - qaerwat = 0._r8 - - h2ommr => state%q(:,:,1) - t => state%t - pmid => state%pmid - - do m = 1, nmodes - ! get mode properties - call rad_cnst_get_mode_props(0, m, rhcrystal=rhcrystal(m), rhdeliques=rhdeliques(m)) - ! get mode info - call rad_cnst_get_info(0, m, nspec=nspec) - - do l = 1, nspec - - ! get species interstitial mixing ratio ('a') - call rad_cnst_get_aer_props(0, m, l, density_aer=specdens) - - if (l == 1) then - ! save off these values to be used as defaults - specdens_1(m) = specdens - end if - - end do - - end do - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - do jj = 1, crm_ny - do ii = 1, crm_nx - do k = top_lev, pver - mm=pver-k+1 - call qsat_water(t(:ncol,k), pmid(:ncol,k), es(:ncol), qs(:ncol),ncol) - do i = 1, ncol - if (qs(i) > h2ommr(i,k)) then - rh(i,k) = h2ommr(i,k)/qs(i) - else - rh(i,k) = 0.98_r8 - endif - rh(i,k) = max(rh(i,k), 0.0_r8) - rh(i,k) = min(rh(i,k), 0.98_r8) - if (cldn(i,k) .lt. 1.0_r8) then - rh(i,k) = (rh(i,k) - cldn(i,k)) / (1.0_r8 - cldn(i,k)) ! clear portion - end if - rh(i,k) = max(rh(i,k), 0.0_r8) - end do - - if (mm <= crm_nz) call qsat_water(t_crm(:ncol,ii,jj,mm), & - pmid(:ncol,k), es_crm(:ncol), qs_crm(:ncol),ncol) - do i = 1, ncol - rh_crm(i, ii, jj, k) = rh(i,k) - if(mm.le.crm_nz) then - rh_crm(i, ii, jj, k) = h2ommr_crm(i,ii,jj,mm)/qs_crm(i) - rh_crm(i, ii, jj, k) = max(rh_crm(i, ii, jj, k), 0.0_r8) - rh_crm(i, ii, jj, k) = min(rh_crm(i, ii, jj, k), 0.98_r8) - if(cldn_crm(i, ii, jj, mm).gt.0.5_r8) then - ! aerosol water uptake is not calculaed at overcast sky in MMF - rh_crm(i, ii, jj, k) = 0.0_r8 - end if - end if - - rh(i,k) = rh_crm(i, ii, jj, k) - cldnt(i, k) = cldn(i,k) - mm=pver-k+1 - if(mm.le.crm_nz) then - cldnt(i,k) = cldn_crm(i, ii, jj, mm) - end if - - do m=1,nmodes - ncount_clear(i,k,m) = ncount_clear(i,k,m) + (1._r8 - cldnt(i,k)) - end do - end do - end do - - call modal_aero_wateruptake_sub( & - ncol, nmodes, rhcrystal, rhdeliques, dryrad, & - hygro, rh, dryvol, so4dryvol, so4specdens, tropLev, & - wetrad, wetvol, wtrvol, sulden, wtpct) - do m = 1, nmodes - do k = top_lev, pver - do i = 1, ncol - dgncur_awet(i,k,m) = dgncur_a(i,k,m) * (wetrad(i,k,m)/dryrad(i,k,m)) - if(k.ge.pver-crm_nz+1) then - qaerwat_crm(i,ii,jj,pver-k+1,m) = rhoh2o*naer(i,k,m)*wtrvol(i,k,m) - dgncur_awet_crm(i,ii,jj,pver-k+1,m) = dgncur_awet(i,k,m) - end if - wtrvol_grid(i,k,m) = wtrvol_grid(i,k,m) + wtrvol(i,k,m)*(1._r8-cldnt(i,k)) - wetvol_grid(i,k,m) = wetvol_grid(i,k,m) + wetvol(i,k,m)*(1._r8-cldnt(i,k)) - qaerwat(i,k,m) = qaerwat(i,k,m)+ rhoh2o*naer(i,k,m)*wtrvol(i,k,m) * (1-cldnt(i,k)) - - end do - end do - end do - end do - end do - - do m = 1, nmodes - do k = 1, pver - do i = 1, ncol - - if(ncount_clear(i,k,m).gt.1.0e-10_r8) then - qaerwat(i,k,m) = qaerwat(i,k,m)/ncount_clear(i,k,m) - wetvol_grid(i,k,m)=wetvol_grid(i,k,m)/ncount_clear(i,k,m) - wtrvol_grid(i,k,m)=wtrvol_grid(i,k,m)/ncount_clear(i,k,m) - if (wetvol_grid(i,k,m) > 1.0e-30_r8) then - wetdens(i,k,m) = (drymass(i,k,m) + & - rhoh2o*wtrvol_grid(i,k,m))/wetvol_grid(i,k,m) - else - wetdens(i,k,m) = specdens_1(m) - end if - wetrad(i,k,m) = max(dryrad(i,k,m), (wetvol_grid(i,k,m)/pi43)**third) - dgncur_awet(i,k,m) = dgncur_a(i,k,m)* & - (wetrad(i,k,m)/dryrad(i,k,m)) - else - dgncur_awet(i,k,m) = dgncur_a(i,k,m) - qaerwat(i,k,m) = 0.0_r8 - wetdens(i,k,m) = specdens_1(m) - end if - end do ! ncol - end do ! pver - end do ! nmodes - - - - deallocate(& - es_crm, & - qs_crm, & - cldnt, & - rh_crm, & - wtrvol_grid, & - wetvol_grid, & - ncount_clear ) - - deallocate(wetrad, wetvol, wtrvol, wtpct, sulden, rhcrystal, rhdeliques, specdens_1) - -end subroutine spcam_modal_aero_wateruptake_dr - - -!------------------------------------------------------------------------------------------------------ -subroutine crmclouds_mixnuc_tend( aero_props, aero_state, state, ptend, dtime, cflx, pblht, pbuf, & - wwqui_cen, wwqui_cloudy_cen, wwqui_bnd, wwqui_cloudy_bnd ) -!----------------------------------------------------------------------------------------------------- -! -! Purpose: to calculate aerosol tendency from dropelt activation and mixing. -! Adopted from mmicro_pcond in cldwat2m.F90 -! -!------------------------------------------------------------------------------------------------------ - use physics_types, only: physics_state, physics_ptend, physics_tend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc, pbuf_old_tim_idx, pbuf_get_index, pbuf_get_field - use physconst, only: gravit, rair, karman - use constituents, only: cnst_get_ind, pcnst, cnst_species_class, cnst_spec_class_gas - use time_manager, only: is_first_step - use cam_history, only: outfld - use ndrop, only: dropmixnuc - use modal_aero_data - use rad_constituents, only: rad_cnst_get_info - - use modal_aerosol_properties_mod, only: modal_aerosol_properties - use modal_aerosol_state_mod, only: modal_aerosol_state - -! Input - type(modal_aerosol_properties), intent(in) :: aero_props - type(modal_aerosol_state), intent(in) :: aero_state - type(physics_state), intent(in) :: state ! state variables - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: pblht(pcols) ! PBL height (meter) - real(r8), intent(in) :: dtime ! timestep - real(r8), intent(in) :: cflx(pcols,pcnst) ! constituent flux from surface - real(r8), intent(in) :: wwqui_cen(pcols, pver) ! vertical velocity variance in quiescent class (m2/s2) - real(r8), intent(in) :: wwqui_cloudy_cen(pcols, pver) ! vertical velocity variance in quiescent, and cloudy class (m2/s2) - real(r8), intent(in) :: wwqui_bnd(pcols, pver+1) ! vertical velocity variance in quiescent class (m2/s2) - real(r8), intent(in) :: wwqui_cloudy_bnd(pcols, pver+1) ! vertical velocity variance in quiescent, and cloudy class (m2/s2) - -! output - type(physics_ptend), intent(out) :: ptend ! package tendencies - -! Local variables - - real(r8), parameter :: wsub_min_asf = 0.1D0 - - integer i,k,m, k1, k2 - integer ifld, itim - integer ixcldliq, ixcldice, ixnumliq - integer l,lnum,lnumcw,lmass,lmasscw - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: nmodes - - real(r8) :: nc(pcols, pver) ! droplet number concentration (#/kg) - real(r8) :: nctend(pcols, pver) ! change in droplet number concentration - real(r8) :: omega(pcols, pver) ! grid-averaaged vertical velocity - real(r8) :: qc(pcols, pver) ! liquid water content (kg/kg) - real(r8) :: qi(pcols, pver) ! ice water content (kg/kg) - real(r8) :: lcldn(pcols, pver) - real(r8) :: lcldo(pcols, pver) - real(r8) :: cldliqf(pcols, pver) - - real(r8) :: wsub(pcols, pver) ! subgrid vertical velocity - real(r8) :: ekd_crm(pcols, pverp) ! diffusivity - real(r8) :: kkvh_crm(pcols, pverp) ! eddy diffusivity - real(r8) :: zs(pcols, pver) ! inverse of distance between levels (meter) - real(r8) :: dz(pcols, pver) ! layer depth (m) - real(r8) :: cs(pcols, pver) ! air density - real(r8) :: lc(pcols, pverp) ! mixing length (m) - real(r8) :: zheight(pcols, pverp) ! height at lay interface (m) - - real(r8) :: alc(pcols, pverp) ! asymptotic length scale (m) - real(r8) :: tendnd(pcols, pver) ! tendency of cloud droplet number concentrations (not used in the MMF) - - real(r8),allocatable :: factnum(:,:,:) ! activation fraction for aerosol number - - real(r8) :: qcld, qsmall - - logical :: dommf=.true. ! value insignificant, if present, means that dropmixnuc is called the mmf part. - -! Variables in the physics buffer: - real(r8), pointer, dimension(:,:) :: cldn ! cloud fractin at the current time step - real(r8), pointer, dimension(:,:) :: cldo ! cloud fraction at the previous time step - real(r8), pointer, dimension(:,:) :: acldy_cen ! liquid cloud fraction at the previous time step from ECPP - real(r8), pointer, dimension(:,:) :: kkvh ! vertical diffusivity - real(r8), pointer, dimension(:,:) :: tke ! turbulence kenetic energy - real(r8), pointer, dimension(:,:) :: tk_crm ! m2/s - - logical :: lq(pcnst) - - lchnk = state%lchnk - ncol = state%ncol - - qsmall = 1.e-18_r8 - - call rad_cnst_get_info(0, nmodes=nmodes) - allocate(factnum(pcols,pver,nmodes)) - - lq(:) = .false. - do m=1,ntot_amode - lnum=numptr_amode(m) - if(lnum>0)then - lq(lnum)= .true. - endif - do l=1,nspec_amode(m) - lmass=lmassptr_amode(l,m) - lq(lmass)= .true. - enddo - enddo - - call physics_ptend_init(ptend,state%psetcols,'crmclouds_mixnuc', lq=lq) - -! -! In the MMF model, turbulent mixing for tracer species are turned off in tphysac. -! So the turbulent for gas species mixing are added here. -! - do m=1, pcnst - if(cnst_species_class(m).eq.cnst_spec_class_gas) then - ptend%lq(m) = .true. - end if - end do - - itim = pbuf_old_tim_idx () - ifld = pbuf_get_index ('CLD') - call pbuf_get_field(pbuf, ifld, cldn, start=(/1,1,itim/), kount=(/pcols,pver,1/) ) - ifld = pbuf_get_index ('CLDO') - call pbuf_get_field(pbuf, ifld, cldo, start=(/1,1,itim/), kount=(/pcols,pver,1/) ) - ifld = pbuf_get_index ('ACLDY_CEN') - call pbuf_get_field(pbuf, ifld, acldy_cen) - ifld = pbuf_get_index('kvh') - call pbuf_get_field(pbuf, ifld, kkvh) - - ifld=pbuf_get_index('tke') - call pbuf_get_field(pbuf, ifld, tke) - - ifld = pbuf_get_index('TK_CRM') - call pbuf_get_field(pbuf, ifld, tk_crm) - - - if (is_first_step()) then - kkvh(:,:)= 0.0_r8 - tke(:,:) = 0.0_r8 - endif - - do i=1, ncol - do k=1, pver-1 - zs(i,k) = 1._r8/(state%zm(i,k)-state%zm(i,k+1)) - end do - zs(i,pver) = zs(i,pver-1) - -! calculate height at layer interface (simple calculation) - zheight(i,pverp) = 0.0_r8 - do k=pver, 1, -1 - zheight(i,k) = zheight(i,k+1) + state%pdel(i,k)/state%pmid(i,k)*(rair*state%t(i,k)/gravit) - end do - -! calculate mixing length -! from Holtslag and Boville, 1993, J. Climate. -! - do k=1, pverp - if(zheight(i,k).le.pblht(i)) then - alc(i,k) = 300._r8 - else - alc(i,k) = 30._r8+270._r8*exp(1._r8-zheight(i,k)/pblht(i)) - endif - lc(i,k) = alc(i,k)*karman*zheight(i,k)/(alc(i,k)+karman*zheight(i,k)) - enddo - end do - - call outfld('LENGC', lc, pcols, lchnk) - - kkvh_crm = 0._r8 - do i=1, ncol - do k=1, pver - -! from vertical variance in the quiescent class, which excldues -! the contribution from strong updraft and downdraft. - wsub(i,k) = sqrt(wwqui_cloudy_cen(i,k)) ! use variance in cloudy quiescent area - wsub(i,k) = min(wsub(i,k), 10._r8) - wsub(i,k) = max(0.20_r8, wsub(i,k)) - end do ! end k - - do k=1, pver+1 - - k1=min(k, pver) - k2=max(k-1, 1) -! -! calculate ekd_crm from wsub in the cloudy quiescent class (following a part of ndrop.F90) - ekd_crm(i,k) = min(10.0_r8, max(0.20_r8, sqrt(wwqui_cloudy_bnd(i,k))))* lc(i,k) - kkvh_crm(i,k) = ekd_crm(i,k) - -! set kkvh to kkvh_crm so this will be used in dropmixnuc in the mmf call - kkvh(i,k) = kkvh_crm(i,k) - - end do !end k - - end do - - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - call cnst_get_ind('NUMLIQ', ixnumliq) - - qc(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) - qi(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) - nc(:ncol,:pver) = state%q(:ncol,:pver,ixnumliq) - cldliqf(:,:) = 1._r8 - lcldn(:,:) = 0._r8 - lcldo(:,:) = 0._r8 - - - do k=1,pver - do i=1,ncol - qcld=qc(i,k)+qi(i,k) - if(qcld.gt.qsmall)then - -#ifdef ECPP -! -! When ECPP is called, activation associated with cloud fraction change is treated in ECPP. -! so set two cloud fractio be the same here. -! But ECPP still did not treat activation associated with turbulent scale motion, and is -! done in dropmixnuc - lcldn(i,k)=acldy_cen(i,k) - lcldo(i,k)=acldy_cen(i,k) -#else - lcldn(i,k)=cldn(i,k)*qc(i,k)/qcld - lcldo(i,k)=cldo(i,k)*qc(i,k)/qcld -#endif - else - lcldn(i,k)=0._r8 - lcldo(i,k)=0._r8 - endif - enddo - enddo - -! should we set omega to be zero ?? - omega(:ncol, :) = state%omega(:ncol, :) - - call dropmixnuc(aero_props, aero_state, state, ptend, dtime, pbuf, wsub, wsub_min_asf, lcldn, lcldo, cldliqf, tendnd, factnum, & - dommf ) - -! this part is moved into tphysbc after aerosol stuffs. -! - - deallocate(factnum) - -end subroutine crmclouds_mixnuc_tend -!====================================================================================================== - -!------------------------------------------------------------------------------------------------------ -subroutine crmclouds_convect_tend(state, ptend, ztodt, pbuf) -!----------------------------------------------------------------- -! -! Purpose: to do convective transport of tracer species using the cloud fields from CRM and using the -! subroutine of zm_conv_convtran_run. -! -! Minghuai Wang, July, 2009: adopted from zm_conv_tend_2 -! -!------------------------------------------------------------------------------------------------------ - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use time_manager, only: get_nstep - use physics_buffer, only: physics_buffer_desc, pbuf_old_tim_idx, pbuf_get_index, pbuf_get_field - use constituents, only: pcnst, cnst_get_ind - use zm_conv_convtran,only: zm_conv_convtran_run - use error_messages, only: alloc_err - -! Arguments -! Input variables: - type(physics_state), intent(in ) :: state ! Physics state variables - real(r8), intent(in) :: ztodt - -! Output variables: - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - -! Local variables - integer :: i, lchnk, istat - integer :: ncol - integer :: nstep - integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. - real(r8), dimension(pcols,pver) :: dpdry - real(r8), dimension(pcols,pver) :: dp ! layer thickness in mbs (between upper/lower interface). - real(r8), dimension(pcols) :: dsubcld ! wg layer thickness in mbs between lcl and maxi. - -! physics buffer fields - integer itim, ifld - real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble - - - real(r8), pointer, dimension(:,:) :: mu !(pcols,pver,begchunk:endchunk) - real(r8), pointer, dimension(:,:) :: eu !(pcols,pver,begchunk:endchunk) - real(r8), pointer, dimension(:,:) :: du !(pcols,pver,begchunk:endchunk) - real(r8), pointer, dimension(:,:) :: md !(pcols,pver,begchunk:endchunk) - real(r8), pointer, dimension(:,:) :: ed !(pcols,pver,begchunk:endchunk) - - real(r8), pointer, dimension(:) :: jtr8 !(pcols,begchunk:endchunk) - ! wg top level index of deep cumulus convection. - real(r8), pointer, dimension(:) :: maxgr8 !(pcols,begchunk:endchunk) - ! wg gathered values of maxi. - real(r8), pointer, dimension(:) :: ideepr8 !(pcols,begchunk:endchunk) - ! w holds position of gathered points vs longitude index - - integer :: jt(pcols) - integer :: maxg(pcols) - integer :: ideep(pcols) - integer :: lengath !(begchunk:endchunk) - logical :: lq(pcnst) - -! -! Initialize -! - - lq(:) = .true. - lq(1) = .false. - lq(ixcldice) = .false. - lq(ixcldliq) = .false. - - call physics_ptend_init(ptend,state%psetcols,'zm_conv_convtran_run2',lq=lq) - -! -! Associate pointers with physics buffer fields -! - ifld = pbuf_get_index('FRACIS') - call pbuf_get_field(pbuf, ifld, fracis, start=(/1,1,1/), kount=(/pcols,pver,pcnst/) ) - - ifld = pbuf_get_index('MU_CRM') - call pbuf_get_field(pbuf, ifld, mu) - ifld = pbuf_get_index('MD_CRM') - call pbuf_get_field(pbuf, ifld, md) - ifld = pbuf_get_index('DU_CRM') - call pbuf_get_field(pbuf, ifld, du) - ifld = pbuf_get_index('EU_CRM') - call pbuf_get_field(pbuf, ifld, eu) - ifld = pbuf_get_index('ED_CRM') - call pbuf_get_field(pbuf, ifld, ed) - ifld = pbuf_get_index('JT_CRM') - call pbuf_get_field(pbuf, ifld, jtr8) - ifld = pbuf_get_index('MX_CRM') - call pbuf_get_field(pbuf, ifld, maxgr8) - ifld = pbuf_get_index('IDEEP_CRM') - call pbuf_get_field(pbuf, ifld, ideepr8) - - -! Transport all constituents except cloud water and ice -! - - lchnk = state%lchnk - ncol = state%ncol - - nstep = get_nstep() - -! -! Convective transport of all trace species except cloud liquid -! and cloud ice done here because we need to do the scavenging first -! to determine the interstitial fraction. -! - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - - -! Is this ok to get the index??? - jt = int(jtr8+0.5_r8) - maxg = int(maxgr8+0.5_r8) - ideep = int(ideepr8+0.5_r8) - -! calculate lengath from ideep - lengath = 0 - do i=1, ncol - if(ideep(i).ge.1) then - lengath = lengath + 1 - endif - end do - -! -! initialize dpdry for call to zm_conv_convtran_run -! it is used for tracers of dry smixing ratio type -! - dpdry = 0._r8 - do i = 1,lengath - dpdry(i,:) = state%pdeldry(ideep(i),:)/100._r8 - dp(i,:) = state%pdel(ideep(i),:)/100._r8 - end do - -! dsubdld is not used in zm_conv_convtran_run, and is set to be zero. - dsubcld = 0._r8 - - - !REMOVECAM - no longer need these when CAM is retired and pcols no longer exists - ptend%q(:,:,:) = 0._r8 - !REMOVECAM_END - call zm_conv_convtran_run (ncol,pver, & - ptend%lq,state%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & - du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & - jt(:ncol),maxg(:ncol),ideep(:ncol), 1, lengath, & - nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:)) - -end subroutine crmclouds_convect_tend -!===================================================================================================== - -!------------------------------------------------------------------------------------------------------ -subroutine crmclouds_diag - -end subroutine crmclouds_diag -!====================================================================================================== - -#endif -#endif /*CRM*/ - -end module crmclouds_camaerosols diff --git a/src/physics/spcam/crmdims.F90 b/src/physics/spcam/crmdims.F90 deleted file mode 100644 index a1765db60c..0000000000 --- a/src/physics/spcam/crmdims.F90 +++ /dev/null @@ -1,11 +0,0 @@ -module crmdims -#ifdef CRM - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - - integer, parameter :: nclubbvars = 17 - - integer, parameter :: crm_nx=SPCAM_NX, crm_ny=SPCAM_NY, crm_nz=SPCAM_NZ - real(r8), parameter :: crm_dx=SPCAM_DX, crm_dy=SPCAM_DX, crm_dt=SPCAM_DT -#endif -end module crmdims diff --git a/src/physics/spcam/ecpp/ecpp_modal_aero_activate.F90 b/src/physics/spcam/ecpp/ecpp_modal_aero_activate.F90 deleted file mode 100644 index 3ef62edd04..0000000000 --- a/src/physics/spcam/ecpp/ecpp_modal_aero_activate.F90 +++ /dev/null @@ -1,663 +0,0 @@ -module ecpp_modal_aero_activate - -!----------------------------------------------------------------- -! Module interface of aerosol activaiton used in the ECPP treatment -! in the MMF model -! Adopted from ndrop.F90 and from the similar one used in the ECPP -! for the WRF-chem model written by Dick Easter -! -! Minghuai Wang, 2009-11 -!------------------------------------------------------------------ - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_abortutils, only: endrun - use constituents, only: pcnst - - use modal_aerosol_properties_mod, only: modal_aerosol_properties - - implicit none - - public parampollu_tdx_activate1 - -contains - -!----------------------------------------------------------------------- - subroutine parampollu_tdx_activate1( aero_props, & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, wbnd_bar, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, ifrom_where, activate_onoff_use, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - chem_sub_old, & - mfbnd_use, & - ar_bnd_tavg, & - ent_airamt, & - ido_actres_horz, fmact_horz, fnact_horz, & - fmact_vert, fnact_vert, mfbnd_quiescn_up ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_tdx_activate1 calculates number and mass activation -! fractions associated with vertical and horizontal transfer -! between subclasses -! -!----------------------------------------------------------------------- - - use module_data_mosaic_asect, only: maxd_asize, maxd_atype, & - nsize_aer, ntype_aer - - use module_data_radm2, only: epsilc - - use module_data_ecpp1 - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message - -! arguments - type(modal_aerosol_properties), intent(in) :: aero_props - integer, intent(in) :: & - ktau, ktau_pp, & - it, jt, kts, ktebnd, ktecen -! ktau - time step number -! ktau_pp - time step number for "parameterized pollutants" calculations -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) - - real(r8), intent(in) :: dtstep, dtstep_pp -! dtstep - main model time step (s) -! dtstep_pp - time step (s) for "parameterized pollutants" calculations - - real(r8), intent(in), dimension( kts:ktecen ) :: & - tcen_bar, pcen_bar, rhocen_bar, dzcen - real(r8), intent(in), dimension( kts:ktebnd ) :: & - rhobnd_bar, wbnd_bar -! tcen_bar - temperature (K) at layer centers -! rhocen_bar, rhobnd_bar - dry air density (kg/m^3) at layer centers and boundaries -! pcen_bar - air pressure (Pa) at layer centers -! wbnd_bar - vertical velocity (m/s) at layer boundaries -! dzcen - layer thicknesses (m) -! - integer, intent(in) :: ncls_ecpp -! ncls_ecpp - number of ecpp transport classes in the grid column - integer, intent(in) :: ifrom_where -! 1,2 - from area_change; 10 - from main_integ - integer, intent(in) :: activate_onoff_use -! 1-99 - calc real fmact,fnact -! 200 - set fmact = fmact_testa, ... -! other - set fmact,fnact = 0.0 -! ALSO, ido_actres_horz is set correctly when activate_onoff_use > 0 -! but is set to zero when activate_onoff_use <= 0 - - integer, intent(in) :: ncls_use - - integer, intent(in), dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_old - - real(r8), intent(inout), dimension( kts:ktebnd, 0:2, 0:maxcls_ecpp ) :: & - ar_bnd_tavg, mfbnd_use - - real(r8), intent(in), dimension( 1:2, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ent_airamt - - integer, intent(out), dimension( 1:2, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp ) :: & - ido_actres_horz -! ido_actres_horz(iccaa,jclsaa,iccbb,jclsbb) is associated with air moving -! into sub-class (iccaa,jclsaa) from sub-class (iccbb,jclsbb) -! ido_actres_horz = +1 or +2 if activation, -1 if resuspension, 0 otherwise -! note that its values are independent of k (i.e., they only depend on the source and -! destination sub-classes) -! the fnact and fmact do depend on k - - real(r8), intent(out), dimension( 1:maxd_asize, 1:maxd_atype, 1:maxcls_ecpp, & - 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - fmact_horz, fnact_horz -! fmact_horz(m,n,jclsaa,iccbb,jclsbb,k) and fnact(...) are associated with air moving -! into sub-class (icc=2,jclsaa,k) from sub-class (iccbb,jclsbb,k) - - real(r8), optional, intent(out), dimension( 1:maxd_asize, 1:maxd_atype, kts:ktecen ) :: & - fmact_vert, fnact_vert -! fnact_vert(m,n,k) and fmact(...) are associated with (quiescent, clear, layer k-1) air moving -! into (quiescent, cloudy, layer k) - - real(r8), optional, intent(in), dimension( kts:ktebnd, 0:2, 0:2 ) :: & - mfbnd_quiescn_up - - -! local variables - integer :: icc, iccb, iccy, ido_actres_tmp, ihorzvert, itmpa - integer :: jcls, jclsy, jj - integer :: k, l - integer :: m, n - - real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpt - real(r8) :: wbar_tmp, wmix_tmp - - real(r8), dimension( 1:maxd_asize, 1:maxd_atype ) :: & - fnact_tmp, fmact_tmp - real(r8), dimension( 1:maxd_asize, 1:maxd_atype, 2 ) :: & - fnact_testa, fmact_testa - - -! initialize fnact/fmact to zero - ido_actres_horz(:,:,:,:) = 0 - fmact_horz(:,:,:,:,:,:) = 0.0_r8 - fnact_horz(:,:,:,:,:,:) = 0.0_r8 - if ( present(fmact_vert) ) fmact_vert(:,:,:) = 0.0_r8 - if ( present(fnact_vert) ) fnact_vert(:,:,:) = 0.0_r8 - - if (activate_onoff_use <= 0) return - - -! temporary values for testing purposes - fmact_testa(:,:,:) = 0.0_r8 - fnact_testa(:,:,:) = 0.0_r8 - - fmact_testa(1,1:3,1) = (/ 0.50_r8, 0.90_r8, 0.95_r8 /) ! updraft_r8 - fnact_testa(1,1:3,1) = (/ 0.40_r8, 0.80_r8, 0.90_r8 /) - fmact_testa(1,1:3,2) = (/ 0.30_r8, 0.80_r8, 0.90_r8 /) ! quiescent - fnact_testa(1,1:3,2) = (/ 0.20_r8, 0.60_r8, 0.80_r8 /) - -! -! horizontal transfer -! - -! first set ido_actres_horz -! note again: ido_actres_horz(icc,jcls,iccy,jclsy) is from iccy,jclsy to icc,jcls - do jclsy = 1, ncls_use - do iccy = 1, 2 - do jcls = 1, ncls_use - do icc = 1, 2 - - if (icc == 1) then - if (iccy == 1) then - ! clear --> clear -- do nothing (no activation or resuspension) - cycle - else - ! cloudy --> clear -- do resuspension - ido_actres_horz(icc,jcls,iccy,jclsy) = -1 - end if - - else - if (iccy == 1) then - ! clear --> cloudy -- do activation for into updrafts & quiescent - ! do nothing for into downdrafts - if (mtype_updnenv_use(icc,jcls) /= mtype_dndraft_ecpp) & - ido_actres_horz(icc,jcls,iccy,jclsy) = 1 - else - ! cloudy --> cloudy -- do (re)activation for into updrafts - ! do nothing for into downdrafts & quiescent - ! if (mtype_updnenv_use(icc,jcls) == mtype_updraft_ecpp) & - ! ido_actres_horz(icc,jcls,iccy,jclsy) = 2 - end if - end if - - end do ! icc - end do ! jcls - end do ! iccy - end do ! jclsy - - - -! next calc activation fractions -horz_k_loop: & - do k = kts, ktecen - -horz_jcls_loop: & - do jcls = 1, ncls_use - icc = 2 - -horz_jclsy_loop: & - do jclsy = 1, ncls_use - -horz_iccy_loop: & - do iccy = 1, 2 - - if (ent_airamt(icc,jcls,iccy,jclsy,k) <= 0.0_r8) cycle horz_iccy_loop - - if (jcls == jcls_qu) then -! quiescent class -! it can entrain from quiescent, updraft, dndraft -! do activation for entrain from clear-any - if (iccy == 2) cycle horz_iccy_loop ! only activate clear --> cloudy - - else if (mtype_updnenv_use(icc,jcls) == mtype_dndraft_ecpp) then -! downdraft class -! it can entrain from quiescent, dndraft -! do activation for none of these - cycle horz_iccy_loop - - else -! updraft class -! it can entrain from quiescent, updraft -! do activation for entrain from any-quiescent and clear-updraft - if (jclsy == jcls_qu) then - continue - else if ( (iccy == 1) .and. & - (mtype_updnenv_use(iccy,jclsy) == & - mtype_updraft_ecpp) ) then - continue - else - cycle horz_iccy_loop - end if - end if - - if (activate_onoff_use == 200) then ! use the fmnact_tst values - jj = 1 - if (jcls == jcls_qu) jj = 2 - fmact_horz(:,:,jcls,iccy,jclsy,k) = fmact_testa(:,:,jj) - fnact_horz(:,:,jcls,iccy,jclsy,k) = fnact_testa(:,:,jj) - end if - - if (activate_onoff_use < 100) then ! calculate "real" values -! stop '*** parampollu_tdx_activate1 - cannot do activate_onoff_use < 100' - - tmpa = 0.5_r8*(mfbnd_use(k,icc,jcls)+mfbnd_use(k+1,icc,jcls)) - tmpb = 0.5_r8*(ar_bnd_tavg(k,icc,jcls)+ar_bnd_tavg(k+1,icc,jcls)) - if (tmpb > 0.0_r8) then - if (abs(tmpa) > abs(tmpb)*w_draft_max) then - wbar_tmp = w_draft_max - else - wbar_tmp = tmpa/tmpb - end if - else - wbar_tmp = 0.0_r8 - end if - wbar_tmp = wbar_tmp + 0.5_r8*(wbnd_bar(k)+wbnd_bar(k+1)) - wmix_tmp = 0.0_r8 - if (max(wbar_tmp,wmix_tmp) <= 0.0_r8) cycle horz_iccy_loop - - ido_actres_tmp = ido_actres_horz(icc,jcls,iccy,jclsy) - ihorzvert = 1 - - call parampollu_tdx_activate_intface( aero_props, & - ktau, ktau_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - ncls_ecpp, ncls_use, & - it, jt, kts,ktebnd,ktecen, & - k, iccy, jclsy, jcls, & - activate_onoff_use, ido_actres_tmp, & - ihorzvert, ifrom_where, & - chem_sub_old, & - tcen_bar(k), rhocen_bar(k), & - wbar_tmp, wmix_tmp, & - fmact_testa, fnact_testa, & - fmact_tmp, fnact_tmp ) - - fmact_horz(:,:,jcls,iccy,jclsy,k) = fmact_tmp(:,:) - fnact_horz(:,:,jcls,iccy,jclsy,k) = fnact_tmp(:,:) - end if - - end do horz_iccy_loop - end do horz_jclsy_loop - end do horz_jcls_loop - end do horz_k_loop - -! write(*,'(a,i4,1p,4e10.2)') 'tdx_activate1 horz min/max', ifrom_where, & -! minval(fmact_horz(:,:,:,:,:,:)), maxval(fmact_horz(:,:,:,:,:,:)), & -! minval(fnact_horz(:,:,:,:,:,:)), maxval(fnact_horz(:,:,:,:,:,:)) - - -! -! vertical transfer -! in up/dndrafts, vertical transport is clear<-->clear or cloudy<-->cloudy -! so no activation -! in quiescent, can have clear<-->cloudy -! do activation for clear(k-1)-->cloud(k) -! - if ( present(fmact_vert) .and. present(fnact_vert) ) then - -vert_k_loop: & - do k = kts, ktecen - if (k == kts) cycle vert_k_loop - - jcls = jcls_qu - icc = 2 - jclsy = jcls_qu - iccy = 1 - -! mfbnd_quiescn_up(k,iccy,icc) is upwards mass flux from iccy to icc -! at bottom of layer k - if (mfbnd_quiescn_up(k,iccy,icc) <= 0.0_r8) cycle vert_k_loop - - if (activate_onoff_use == 200) then ! use the fmnact_tst values - jj = 2 - fmact_vert(:,:,k) = fmact_testa(:,:,jj) - fnact_vert(:,:,k) = fnact_testa(:,:,jj) - end if - - if (activate_onoff_use < 100) then ! calculate "real" values -! stop '*** parampollu_tdx_activate1 - cannot do activate_onoff_use < 100' - - tmpa = mfbnd_use(k,iccy,jclsy) - tmpb = ar_bnd_tavg(k,iccy,jclsy) - if (tmpb > 0.0_r8) then - if (abs(tmpa) > abs(tmpb)*w_draft_max) then - wbar_tmp = w_draft_max - else - wbar_tmp = tmpa/tmpb - end if - else - wbar_tmp = 0.0_r8 - end if - wbar_tmp = wbar_tmp + wbnd_bar(k) - wmix_tmp = 0.0_r8 - if (max(wbar_tmp,wmix_tmp) <= 0.0_r8) cycle vert_k_loop - - ido_actres_tmp = 1 - - tmpt = 0.5_r8*( tcen_bar(k) + tcen_bar(max(k-1,kts)) ) - - ido_actres_tmp = 1 - ihorzvert = 2 - - call parampollu_tdx_activate_intface( aero_props, & - ktau, ktau_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - ncls_ecpp, ncls_use, & - it, jt, kts,ktebnd,ktecen, & - k-1, iccy, jclsy, jcls, & - activate_onoff_use, ido_actres_tmp, & - ihorzvert, ifrom_where, & - chem_sub_old, & - tmpt, rhobnd_bar(k), & - wbar_tmp, wmix_tmp, & - fmact_testa, fnact_testa, & - fmact_tmp, fnact_tmp ) - - fmact_vert(:,:,k) = fmact_tmp(:,:) - fnact_vert(:,:,k) = fnact_tmp(:,:) - end if - - end do vert_k_loop - -! write(*,'(a,i4,1p,4e10.2)') 'tdx_activate1 vert min/max', ifrom_where, & -! minval(fmact_vert(:,:,:)), maxval(fmact_vert(:,:,:)), & -! minval(fnact_vert(:,:,:)), maxval(fnact_vert(:,:,:)) - - end if ! ( present(fmact_vert) .and. present(fnact_vert) ) - - - - return - end subroutine parampollu_tdx_activate1 - - - -!----------------------------------------------------------------------- - subroutine parampollu_tdx_activate_intface( aero_props, & - ktau, ktau_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - ncls_ecpp, ncls_use, & - i, j, kts,ktebnd,ktecen, & - k, iccy, jclsy, jcls, & - activate_onoff_use, ido_actres, & - ihorzvert, ifrom_where, & - chem_sub_old, & - tempair_in, rhoair_in, & - wbar_in, wmix_in, & - fmact_testa, fnact_testa, & - fmact, fnact ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_tdx_activate1 calculates number and mass activation -! fractions associated with vertical and horizontal transfer -! between subclasses -! -!----------------------------------------------------------------------- - - use module_data_mosaic_asect, only: & - maxd_acomp, maxd_asize, maxd_atype, & - ncomp_aer, nsize_aer, ntype_aer, & - nphase_aer, ai_phase, cw_phase, & - numptr_aer, massptr_aer, sigmag_aer - - use module_data_ecpp1 - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message - - use ndrop, only: activate_aerosol - -! arguments - type(modal_aerosol_properties), intent(in) :: aero_props - integer, intent(in) :: & - ktau, ktau_pp, & - i, j, kts, ktebnd, ktecen -! ktau - time step number -! ktau_pp - time step number for "parameterized pollutants" calculations -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) - - integer, intent(in) :: & - k, iccy, jclsy, jcls - - real(r8), intent(in) :: tempair_in, rhoair_in, wbar_in, wmix_in -! tempair - temperature (k) -! rhoair - air density (kg/m3) - - integer, intent(in) :: ncls_ecpp -! ncls_ecpp - number of ecpp transport classes in the grid column - integer, intent(in) :: ncls_use - - integer, intent(in) :: activate_onoff_use -! 1-99 - calc real fmact,fnact -! 200 - set fmact = fmact_testa, ... -! other - set fmact,fnact = 0.0 - integer, intent(in) :: ido_actres, ihorzvert, ifrom_where - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_old - - real(r8), intent(in), dimension( 1:maxd_asize, 1:maxd_atype, 2 ) :: & - fnact_testa, fmact_testa - - real(r8), intent(out), dimension( 1:maxd_asize, 1:maxd_atype ) :: & - fmact, fnact - - -! local variables - integer :: iphase, jj, l, ll, lun, m, n - integer, save :: ifrom_where_save, ktau_save - data ifrom_where_save, ktau_save / -1, -1 / - - real(r8) :: factscale, flux_fullact - real(r8) :: rhoair - real(r8) :: sumhygro, sumvol - real(r8) :: tempair, tmpc - real(r8) :: wbar, wdiab, wmin, wmax, wmix, wmixmin - - real(r8) :: raercol( 1:1, 1:num_chem_ecpp ) - - real(r8) :: raer (1:pcnst) ! interstitial aerosols - real(r8) :: qqcw (1:pcnst) ! interstitial aerosols - - real(r8), dimension( 1:maxd_asize, 1:maxd_atype ) :: & - fn, fs, fm, fluxn, fluxs, fluxm, hygro, & - maerosol_tot, maerosol_totcw, & - naerosol, naerosolcw, & - vaerosol, vaerosolcw, sigmag - - real(r8), dimension( 1:maxd_acomp, 1:maxd_asize, 1:maxd_atype ) :: & - maerosol, maerosolcw - - - -! initialize fnact/fmact to zero - fmact(:,:) = 0.0_r8 - fnact(:,:) = 0.0_r8 - -! special testing cases - if ((activate_onoff_use <= 0) .or. (activate_onoff_use >= 100)) then - return - else if (activate_onoff_use == 81) then - return - else if (activate_onoff_use == 82) then - jj = 1 - if (jcls == jcls_qu) jj = 2 - fmact(:,:) = fmact_testa(:,:,jj) - fnact(:,:) = fnact_testa(:,:,jj) - return - end if - -! -! calc activation fractions -! - tempair = tempair_in - rhoair = rhoair_in - wbar = wbar_in - wmix = wmix_in - - wmixmin = 0.2_r8 - ! do single updraft, forced to wbar >= wmixmin - wbar = max( wbar+wmix, wmixmin ) - wmix = 0.0_r8 - - wmin = 0.0_r8 - wmax = 50.0_r8 - wdiab = 0.0_r8 - -! load raercol (with units conversion) and calculate hygro - raercol(:,:) = 0.0_r8 - - raer(1:pcnst) = chem_sub_old(k,iccy,jclsy,1:pcnst) - qqcw(1:pcnst) = chem_sub_old(k,iccy,jclsy,pcnst+1:2*pcnst) - -! do loadaer calls - do n=1,ntype_aer - do m=1,nsize_aer(n) - - if(ido_actres ==2 ) then - iphase = 3 - else - iphase = 1 - end if - call loadaer0D (raer, qqcw, n, rhoair, ai_phase, & - naerosol(m,n), vaerosol(m,n), hygro(m,n)) - sigmag(m, n) = sigmag_aer(m,n) - enddo ! m - enddo ! n - -! do activate call - m = 1 ! for the CAM modal aeosol, nsize_aer is always 1. - call activate_aerosol( wbar, wmix, wdiab, wmin, wmax, tempair, rhoair, & - naerosol(m,:), ntype_aer, & - vaerosol(m,:), hygro(m,:), aero_props, & - fn(m,:), fm(m,:), fluxn(m,:), fluxm(m,:), flux_fullact ) - -! load results - fmact(:,:) = fm(:,:) - fnact(:,:) = fn(:,:) - -! diagnostics - lun = ldiagaa_ecpp(125) - if ((idiagaa_ecpp(125) > 0) .and. (lun > 0)) then - - if ((ktau /= ktau_save) .or. (ifrom_where /= ifrom_where_save)) & - write(lun,'(//a,4i8)') & - 'activate_intface - ktau, ifrom_where =', ktau, ifrom_where - ktau_save = ktau - ifrom_where_save = ifrom_where - - write(lun,'(2i3,2x,2i2,2x,4i2, 1p,2x,3e8.1, 0p,3x,3f7.3, 2(3x,4f6.3))') & - jcls, k, jclsy, iccy, ido_actres, ihorzvert, maxd_asize, maxd_atype, & - naerosol(1,1:3)*1.0e-6_r8, wbar_in, wmix_in, wbar, fmact(1,1:3), fnact(1,1:3) - write(lun,'(8x,a, 1p,2x,4e10.2)') ' vaerosol', vaerosol(1,1:3) - write(lun,'(8x,a, 1p,2x,4e10.2)') ' hygro ', hygro(1,1:3) - write(lun,'(8x,a, 1p,2x,6e10.2)') ' t,rho', tempair, rhoair - - end if - - - return - end subroutine parampollu_tdx_activate_intface -!========================================================================================================== - -!---------------------------------------------------------------------------------------------------------- - subroutine loadaer0D(raer,qqcw,m,cs, phase, & - naerosol, vaerosol, hygro ) -!------------------------------------------------------------------------- -! This subroutine is adopted from loadaer in ndrop.F90. It is 2D in ndrop.F90, -! but it is 0D here (single point). So that we do not need to define arrays with -! pcols, pver. -! Minghuai Wang, 2009-11 -!------------------------------------------------------------------------- - use modal_aero_data - - implicit none - -! load aerosol number, volume concentrations, and bulk hygroscopicity - - real(r8), intent(in) :: raer(pcnst) ! aerosol mass, number mixing ratios - real(r8), intent(in) :: qqcw(pcnst) ! cloud-borne aerosol mass, number mixing ratios - integer, intent(in) :: m ! m=mode 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 - real(r8), intent(out) :: naerosol ! interstitial number conc (/m3) - real(r8), intent(out) :: vaerosol ! interstitial+activated volume conc (m3/m3) - real(r8), intent(out) :: hygro ! bulk hygroscopicity of mode - -! internal - - real(r8) vol ! aerosol volume mixing ratio - integer i,lnum,lnumcw,l,lmass,lmasscw - - vaerosol=0._r8 - hygro=0._r8 - - do l=1,nspec_amode(m) - lmass=lmassptr_amode(l,m) ! interstitial - lmasscw=lmassptrcw_amode(l,m) ! cloud-borne - if(phase.eq.3)then - vol=max(raer(lmass)+qqcw(lmasscw),0._r8)/specdens_amode(l,m) - elseif(phase.eq.2)then - vol=max(qqcw(lmasscw),0._r8)/specdens_amode(l,m) - elseif(phase.eq.1)then - vol=max(raer(lmass),0._r8)/specdens_amode(l,m) - else - write(6,*)'phase=',phase,' in loadaer' - call endrun('phase error in loadaer') - endif - vaerosol=vaerosol+vol - hygro=hygro+vol*spechygro(l,m) - enddo - if (vaerosol > 1.0e-30_r8) then ! +++xl add 8/2/2007 - hygro=hygro/(vaerosol) - vaerosol=vaerosol*cs - else - hygro=0.0_r8 - vaerosol=0.0_r8 - endif - - lnum=numptr_amode(m) - lnumcw=numptrcw_amode(m) -! aerosol number predicted - if(phase.eq.3)then - naerosol=(raer(lnum)+qqcw(lnumcw))*cs - elseif(phase.eq.2)then - naerosol=qqcw(lnumcw)*cs - else - naerosol=raer(lnum)*cs - endif -! adjust number so that dgnumlo < dgnum < dgnumhi - naerosol = max( naerosol, vaerosol*voltonumbhi_amode(m) ) - naerosol = min( naerosol, vaerosol*voltonumblo_amode(m) ) - - return - end subroutine loadaer0D -!============================================================================================ - -end module ecpp_modal_aero_activate diff --git a/src/physics/spcam/ecpp/ecpp_modal_cloudchem.F90 b/src/physics/spcam/ecpp/ecpp_modal_cloudchem.F90 deleted file mode 100644 index 66ff95b967..0000000000 --- a/src/physics/spcam/ecpp/ecpp_modal_cloudchem.F90 +++ /dev/null @@ -1,700 +0,0 @@ -module ecpp_modal_cloudchem - -!----------------------------------------------------------------- -! Module interface for cloud chemistry used in the ECPP treatment -! in the MMF model -! Adopted the similar one used in the ECPP -! for the WRF-chem model written by Dick Easter -! -! Minghuai Wang, 2009-11 -!------------------------------------------------------------------ - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_abortutils, only: endrun - - implicit none - - public parampollu_tdx_cldchem - -contains - -!----------------------------------------------------------------------- - -subroutine parampollu_tdx_cldchem( & - ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & - itstep_hybrid, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - chem_sub_new, & - del_chem_clm_cldchem, del_chem_clm_rename, del_cldchem3d, del_rename3d, & - aqso4_h2o2, aqso4_o3, xphlwc3d, & - ardz_cen_old, ardz_cen_new, rhodz_cen, & - acen_tavg_use, acen_prec_use, & - rh_sub2, qcloud_sub2, qlsink_sub2, & - precr_sub2, precs_sub2, & - chem_bar_iccfactor, activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol,pbuf ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_tdx_cldchem does cloud chemistry -! for one main-integ time sub-step -! -! incoming chem_sub_new holds current sub-class mixing ratios -! outgoing chem_sub_new holds updated sub-class mixing ratios -! -! In the beginning of the subroutine, the vertical coordinate (from bottom to top in ECPP) -! is converted into the one used in CAM: from the top to the bottom. And at the end of the -! subroutine, the vertical coordinate is converted back. -! -!----------------------------------------------------------------------- - - use module_data_ecpp1, only: p_qv, p_qc - - use module_data_radm2, only: epsilc - - use module_data_mosaic_asect, only: ai_phase, cw_phase, & - massptr_aer, maxd_asize, maxd_atype, & - ncomp_aer, nphase_aer, nsize_aer, ntype_aer, numptr_aer - - use module_data_ecpp1 - - use mo_setsox, only : setsox - use mo_mass_xforms, only : mmr2vmr, vmr2mmr - use modal_aero_rename, only : modal_aero_rename_sub - use modal_aero_data, only : ntot_amode - use physconst, only: gravit - use ppgrid, only: pcols, pver - use time_manager, only: get_nstep - use mo_mean_mass, only: set_mean_mass - use chem_mods, only: gas_pcnst, nfs, indexm - use mo_setinv, only : setinv - use constituents, only: pcnst - use mo_gas_phase_chemdr, only: map2chm - use chemistry, only: imozart - use physics_buffer, only: physics_buffer_desc - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message - -! arguments - integer, intent(in) :: & - ktau, ktau_pp, itstep_sub, & - it, jt, kts, ktebnd, ktecen, & - itstep_hybrid -! ktau - time step number -! ktau_pp - time step number for "parameterized pollutants" calculations -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) - - real(r8), intent(in) :: dtstep, dtstep_sub -! dtstep - main model time step (s) -! dtstep_sub - sub time step (s) currently used in ecpp main-integ routine - - real(r8), intent(in), dimension( kts:ktecen ) :: & - tcen_bar, pcen_bar, rhocen_bar, dzcen - real(r8), intent(in), dimension( kts:ktebnd ) :: & - rhobnd_bar, wbnd_bar, zbnd -! tcen_bar - temperature (K) at layer centers -! rhocen_bar, rhobnd_bar - dry air density (kg/m^3) at layer centers and boundaries -! pcen_bar - air pressure (Pa) at layer centers -! wbnd_bar - vertical velocity (m/s) at layer boundaries -! zbnd - elevation (m) at layer boundaries -! dzcen - layer thicknesses (m) - - real(r8), intent(in), dimension( kts:ktecen, 1:num_chem_ecpp ) :: & - chem_bar -! chem_bar - mixing ratios of trace gase (ppm) and aerosol species -! (ug/kg for mass species, #/kg for number species) - - integer, intent(in) :: ncls_ecpp, ncls_use - - integer, intent(in), dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use - - real(r8), intent(inout), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_new - - real(r8), intent(inout), dimension( 1:num_chem_ecpp ) :: & - del_chem_clm_cldchem - - real(r8), intent(inout), dimension( 1:num_chem_ecpp ) :: & - del_chem_clm_rename - - real(r8), intent(inout), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:num_chem_ecpp ) :: & - del_cldchem3d ! 3D change from aqueous chemistry - - real(r8), intent(inout), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:num_chem_ecpp ) :: & - del_rename3d ! 3D change from modal merging - - real(r8), intent(inout) :: aqso4_h2o2, & ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - aqso4_o3 ! SO4 aqueous phase chemistry due to O3 (kg/m2) - - real(r8), intent(inout), dimension(kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2) :: & - xphlwc3d ! pH value multiplied by lwc - - - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - ardz_cen_old, ardz_cen_new, acen_tavg_use, acen_prec_use - - real(r8), intent(inout), dimension( kts:ktecen ) :: rhodz_cen - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - rh_sub2, qcloud_sub2, qlsink_sub2, precr_sub2, precs_sub2 - - real(r8), intent(in), dimension( 1:2, num_chem_ecpp ) :: chem_bar_iccfactor - - integer, intent(in) :: activate_onoff_use - - integer, intent(in), dimension( 1:num_chem_ecpp ) :: & - iphase_of_aerosol, isize_of_aerosol, itype_of_aerosol, & - inmw_of_aerosol, laicwpair_of_aerosol - type(physics_buffer_desc), pointer :: pbuf(:) - - - -! local variables - - integer :: icc, iccpp, iccpp1, iccpp2, ipp - integer :: jcls - integer :: k, kk, l, km - integer :: numgas_aqfrac - integer :: p1st - integer :: m, n - integer :: im, in, lnumcw - integer :: ncol - integer :: empty_troplev(pcols) = -99 ! This variable is not used in the modal_aero_rename_no_acc_crs_sub (which is - ! called witin modal_aero_rename_sub) when moal_accum_coars_exch is false - - real(r8) :: tmpa, tmpa1, tmpa2, tmpb1, tmpb2, tmpq, tmpq1, tmpq2, tmpx, tmpx2, tmpy, tmpy2 - real(r8) :: dtmpchem - - real(r8), parameter :: qcldwtr_cutoff = 1.0e-6_r8 - real(r8), parameter :: yph = 4.5_r8 ! in the MMF model, for ECPP, ph value is fixed at 4.5 - real(r8) :: dt_tmp - - real(r8), allocatable :: p_tmp(:,:,:), t_tmp(:,:,:), rho_tmp(:,:,:), & - alt_tmp(:,:,:), cldfra_tmp(:,:,:), & - qlsink_tmp(:,:,:), precr_tmp(:,:,:), & - precs_tmp(:,:,:), precg_tmp(:,:,:), preci_tmp(:,:,:) - real(r8), allocatable :: chem_tmpa(:,:,:,:), chem_tmpb(:,:,:,:), chem_tmpc(:,:,:,:) - - real(r8), allocatable :: cwat_tmp(:,:,:) - real(r8), allocatable :: pdel_tmp(:,:,:) - - real(r8), allocatable :: aqso4_tmp(:,:) - real(r8), allocatable :: aqh2so4_tmp(:,:) - real(r8), allocatable :: aqso4_h2o2_tmp(:) - real(r8), allocatable :: aqso4_o3_tmp(:) - real(r8), allocatable :: xphlwc_tmp(:,:) - real(r8), allocatable :: aqso4_h2o2_3dtmp(:,:) - real(r8), allocatable :: aqso4_o3_3dtmp(:,:) - - real(r8), allocatable :: mmr(:, :), vmr(:,:), mmrcw(:, :), vmrcw(:, :) - real(r8), allocatable :: vmr_3d(:,:,:), vmrcw_3d(:,:, :) - real(r8), allocatable :: vmr_sv1(:,:), vmrcw_sv1(:,:) - real(r8), allocatable :: mbar(:) - real(r8), allocatable :: mmr_3d(:, :, :), mmrcw_3d(:, :, :), mbar_3d(:, :) - real(r8), allocatable :: cldnum(:,:) - - real(r8) :: invariants_full(pcols, pver, nfs) - real(r8) :: t_full(pcols, pver) - real(r8) :: pmid_full(pcols, pver) - real(r8) :: h2ovmr_full(pcols, pver) - real(r8) :: vmr_full(pcols, pver, gas_pcnst) - - real(r8), allocatable :: qsrflx_full(:, :,:), qqcwsrflx_full(:, :,:) - integer :: nsrflx - integer :: nstep - integer :: jsrflx_rename - integer :: latndx_full(pcols, pver) - integer :: lonndx_full(pcols, pver) - real(r8) :: pdel_full(pcols, pver) - real(r8) :: dqdt(pver, gas_pcnst) - real(r8) :: dqdt_other(pver, gas_pcnst) - real(r8) :: dqqcwdt(pver, gas_pcnst) - real(r8) :: dqqcwdt_other(pver, gas_pcnst) - logical :: dotendrn(gas_pcnst) - logical :: dotendqqcwrn(gas_pcnst) - logical :: is_dorename_atik - logical :: dorename_atik(pver) - - p1st = param_first_ecpp - numgas_aqfrac = num_chem_ecpp - - nsrflx = 2 - jsrflx_rename = 2 - nstep = get_nstep() - - -! -! load arrays for interfacing with cloud chemistry subroutine -! -! use the wrfchem "i" index for the ecpp icc & ipp sub-class indices -! use the wrfchem "j" index for the ecpp jcls class index -! all the temporary real*4 arrays must be dimensioned kts:ktebnd -! - allocate ( p_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( t_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( rho_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( alt_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( cldfra_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( qlsink_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( precr_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( precs_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( precg_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( preci_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( cwat_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( pdel_tmp( 1:4,kts:ktecen,1:ncls_use) ) - allocate ( chem_tmpa( 1:4,kts:ktecen,1:ncls_use,1:num_chem_ecpp) ) - allocate ( chem_tmpb( 1:4,kts:ktecen,1:ncls_use,1:num_chem_ecpp) ) - allocate ( chem_tmpc( 1:4,kts:ktecen,1:ncls_use,1:num_chem_ecpp) ) - - allocate ( mmr(kts:ktecen,1:gas_pcnst) ) - allocate ( vmr(kts:ktecen,1:gas_pcnst) ) - allocate ( mmrcw(kts:ktecen,1:gas_pcnst) ) - allocate ( vmrcw(kts:ktecen,1:gas_pcnst) ) - allocate ( vmr_sv1(kts:ktecen,1:gas_pcnst) ) - allocate ( vmrcw_sv1(kts:ktecen,1:gas_pcnst) ) - allocate ( mbar(kts:ktecen) ) - allocate ( cldnum(1,kts:ktecen) ) - allocate ( vmr_3d(1,kts:ktecen,1:gas_pcnst) ) - allocate ( vmrcw_3d(1,kts:ktecen,1:gas_pcnst) ) - allocate ( mmr_3d(1, kts:ktecen,1:gas_pcnst) ) - allocate ( mmrcw_3d(1, kts:ktecen, 1:gas_pcnst) ) - allocate ( mbar_3d(1, kts:ktecen) ) - - allocate (aqso4_tmp(1, ntot_amode)) - allocate (aqh2so4_tmp(1, ntot_amode)) - allocate (aqso4_h2o2_tmp(1)) - allocate (aqso4_o3_tmp(1)) - allocate (xphlwc_tmp(1,kts:ktecen)) - allocate (aqso4_h2o2_3dtmp(1,kts:ktecen)) - allocate (aqso4_o3_3dtmp(1,kts:ktecen)) - - allocate (qsrflx_full(pcols, gas_pcnst, nsrflx)) - allocate (qqcwsrflx_full(pcols, gas_pcnst, nsrflx)) - -! chem_tmpa, chem_tmpb and chem_tmpc start from bottom to top, just as chem_sub_new -! But mmr, mmrcw are reordered, starts from top to the bottom for aqueous chemistry at CAM. - do l = 1, num_chem_ecpp - do jcls = 1, ncls_use - do kk = kts, ktecen - k = min( kk, ktecen ) - do icc = 1, 2 - do ipp = 1, 2 - iccpp = 2*(icc-1) + ipp - chem_tmpa(iccpp,k,jcls,l) = chem_sub_new(k,icc,jcls,l) - end do - end do - end do - end do - end do - chem_tmpb(:,:,:,:) = chem_tmpa(:,:,:,:) - chem_tmpc(:,:,:,:) = chem_tmpa(:,:,:,:) - -! -! prepare fields for aqueous chemistry at CAM. - do kk = kts, ktecen - k = min( kk, ktecen ) -! -! vertical coordinate is from bottom to top in the ECPP, -! so convert it to from top to the bottom for aqueous chemistry at CAM. - km = ktecen-k+1 - p_tmp(1:4,k,1:ncls_use) = pcen_bar(km) - t_tmp(1:4,k,1:ncls_use) = tcen_bar(km) - rho_tmp(1:4,k,1:ncls_use) = rhocen_bar(km) - alt_tmp(1:4,k,1:ncls_use) = 1.0_r8/rhocen_bar(km) - pdel_tmp(1:4,k,1:ncls_use) = rhocen_bar(km)*dzcen(km)*gravit - end do - - cldfra_tmp(:,:,:) = 0.0_r8 - qlsink_tmp(:,:,:) = 0.0_r8 - precr_tmp(:,:,:) = 0.0_r8 - precg_tmp(:,:,:) = 0.0_r8 - precs_tmp(:,:,:) = 0.0_r8 - preci_tmp(:,:,:) = 0.0_r8 - cwat_tmp(:,:,:) = 0.0_r8 - - do jcls = 1, ncls_use - do k = kts, ktecen -! -! vertical coordinate is from bottom to top in the ECPP, -! so convert it to from top to the bottom for aqueous chemistry at CAM. - km = ktecen-k+1 - do icc = 1, 2 - do ipp = 1, 2 - iccpp = 2*(icc-1) + ipp - if (ipp == 1) then - tmpa = acen_tavg_use(km,icc,jcls) - acen_prec_use(km,icc,jcls) - else - tmpa = acen_prec_use(km,icc,jcls) - end if - tmpq = qcloud_sub2(km,icc,jcls,ipp) - if ((tmpa > afrac_cut_0p5) .and. (tmpq > qcldwtr_cutoff)) then - qlsink_tmp(iccpp,k,jcls) = qlsink_sub2(km,icc,jcls,ipp) - cwat_tmp(iccpp,k,jcls) = tmpq - end if - - if (icc == 2) then - if(tmpa > afrac_cut_0p5) then - cldfra_tmp(iccpp,k,jcls) = 1.0_r8 - end if - end if - - precr_tmp(iccpp,k,jcls) = precr_sub2(km,icc,jcls,ipp) - precs_tmp(iccpp,k,jcls) = precs_sub2(km,icc,jcls,ipp) - end do - end do - end do - end do - - - dt_tmp = dtstep_sub - - if (cldchem_onoff_ecpp > 0) then - - do jcls = 1, ncls_use - do icc = 2, 2 ! In clear sky, cloud chemistry and renaming are not called. - do ipp = 1, 2 - iccpp = 2*(icc-1) + ipp - ncol = 1 - - !---------------------------------------------------------------------- - ! calculate cldnum from cloud borne aerosol particles - ! Vertical coordinate is from bottom to top in the ECPP for chem_tempb, - ! so convert it to from top to the bottom for aqueous chemistry at CAM. - !---------------------------------------------------------------------- - cldnum(1,:) = 0.0_r8 - do in=1, ntype_aer - do im=1, nsize_aer(in) - lnumcw = numptr_aer(im, in, cw_phase) - do k=kts, ktecen - km=ktecen-k+1 - cldnum(1,k) = cldnum(1,k)+chem_tmpb(iccpp,km,jcls,lnumcw) - end do - end do - end do - - !----------------------------------------------------------------------- - ! ... map incoming concentrations to working array - ! Vertical coordinate is from bottom to top in the ECPP for chem_tempb, - ! so convert it to from top to the bottom for aqueous chemistry at CAM. - !----------------------------------------------------------------------- - mmr(:, :) = 0.0_r8 - mmrcw(:, :) = 0.0_r8 - do m = 1,pcnst - n = map2chm(m) - if( n > 0 ) then - do k = kts, ktecen - km = ktecen-k+1 - mmr(k,n) = chem_tmpb(iccpp,km,jcls,m) - mmrcw(k,n) = chem_tmpb(iccpp,km,jcls,m+pcnst) - end do - end if - end do - - !----------------------------------------------------------------------- - ! ... Set atmosphere mean mass - !----------------------------------------------------------------------- - mmr_3d(1, :, :) = mmr(:, :) - call set_mean_mass( ncol, mmr_3d, mbar_3d ) - mbar(:) = mbar_3d(1, :) - - !----------------------------------------------------------------------- - ! ... Xform from mmr to vmr - !----------------------------------------------------------------------- - vmr_3d(1, :, :) = vmr(:, :) - mmr_3d(1, :, :) = mmr(:, :) - mmrcw_3d(1, :, :) = mmrcw(:, :) - vmrcw_3d(1, :, :) = vmrcw(:, :) - call mmr2vmr( mmr_3d, vmr_3d, mbar_3d, ncol ) - call mmr2vmr( mmrcw_3d, vmrcw_3d, mbar_3d, ncol ) - - vmr_sv1 = vmr_3d(1,:,:) - vmrcw_sv1 = vmrcw_3d(1,:,:) - - vmr(:,:) = vmr_3d(1,:,:) - vmrcw(:,:) = vmrcw_3d(1,:,:) - - !----------------------------------------------------------------------- - ! ... Set the "invariants" - !----------------------------------------------------------------------- - h2ovmr_full(:, :) = 0.0_r8 ! h2ommr is not used in CAM aqueous chemistry, so set it to zero here. - do kk = kts, ktecen - k = min( kk, ktecen) - t_full(:, k) = t_tmp(iccpp, k,jcls) - pmid_full(:, k) = p_tmp(iccpp, k, jcls) - do n=1, gas_pcnst - vmr_full(:, k, n) = vmr(k, n) - end do - end do - call setinv( invariants_full(:it,:,:), t_full, h2ovmr_full(:it,:), vmr_full(:it,:,:), pmid_full, it, jt, pbuf) ! jt=lchnk - - !-------------------------------------------------------------------------- - ! ... Aqueous chemistry - !-------------------------------------------------------------------------- - call setsox( ncol, & ! ncol - jt, & ! lchnk - imozart-1,& ! loffset - dt_tmp, & ! dtime - p_tmp(iccpp:iccpp, :, jcls), & ! press - pdel_tmp(iccpp:iccpp, :, jcls), & ! pdel - t_tmp(iccpp:iccpp, :, jcls), & ! tfld - mbar_3d, & ! mbar(1,:) - cwat_tmp(iccpp:iccpp, :, jcls), & ! lwc - cldfra_tmp(iccpp:iccpp, :, jcls), & ! cldfrc - cldnum, & ! cldnum - invariants_full(it:it,:,indexm), & ! xhnm - invariants_full(it:it,:,:), & ! invariants - vmrcw_3d, & ! qcw - vmr_3d, & ! qin - xphlwc_tmp, & - aqso4_tmp, & - aqh2so4_tmp, & - aqso4_h2o2_tmp, & - aqso4_o3_tmp, & - yph, & - aqso4_h2o2_3dtmp, & - aqso4_o3_3dtmp ) - - !----------------------------------------------------------------------- - ! ... Xform from vmr to mmr - !----------------------------------------------------------------------- - vmr(:,:) = vmr_3d(1,:,:) - vmrcw(:,:) = vmrcw_3d(1,:,:) - call vmr2mmr( vmr, mmr_3d, mbar, ncol ) - call vmr2mmr( vmrcw, mmrcw_3d, mbar, ncol ) - mmr(:, :) = mmr_3d(1, :, :) - mmrcw(:, :) = mmrcw_3d(1, :, :) - - !----------------------------------------------------------------------- - ! ... Form the tendencies - ! Vertical coordinate is from top to bottom in the aqueous chemistry at CAM, - ! so convert it to from bottom to the top in the ECPP for chem_tmpb. - !----------------------------------------------------------------------- - do m = 1,pcnst - n = map2chm(m) - if( n > 0 ) then - do k = kts, ktecen - km = ktecen-k+1 - chem_tmpb(iccpp, k,jcls,m) = mmr(km,n) - chem_tmpb(iccpp, k,jcls,m+pcnst) = mmrcw(km,n) - end do - end if - end do - - do k = kts, ktecen - km = ktecen-k+1 ! acen is defined in the ECPP (from bottom to top) - if (ipp == 1) then - tmpa = acen_tavg_use(k,icc,jcls) - acen_prec_use(k,icc,jcls) - else - tmpa = acen_prec_use(k,icc,jcls) - end if - if (tmpa > afrac_cut_0p5) then - aqso4_h2o2 = aqso4_h2o2+tmpa * aqso4_h2o2_3dtmp(1, km)*dt_tmp - aqso4_o3 = aqso4_o3 + tmpa * aqso4_o3_3dtmp(1, km)*dt_tmp - end if -! -! xphlwc_tmp is defined in CAM( top to bottom), and xphlwc3d is defined in ECPP (bottom to top) - xphlwc3d(k,icc,jcls,ipp) = xphlwc3d(k,icc,jcls,ipp) + xphlwc_tmp(1,km) * tmpa - - end do - -!----------------------------------------------------------------------------- -! ----- renaming: modal aerosol mode merging ------ -!----------------------------------------------------------------------------- - if(rename_onoff_ecpp > 0) then - do kk = kts, ktecen - k = min( kk, ktecen) - pdel_full(:, k) = p_tmp(iccpp, k, jcls) - end do - latndx_full(:,:) = 1 - lonndx_full(:,:) = 1 - qsrflx_full(:,:,:) = 0.0_r8 - qqcwsrflx_full(:,:,:) = 0.0_r8 - dotendrn(:) = .false. - dotendqqcwrn(:) = .false. - dorename_atik(:) = .true. - is_dorename_atik = .true. - dqdt (:,:) = 0.0_r8 - dqqcwdt(:,:) = 0.0_r8 - dqdt_other(:,:)=(vmr-vmr_sv1)/dt_tmp - dqqcwdt_other(:,:)=(vmrcw-vmrcw_sv1)/dt_tmp - - call modal_aero_rename_sub('ecpp_modal_cloudchem', jt, & - ncol, nstep, & - imozart-1, dt_tmp, & - pdel_full, empty_troplev, & - dotendrn, vmr, & - dqdt, dqdt_other, & - dotendqqcwrn, vmrcw, & - dqqcwdt, dqqcwdt_other, & - is_dorename_atik, dorename_atik, & - jsrflx_rename, nsrflx, & - qsrflx_full, qqcwsrflx_full ) - vmr = vmr + dqdt * dt_tmp - vmrcw = vmrcw + dqqcwdt * dt_tmp - - !----------------------------------------------------------------------- - ! ... Xform from vmr to mmr - !----------------------------------------------------------------------- - call vmr2mmr( vmr, mmr_3d, mbar, ncol ) - call vmr2mmr( vmrcw, mmrcw_3d, mbar, ncol ) - mmr(:, :) = mmr_3d(1, :, :) - mmrcw(:, :) = mmrcw_3d(1, :, :) - - !----------------------------------------------------------------------- - ! ... Form the tendencies - ! Vertical coordinate is from top to bottom in the aqueous chemistry at CAM, - ! so convert it to from bottom to the top in the ECPP for chem_tmpb. - !----------------------------------------------------------------------- - do m = 1,pcnst - n = map2chm(m) - if( n > 0 ) then - do k = kts, ktecen - km = ktecen-k+1 - chem_tmpc(iccpp, k,jcls,m) = mmr(km,n) - chem_tmpc(iccpp, k,jcls,m+pcnst) = mmrcw(km,n) - end do - end if - end do - - - end if ! (rename_onoff_ecpp > 0) - - end do - end do - end do - - do l = p1st, num_chem_ecpp - tmpx = 0.0_r8 - tmpx2 = 0.0_r8 - do k = kts, ktecen - tmpy = 0.0_r8 - tmpy2 = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - do ipp = 1, 2 - iccpp = 2*(icc-1) + ipp - if (ipp == 1) then - tmpa = acen_tavg_use(k,icc,jcls) - acen_prec_use(k,icc,jcls) - else - tmpa = acen_prec_use(k,icc,jcls) - end if - - if (tmpa > afrac_cut_0p5) then - tmpq = (chem_tmpb(iccpp,k,jcls,l) - chem_tmpa(iccpp,k,jcls,l)) - tmpy = tmpy + tmpa*tmpq - del_cldchem3d(k,icc,jcls,ipp,l)=del_cldchem3d(k,icc,jcls,ipp,l)+tmpa*tmpq - else - del_cldchem3d(k,icc,jcls,ipp,l)=del_cldchem3d(k,icc,jcls,ipp,l)+0.0_r8 - end if - - if(rename_onoff_ecpp > 0 ) then - if (tmpa > afrac_cut_0p5) then - tmpq = (chem_tmpc(iccpp,k,jcls,l) - chem_tmpb(iccpp,k,jcls,l)) - tmpy2 = tmpy2 + tmpa*tmpq - del_rename3d(k,icc,jcls,ipp,l)=del_rename3d(k,icc,jcls,ipp,l)+tmpa*tmpq - else - del_rename3d(k,icc,jcls,ipp,l)=del_rename3d(k,icc,jcls,ipp,l)+0.0_r8 - end if - end if ! (rename_onoff_ecpp > 0.) - - end do ! ipp - end do ! icc - end do ! jcls - tmpx = tmpx + tmpy*rhodz_cen(k) - if(rename_onoff_ecpp > 0 ) tmpx2 = tmpx2+tmpy2 * rhodz_cen(k) - end do ! k - - del_chem_clm_cldchem(l) = del_chem_clm_cldchem(l) + tmpx - if(rename_onoff_ecpp > 0 ) & - del_chem_clm_rename(l) = del_chem_clm_rename(l) + tmpx2 - end do ! l - - end if ! (cldchem_onoff_ecpp > 0) - - if ((cldchem_onoff_ecpp > 0)) then - - do l = p1st, num_chem_ecpp - do k = kts, ktecen - do jcls = 1, ncls_use - do icc = 1, 2 - tmpa1 = acen_tavg_use(k,icc,jcls) - acen_prec_use(k,icc,jcls) - tmpa2 = acen_prec_use(k,icc,jcls) - if ((tmpa1 <= afrac_cut_0p5) .and. (tmpa2 <= afrac_cut_0p5)) cycle - - iccpp1 = 2*(icc-1) + 1 - iccpp2 = 2*(icc-1) + 2 - - if(rename_onoff_ecpp > 0 ) then - if ((tmpa1 > afrac_cut_0p5) .and. (tmpa2 > afrac_cut_0p5)) then - tmpb1 = max( 0.0_r8, min( 1.0_r8, (tmpa1/(tmpa1+tmpa2)) ) ) - tmpb2 = 1.0_r8 - tmpb1 - tmpq1 = chem_tmpa(iccpp1,k,jcls,l)*tmpb1 & - + chem_tmpa(iccpp2,k,jcls,l)*tmpb2 - tmpq2 = chem_tmpc(iccpp1,k,jcls,l)*tmpb1 & - + chem_tmpc(iccpp2,k,jcls,l)*tmpb2 - else if (tmpa1 > afrac_cut_0p5) then - tmpq1 = chem_tmpa(iccpp1,k,jcls,l) - tmpq2 = chem_tmpc(iccpp1,k,jcls,l) - else - tmpq1 = chem_tmpa(iccpp2,k,jcls,l) - tmpq2 = chem_tmpc(iccpp2,k,jcls,l) - end if - else ! no renaming - if ((tmpa1 > afrac_cut_0p5) .and. (tmpa2 > afrac_cut_0p5)) then - tmpb1 = max( 0.0_r8, min( 1.0_r8, (tmpa1/(tmpa1+tmpa2)) ) ) - tmpb2 = 1.0_r8 - tmpb1 - tmpq1 = chem_tmpa(iccpp1,k,jcls,l)*tmpb1 & - + chem_tmpa(iccpp2,k,jcls,l)*tmpb2 - tmpq2 = chem_tmpb(iccpp1,k,jcls,l)*tmpb1 & - + chem_tmpb(iccpp2,k,jcls,l)*tmpb2 - else if (tmpa1 > afrac_cut_0p5) then - tmpq1 = chem_tmpa(iccpp1,k,jcls,l) - tmpq2 = chem_tmpb(iccpp1,k,jcls,l) - else - tmpq1 = chem_tmpa(iccpp2,k,jcls,l) - tmpq2 = chem_tmpb(iccpp2,k,jcls,l) - end if - end if ! (rename_onoff_ecpp > 0) - if (tmpq1 /= tmpq2) chem_sub_new(k,icc,jcls,l) = tmpq2 - - end do ! icc - end do ! jcls - end do ! k - end do ! l - - end if ! ((cldchem_onoff_ecpp > 0)) - - - deallocate ( p_tmp, t_tmp, rho_tmp, alt_tmp, & - cldfra_tmp, & - qlsink_tmp, & - precr_tmp, precs_tmp, precg_tmp, preci_tmp ) - deallocate ( chem_tmpa, chem_tmpb, chem_tmpc) - deallocate ( mmr, mmrcw, vmr, vmrcw, vmr_sv1, vmrcw_sv1, & - mbar, cldnum, mmr_3d, mmrcw_3d, mbar_3d, & - qsrflx_full, qqcwsrflx_full) - - deallocate ( cwat_tmp, pdel_tmp, vmr_3d, vmrcw_3d, & - aqso4_tmp, aqh2so4_tmp, aqso4_h2o2_tmp, & - aqso4_o3_tmp, xphlwc_tmp, aqso4_h2o2_3dtmp, & - aqso4_o3_3dtmp) - return - end subroutine parampollu_tdx_cldchem - -end module ecpp_modal_cloudchem diff --git a/src/physics/spcam/ecpp/ecpp_modal_wetscav.F90 b/src/physics/spcam/ecpp/ecpp_modal_wetscav.F90 deleted file mode 100644 index 862f45278c..0000000000 --- a/src/physics/spcam/ecpp/ecpp_modal_wetscav.F90 +++ /dev/null @@ -1,1898 +0,0 @@ -module ecpp_modal_wetscav - -!----------------------------------------------------------------- -! Module interface for cloud chemistry used in the ECPP treatment -! in the MMF model -! Adopted the similar one used in the ECPP -! for the WRF-chem model written by Dick Easter -! -! Minghuai Wang, 2009-11 -!------------------------------------------------------------------ - use shr_kind_mod, only: r8 => shr_kind_r8 - use perf_mod - use cam_abortutils, only: endrun - - implicit none - - public parampollu_tdx_wetscav_2 - -contains - -!----------------------------------------------------------------------- - subroutine parampollu_tdx_wetscav_2( & - ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & - itstep_hybrid, & - idiagaa_ecpp, ldiagaa_ecpp, idiagbb_wetscav, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & -! rhobnd_bar, zbnd, wbnd_bar, & not needed ? -! chem_bar, & not needed ? -! ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & -! kdraft_bot_use, kdraft_top_use, & not needed ? -! mtype_updnenv_use, & not needed ? - chem_sub_new, & - del_chem_clm_wetscav, & - del_wetscav3d, del_wetresu3d, & -! ardz_cen_old, ardz_cen_new, & not needed ? - rhodz_cen, & - acen_tavg_use, acen_prec_use, & - rh_sub2, qcloud_sub2, qlsink_sub2, & - precr_sub2, precs_sub2, & -! chem_bar_iccfactor, & not needed ? - activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_tdx_wetscav_2 does wet scavenging of aerosols only -! for one main-integ time sub-step -! -! incoming chem_sub_new holds current sub-class mixing ratios -! outgoing chem_sub_new holds updated sub-class mixing ratios -! -!----------------------------------------------------------------------- - -! use module_state_description, only: p_qv, p_qc - -! use module_data_radm2, only: epsilc - -! use module_data_mosaic_asect, only: ai_phase, cw_phase, & -! massptr_aer, maxd_asize, maxd_atype, & -! ncomp_aer, nphase_aer, nsize_aer, ntype_aer, numptr_aer, & -! waterptr_aer - use module_data_mosaic_asect, only: & - ai_phase, cw_phase, & - massptr_aer, maxd_asize, maxd_atype, & - ncomp_aer, nphase_aer, nsize_aer, ntype_aer, numptr_aer - - use module_data_ecpp1 - -! use module_ecpp_hoststuff, only: config_flags_ecpp - -! use module_mosaic_wetscav, only: wetscav_cbmz_mosaic - -! use module_ecpp_util, only: ecpp_error_fatal, ecpp_message, & -! parampollu_1clm_set_opts - - implicit none - -! arguments - integer, intent(in) :: & - ktau, ktau_pp, itstep_sub, & - it, jt, kts, ktebnd, ktecen - integer, intent(in) :: itstep_hybrid -! ktau - time step number -! ktau_pp - time step number for "parameterized pollutants" calculations -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199), & - idiagbb_wetscav - - real(r8), intent(in) :: dtstep, dtstep_sub -! dtstep - main model time step (s) -! dtstep_sub - sub time step (s) currently used in ecpp main-integ routine - - real(r8), intent(in), dimension( kts:ktecen ) :: & - tcen_bar, pcen_bar, rhocen_bar, dzcen -! real(r8), intent(in), dimension( kts:ktebnd ) :: & -! rhobnd_bar, wbnd_bar, zbnd -! tcen_bar - temperature (K) at layer centers -! rhocen_bar, rhobnd_bar - dry air density (kg/m^3) at layer centers and boundaries -! pcen_bar - air pressure (Pa) at layer centers -! wbnd_bar - vertical velocity (m/s) at layer boundaries -! zbnd - elevation (m) at layer boundaries -! dzcen - layer thicknesses (m) - -! real(r8), intent(in), dimension( kts:ktecen, 1:num_chem_ecpp ) :: & -! chem_bar -! chem_bar - mixing ratios of trace gase (ppm) and aerosol species -! (ug/kg for mass species, #/kg for number species) - - integer, intent(in) :: ncls_use -! integer, intent(in) :: ncls_ecpp - -! integer, intent(in), dimension( 1:2, 1:maxcls_ecpp ) :: & -! kdraft_bot_use, kdraft_top_use, & -! mtype_updnenv_use - - real(r8), intent(inout), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_new - - real(r8), intent(inout), dimension( 1:num_chem_ecpp ) :: & - del_chem_clm_wetscav -! del_chem_clm_wetscav(l) = & -! sum( rhodz_cen(kts:ktecen) * ( del_wetscav3d(kts:ktecen,1:2,1:ncls_use,1:2,l) & -! + del_wetresu3d(kts:ktecen,1:2,1:ncls_use,1:2,l) ) ) - - real(r8), intent(inout), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:num_chem_ecpp ) :: & - del_wetscav3d, del_wetresu3d -! del_wetscav3d = acen * (change to chem_sub due to uptake by precip) -! the change for the current time sub-step is added to this array, so the array holds -! the cummulative change over multiple time steps -! this is always negative (or zero), and units are (kg/m^2) -! del_wetresu3d = acen * (change to chem_sub due to resuspension from precip evaporation) -! this is always positive (or zero), and units are (kg/m^2) -! -! units for del_wetscav/resu3d will be (kg/m^2) or (#/m^2) in cam, -! where all tracer mixing ratios are (kg/kgair) -! in wrfchem, units are (ug/m^2) and (#/m^2) for aerosol mass and number -! for gases, they are (mg/m^2) AFTER one applies a molecular weight ratio -! the important thing is that their sum is always equal to the column burden change, -! where column burden = sum_over_k[ (mixing ratio)*(air density, kg/m^3)*(dz, m) ] - - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tavg_use, acen_prec_use -! ardz_cen_old, ardz_cen_new, - - real(r8), intent(inout), dimension( kts:ktecen ) :: rhodz_cen - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - rh_sub2, qcloud_sub2, qlsink_sub2, precr_sub2, precs_sub2 - -! real(r8), intent(in), dimension( 1:2, num_chem_ecpp ) :: chem_bar_iccfactor - - integer, intent(in) :: activate_onoff_use - - integer, intent(in), dimension( 1:num_chem_ecpp ) :: & - iphase_of_aerosol, isize_of_aerosol, itype_of_aerosol, & - inmw_of_aerosol, laicwpair_of_aerosol - - - -! local variables - integer, parameter :: nwdt = 1 - - integer :: icc, icc_g, icc_l, iphase, ipp, ipp_l, ipp_g - integer :: jcls, jcls_g, jcls_l - integer :: k, kk, km1, kp1 - integer :: l, ll, lun142 - integer :: lgas_scav(1:num_chem_ecpp) - integer :: m, mwdt - integer :: n - integer, parameter :: maxgas_scav = 4 - integer :: ngas_scav - integer :: p1st - integer :: inwdt - - logical :: skip_aer_resu, skip_gas_scav - logical, dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - is_active, is_precp, is_ptgain, is_ptloss, is_rain -! is_active = .true. if sub-subarea has acen > afrac_cut_0p5 -! is_precp = .true. if sub-subarea has prtb > prsmall -! is_ptgain = .true. prtb increases from k+1 to k for the sub-subarea -! is_ptloss = .true. prtb decreases from k+1 to k for the sub-subarea - logical, dimension( 1:2, 1:maxcls_ecpp, 1:2 ) :: & - ltmp_aa3d - - real(r8) :: delprtb_gtot, delprtb_ltot, delprtb_xtot - real(r8) :: dt_scav - real(r8) :: flxdt, flxdt_kp1 - real(r8) :: qgcx, qgcx_bgn - real(r8) :: frac_scav - real(r8) :: prsmall - real(r8) :: rate_scav - real(r8) :: scavcoef - real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpq - real(r8) :: tmpx, tmpx2, tmpy, tmpy2 - real(r8) :: tmpa1, tmpa2, tmpb1, tmpb2, tmpq1, tmpq2 - real(r8) :: tmp_ardzcen, tmpvol - - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:num_chem_ecpp ) :: & - chem_tmpa, chem_tmpb - real(r8), dimension( 1:num_chem_ecpp ) :: curdel_chem_clm_wetscav - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:max_wetdiagtype, 1:num_chem_ecpp ) :: & - delchem_wetscav, delchem_wetresu -! delchem_wetscav = [ change to chem from wet scavenging over dt_scav ] ] * acen_tmp * rhodz_cen -! so units are (kg/m^2) -! delchem_wetresu = similar, but change from resuspension (due to precip evap) - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:max_wetdiagtype, 1:num_chem_ecpp ) :: & - chem_prflxdt, chem_prflxdt_xfer -! chem_prflxdt = [ downwards flux of precip-borne-tracers (kg/m^2/s) for subarea -! if it were spread over the entire host-code grid cell area ] * dt_scav -! so units are (kg/m^2) -! chem_prflxdt_xfer = net transfer of chem_prflxdt into subarea from other subareas - - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: acen_tmp -! acen_tmp = fractional at layer centers for all 2 X 3 X 2 sub-subareas - real(r8), dimension( kts:ktebnd, 1:2, 1:maxcls_ecpp, 1:2 ) :: prra, prsa, prta, prtb -! prta = total (liquid + solid) precip rate (kg/m^2/s) within the subarea -! prra, prsa = liquid, solid precip rate (kg/m^2/s) within the subarea -! prtb = prta*acen_tmp = subarea precip rate -! if it were spread over the entire host-code grid cell area - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - delprtb, delprtb_g, delprtb_l -! depprtb = change in prtb from k+1 to k (kg/m^2/s) -! depprtb_g = increase in prtb from k+1 to k -! depprtb_l = abs( decrease in prtb from k+1 to k ) - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: frac_evap_prtb - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, & - 1:2, 1:maxcls_ecpp, 1:2 ) :: frac_xfer_prtb - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, & - 1:2, 1:maxcls_ecpp, 1:2 ) :: fxaa_evap_prtb -! frac_evap_prtb = fraction of precip (and precip-borne aerosols) entering the -! top of a subarea that is evaporated/resuspended -! frac_xfer_prtb = fraction of precip (and precip-borne aerosols) entering the -! top of a subarea that is transferred to another subarea -! (the first set of icc,jcls,ipp indices are the "xfer from" subarea) -! (the second set of icc,jcls,ipp indices are the "xfer to " subarea) - - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:maxd_asize, 1:maxd_atype ) :: & - scavcoef_num, scavcoef_vol -! scavcoef_vol = below-cloud scavenging coeficient for volume (1/mm) -! scavcoef_num = below-cloud scavenging coeficient for number (1/mm) -! when precip rate = xxx kg/m2/s == xxx mm/s, the scavenging rate (1/s) = scavcoef*xxx - - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, maxgas_scav ) :: & - gasscav_aa, gasscav_bb - - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - gasscav_cc - - - call t_startf('ecpp_wetscav_init') -! write(*,'(a)') 'wetscav_2 doing part 1 stuff' - - lun142 = -1 - if (idiagaa_ecpp(142) > 0) lun142 = ldiagaa_ecpp(142) - if (idiagbb_wetscav <= 0) lun142 = -1 - - p1st = param_first_ecpp - dt_scav = dtstep_sub - - mwdt = 1 - - skip_gas_scav = .false. ! flag for gas scavenging on/off - if (wetscav_onoff_ecpp < 400) skip_gas_scav = .true. - skip_aer_resu = .false. ! flag for aerosol resuspension on/off - if (wetscav_onoff_ecpp == 310) skip_aer_resu = .true. - if (wetscav_onoff_ecpp == 410) skip_aer_resu = .true. - -! load chem_tmpa array - chem_tmpa = 0.0_r8 - do l = p1st, num_chem_ecpp - do jcls = 1, ncls_use - do icc = 1, 2 - do k = kts, ktecen - chem_tmpa(k,icc,jcls,1:2,l) = chem_sub_new(k,icc,jcls,l) - end do - end do - end do - end do - chem_tmpb(:,:,:,:,:) = chem_tmpa(:,:,:,:,:) - - curdel_chem_clm_wetscav(:) = 0.0_r8 - delchem_wetscav(:,:,:,:,:,:) = 0.0_r8 - delchem_wetresu(:,:,:,:,:,:) = 0.0_r8 - chem_prflxdt(:,:,:,:,:,:) = 0.0_r8 - chem_prflxdt_xfer(:,:,:,:,:,:) = 0.0_r8 - - -! precip rates -- 1.0 kgwtr/m^2/s = 1.0e-3 m3wtr/m^2/s = 1.0e-3 m/s -! 7.06e-5 kg/m^2/s = 7.06e-8 m/s = 0.01 inch/h -! 1.00e-7 kg/m^2/s = 1.00e-10 m/s = (0.01 inch/h) * 0.0014 is a very small precip rate! - prsmall = 1.0e-7_r8 - -! load precip rates for each icc,jcls,ipp subarea - prta(:,:,:,:) = 0.0_r8 - prtb(:,:,:,:) = 0.0_r8 - prra(:,:,:,:) = 0.0_r8 - prsa(:,:,:,:) = 0.0_r8 - acen_tmp(:,:,:,:) = 0.0_r8 - - is_active(:,:,:,:) = .false. - is_precp(:,:,:,:) = .false. - is_ptgain(:,:,:,:) = .false. - is_ptloss(:,:,:,:) = .false. - is_rain(:,:,:,:) = .false. - - do jcls = 1, ncls_use - do icc = 1, 2 - do k = kts, ktecen - tmpa = max( 0.0_r8, acen_tavg_use(k,icc,jcls) ) - tmpb = max( 0.0_r8, acen_prec_use(k,icc,jcls) ) - tmpb = min( tmpa, tmpb ) - - if (tmpa <= afrac_cut_0p5) then ! both ipp=1&2 have near-zero area - continue - else if (tmpb <= afrac_cut_0p5) then ! ipp=2 has near-zero area - is_active(k,icc,jcls,1) = .true. - acen_tmp(k,icc,jcls,1) = tmpa - prta(k,icc,jcls,1) = precr_sub2(k,icc,jcls,1) + precs_sub2(k,icc,jcls,1) - prtb(k,icc,jcls,1) = prta(k,icc,jcls,1)*acen_tmp(k,icc,jcls,1) - else if (tmpa-tmpb <= afrac_cut_0p5) then ! ipp=1 has near-zero area - is_active(k,icc,jcls,2) = .true. - acen_tmp(k,icc,jcls,2) = tmpb - prta(k,icc,jcls,2) = precr_sub2(k,icc,jcls,2) + precs_sub2(k,icc,jcls,2) - prtb(k,icc,jcls,2) = prta(k,icc,jcls,2)*acen_tmp(k,icc,jcls,2) - else ! both ipp=1&2 have areas > threshold - is_active(k,icc,jcls,1) = .true. - acen_tmp(k,icc,jcls,1) = tmpa-tmpb - prta(k,icc,jcls,1) = precr_sub2(k,icc,jcls,1) + precs_sub2(k,icc,jcls,1) - prtb(k,icc,jcls,1) = prta(k,icc,jcls,1)*acen_tmp(k,icc,jcls,1) - is_active(k,icc,jcls,2) = .true. - acen_tmp(k,icc,jcls,2) = tmpb - prta(k,icc,jcls,2) = precr_sub2(k,icc,jcls,2) + precs_sub2(k,icc,jcls,2) - prtb(k,icc,jcls,2) = prta(k,icc,jcls,2)*acen_tmp(k,icc,jcls,2) - end if - - do ipp = 1, 2 - if ( is_active(k,icc,jcls,ipp) ) then - prtb(k,icc,jcls,ipp) = prta(k,icc,jcls,ipp)*acen_tmp(k,icc,jcls,ipp) - if (prtb(k,icc,jcls,ipp) > prsmall) then - is_precp(k,icc,jcls,ipp) = .true. - prsa(k,icc,jcls,ipp) = precs_sub2(k,icc,jcls,ipp) - if (precr_sub2(k,icc,jcls,ipp)*acen_tmp(k,icc,jcls,ipp) > prsmall) then - prra(k,icc,jcls,ipp) = precr_sub2(k,icc,jcls,ipp) - is_rain(k,icc,jcls,ipp) = .true. - end if - else - prta(k,icc,jcls,ipp) = 0.0_r8 - prtb(k,icc,jcls,ipp) = 0.0_r8 - end if - end if - end do - end do - end do - end do - call t_stopf('ecpp_wetscav_init') - - -! -! calculate the fractions of precip (and precip-borne aerosols) -! entering the top of a subarea that are either -! > evaporated/resuspended or -! > transferred to another subarea -! - call t_startf('ecpp_wetscav_precip_evap') - call wetscav_2_precip_evap_xfer( & - ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & - idiagaa_ecpp, ldiagaa_ecpp, idiagbb_wetscav, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - is_active, is_precp, is_ptgain, is_ptloss, & - acen_tmp, prtb, frac_evap_prtb, frac_xfer_prtb, & - fxaa_evap_prtb ) - call t_stopf('ecpp_wetscav_precip_evap') - - -! -! calculate below-cloud scavenging coeficients for interstitial aerosols -! - call t_startf('ecpp_wetscav_bcscav') - call wetscav_2_bcscavcoef( & - ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & - idiagaa_ecpp, ldiagaa_ecpp, idiagbb_wetscav, & - tcen_bar, pcen_bar, rhocen_bar, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - rh_sub2, & - is_active, is_precp, & - chem_tmpa, scavcoef_num, scavcoef_vol ) - call t_stopf('ecpp_wetscav_bcscav') - - -! -! calculate stuff for below-cloud gas scavenging -! - call t_startf('ecpp_wetscav_gascav') - call wetscav_2_gasscav( & - ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & - dt_scav, & - idiagaa_ecpp, ldiagaa_ecpp, idiagbb_wetscav, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - is_active, is_precp, is_rain, & - maxgas_scav, ngas_scav, lgas_scav, & - acen_tmp, prra, & - qcloud_sub2, qlsink_sub2, & - gasscav_aa, gasscav_bb, gasscav_cc ) - call t_stopf('ecpp_wetscav_gascav') - - -! -! -! now calculate -! in-cloud & below-cloud aerosol wet removal -! below-cloud resuspension from evaporating precip -! -! - call t_startf('ecpp_wetscav_main') -wetscav_main_kloop_aa: & - do k = ktecen, kts, -1 - - -! set precip-borne_flux to that of layer above - if (k < ktecen) then - chem_prflxdt(k,:,:,:,:,:) = chem_prflxdt(k+1,:,:,:,:,:) - end if - if (wetscav_onoff_ecpp < 200) cycle wetscav_main_kloop_aa - - -! -! do transfer of precip-borne tracers between subareas -! and resuspension from evaporation -! - if (k < ktecen) then -! loop over the "losing" subareas - do jcls_l = 1, ncls_use - do ipp_l = 1, 2 - do icc_l = 1, 2 - if ( .not. is_ptloss(k,icc_l,jcls_l,ipp_l) ) cycle - -! loop over the "gaining" subareas, -! transferring chem_prflxdt from losing to gaining subarea - do jcls_g = 1, ncls_use - do ipp_g = 1, 2 - do icc_g = 1, 2 - if ( .not. is_ptgain(k,icc_g,jcls_g,ipp_g) ) cycle - tmpa = frac_xfer_prtb(k,icc_l,jcls_l,ipp_l, icc_g,jcls_g,ipp_g) - if (tmpa <= 0.0_r8) cycle - do l = p1st, num_chem_ecpp - if ( skip_gas_scav .and. (inmw_of_aerosol(l) <= 0)) cycle - tmpb = chem_prflxdt(k+1,icc_l,jcls_l,ipp_l,mwdt,l)*tmpa - chem_prflxdt(k ,icc_g,jcls_g,ipp_g,mwdt,l) = & - chem_prflxdt(k ,icc_g,jcls_g,ipp_g,mwdt,l) + tmpb - chem_prflxdt(k ,icc_l,jcls_l,ipp_l,mwdt,l) = & - chem_prflxdt(k ,icc_l,jcls_l,ipp_l,mwdt,l) - tmpb - - chem_prflxdt_xfer(k ,icc_g,jcls_g,ipp_g,mwdt,l) = & - chem_prflxdt_xfer(k ,icc_g,jcls_g,ipp_g,mwdt,l) + tmpb - chem_prflxdt_xfer(k ,icc_l,jcls_l,ipp_l,mwdt,l) = & - chem_prflxdt_xfer(k ,icc_l,jcls_l,ipp_l,mwdt,l) - tmpb - end do - end do ! icc_g - end do ! ipp_g - end do ! jcls_g - -! do resuspension from evaporation here - tmpa = frac_evap_prtb(k,icc_l,jcls_l,ipp_l) - if (tmpa <= 0.0_r8) cycle - - tmp_ardzcen = acen_tmp(k,icc_l,jcls_l,ipp_l)*rhodz_cen(k) - do l = p1st, num_chem_ecpp - if ( skip_gas_scav .and. (inmw_of_aerosol(l) <= 0)) cycle - if ( skip_aer_resu .and. (inmw_of_aerosol(l) > 0)) cycle - tmpd = chem_prflxdt(k+1,icc_l,jcls_l,ipp_l,mwdt,l)*tmpa - delchem_wetresu(k,icc_l,jcls_l,ipp_l,mwdt,l) = & - delchem_wetresu(k,icc_l,jcls_l,ipp_l,mwdt,l) + tmpd - chem_prflxdt(k,icc_l,jcls_l,ipp_l,mwdt,l) = & - chem_prflxdt(k,icc_l,jcls_l,ipp_l,mwdt,l) - tmpd - - if ( is_active(k,icc_l,jcls_l,ipp_l) ) then -! normally resuspend into (k,icc_l,jcls_l,ipp_l) - chem_tmpb(k,icc_l,jcls_l,ipp_l,l) = & - chem_tmpb(k,icc_l,jcls_l,ipp_l,l) + tmpd/tmp_ardzcen - else -! if (k,icc_l,jcls_l,ipp_l) is not active (acen_tmp ~= 0), then resuspend -! uniformly across all active subareas -! (tmpd/rhodz_cen(k)) is the delta(chem) spread over the entire grid area - do jcls_g = 1, ncls_use - do ipp_g = 1, 2 - do icc_g = 1, 2 - tmpf = fxaa_evap_prtb(k,icc_l,jcls_l,ipp_l, icc_g,jcls_g,ipp_g) - if (tmpf <= afrac_cut_0p5) cycle - chem_tmpb(k,icc_g,jcls_g,ipp_g,l) = & - chem_tmpb(k,icc_g,jcls_g,ipp_g,l) + tmpd/(tmpf*rhodz_cen(k)) - end do ! icc_g - end do ! ipp_g - end do ! jcls_g - end if - end do ! l - - end do ! icc_l - end do ! ipp_l - end do ! jcls_l - end if ! (k < kte_cen) - - -! -! do additional resuspension for gases -! currently gases are only in rain (none in solid precip), -! and the previous resuspension involves total precip -! if rain ~= zero in a subarea, then resuspend any rainborne gases -! - if ((k < ktecen) .and. ( .not. skip_gas_scav )) then - do jcls_l = 1, ncls_use - do ipp_l = 1, 2 - do icc_l = 1, 2 - if ( is_rain(k,icc_l,jcls_l,ipp_l) ) cycle - - tmp_ardzcen = acen_tmp(k,icc_l,jcls_l,ipp_l)*rhodz_cen(k) - if ( .not. is_active(k,icc_l,jcls_l,ipp_l) ) then - tmpf = 0.0_r8 - ltmp_aa3d(:,:,:) = .false. - do jcls_g = 1, ncls_use - do ipp_g = 1, 2 - do icc_g = 1, 2 - if ( .not. is_active(k,icc_g,jcls_g,ipp_g) ) cycle - if ((jcls_g == jcls_l) .and. & - (ipp_g == ipp_l) .and. (icc_g == icc_l)) cycle - tmpf = tmpf + acen_tmp(k,icc_g,jcls_g,ipp_g) - ltmp_aa3d(icc_g,jcls_g,ipp_g) = .true. - end do ! icc_g - end do ! ipp_g - end do ! jcls_g - end if - - do ll = 1, ngas_scav - l = lgas_scav(ll) - if ((l < p1st) .or. (l > num_chem_ecpp)) cycle - tmpd = chem_prflxdt(k,icc_l,jcls_l,ipp_l,mwdt,l) - if (tmpd <= 0.0_r8) cycle - - delchem_wetresu(k,icc_l,jcls_l,ipp_l,mwdt,l) = & - delchem_wetresu(k,icc_l,jcls_l,ipp_l,mwdt,l) + tmpd - chem_prflxdt(k,icc_l,jcls_l,ipp_l,mwdt,l) = 0.0_r8 - - if ( is_active(k,icc_l,jcls_l,ipp_l) ) then -! resuspend into (k,icc_l,jcls_l,ipp_l) - chem_tmpb(k,icc_l,jcls_l,ipp_l,l) = & - chem_tmpb(k,icc_l,jcls_l,ipp_l,l) + tmpd/tmp_ardzcen - else -! (k,icc_l,jcls_l,ipp_l) is not active, so resuspend across all active subareas - do jcls_g = 1, ncls_use - do ipp_g = 1, 2 - do icc_g = 1, 2 - if ( .not. ltmp_aa3d(icc_g,jcls_g,ipp_g) ) cycle - chem_tmpb(k,icc_g,jcls_g,ipp_g,l) = & - chem_tmpb(k,icc_g,jcls_g,ipp_g,l) + tmpd/rhodz_cen(k) - end do ! icc_g - end do ! ipp_g - end do ! jcls_g - end if - end do ! ll - - end do ! icc_l - end do ! ipp_l - end do ! jcls_l - end if ! ((k < ktecen) .and. ( .not. skip_gas_scav )) - - -! -! calc in-cloud scavenging of activated aerosols -! - do jcls = 1, ncls_use - do ipp = 1, 2 - do icc = 1, 2 -! cycle ! *** skip for testing - if ( .not. is_active(k,icc,jcls,ipp) ) cycle - if ( .not. is_precp( k,icc,jcls,ipp) ) cycle - - frac_scav = max( 0.0_r8, min( 1.0_r8, qlsink_sub2(k,icc,jcls,ipp)*dt_scav ) ) - tmp_ardzcen = acen_tmp(k,icc,jcls,ipp)*rhodz_cen(k) - - iphase = cw_phase - do n = 1, ntype_aer - do m = 1, nsize_aer(n) - do ll = 0, ncomp_aer(n) - if (ll == 0) then - l = numptr_aer(m,n,iphase) - else - l = massptr_aer(ll,m,n,iphase) - end if - if ((l < p1st) .or. (l > num_chem_ecpp)) cycle - - tmpa = frac_scav*chem_tmpb(k,icc,jcls,ipp,l) - chem_tmpb(k,icc,jcls,ipp,l) = chem_tmpb(k,icc,jcls,ipp,l) - tmpa - - tmpb = tmpa*tmp_ardzcen - delchem_wetscav(k,icc,jcls,ipp,mwdt,l) = & - delchem_wetscav(k,icc,jcls,ipp,mwdt,l) - tmpb - chem_prflxdt(k,icc,jcls,ipp,mwdt,l) = & - chem_prflxdt(k,icc,jcls,ipp,mwdt,l) + tmpb - end do ! ll - end do ! m - end do ! n - end do ! icc - end do ! ipp - end do ! jcls - - -! -! calc below-cloud scavenging of interstitial aerosols -! - do jcls = 1, ncls_use - do ipp = 1, 2 - do icc = 1, 2 -! cycle ! *** skip for testing - if ( .not. is_active(k,icc,jcls,ipp) ) cycle - if ( .not. is_precp( k,icc,jcls,ipp) ) cycle - - tmp_ardzcen = acen_tmp(k,icc,jcls,ipp)*rhodz_cen(k) - - iphase = ai_phase - do n = 1, ntype_aer - do m = 1, nsize_aer(n) - do ll = 0, ncomp_aer(n) - if (ll == 0) then - l = numptr_aer(m,n,iphase) - scavcoef = scavcoef_num(k,icc,jcls,ipp,m,n) - else - l = massptr_aer(ll,m,n,iphase) - scavcoef = scavcoef_vol(k,icc,jcls,ipp,m,n) - end if - if ((l < p1st) .or. (l > num_chem_ecpp)) cycle -! scavcoef = 0.01_r8 ! use simple constant value -! scavcoef = 0.0_r8 ! turn off below-cloud scav - - rate_scav = prta(k,icc,jcls,ipp)*scavcoef - frac_scav = 1.0_r8 - exp( -rate_scav*dt_scav ) - frac_scav = max( 0.0_r8, min( 1.0_r8, frac_scav ) ) - - tmpa = frac_scav*chem_tmpb(k,icc,jcls,ipp,l) - chem_tmpb(k,icc,jcls,ipp,l) = chem_tmpb(k,icc,jcls,ipp,l) - tmpa - - tmpb = tmpa*tmp_ardzcen - delchem_wetscav(k,icc,jcls,ipp,mwdt,l) = & - delchem_wetscav(k,icc,jcls,ipp,mwdt,l) - tmpb - chem_prflxdt(k,icc,jcls,ipp,mwdt,l) = & - chem_prflxdt(k,icc,jcls,ipp,mwdt,l) + tmpb - end do ! ll - end do ! m - end do ! n - end do ! icc - end do ! ipp - end do ! jcls - - -! -! calc gas scavenging -! - if ( .not. skip_gas_scav ) then - do jcls = 1, ncls_use - do ipp = 1, 2 - do icc = 1, 2 -! cycle ! *** skip for testing - if ( .not. is_rain(k,icc,jcls,ipp) ) cycle - tmp_ardzcen = acen_tmp(k,icc,jcls,ipp)*rhodz_cen(k) - - do ll = 1, ngas_scav - l = lgas_scav(ll) - if ((l < p1st) .or. (l > num_chem_ecpp)) cycle - - flxdt_kp1 = chem_prflxdt(k,icc,jcls,ipp,mwdt,l) - qgcx_bgn = chem_tmpb(k,icc,jcls,ipp,l) - tmpa = gasscav_aa(k,icc,jcls,ipp,ll) - tmpb = gasscav_bb(k,icc,jcls,ipp,ll) - tmpc = gasscav_cc(k,icc,jcls,ipp) - tmpe = tmpb + tmpc + tmpa*tmpc - -! this is the solution to the 2 final equations in subr wetscav_2_gasscav - flxdt = flxdt_kp1*((1.0_r8 + tmpa)*tmpc/tmpe) + qgcx_bgn*(tmpa/tmpe) - qgcx = qgcx_bgn*((1.0_r8 + tmpa*(tmpb/tmpe))/(1.0_r8 + tmpa)) & - + flxdt_kp1*(tmpc*(tmpb/tmpe)) - - chem_tmpb(k,icc,jcls,ipp,l) = qgcx - chem_prflxdt(k,icc,jcls,ipp,mwdt,l) = flxdt - tmpf = (qgcx - qgcx_bgn)*tmp_ardzcen - if (tmpf > 0.0_r8) then - delchem_wetresu(k,icc,jcls,ipp,mwdt,l) = & - delchem_wetresu(k,icc,jcls,ipp,mwdt,l) + tmpf - else - delchem_wetscav(k,icc,jcls,ipp,mwdt,l) = & - delchem_wetscav(k,icc,jcls,ipp,mwdt,l) + tmpf - end if - end do ! ll - - end do ! icc - end do ! ipp - end do ! jcls - end if ! ( .not. skip_gas_scav ) - - - end do wetscav_main_kloop_aa - call t_stopf('ecpp_wetscav_main') - - - call t_startf('ecpp_wetscav_endcopy') -! -! load new chem mixratios into chem_sub_new (only if wetscav_onoff_ecpp >= 300) -! calc overall changes to column burdens (only if wetscav_onoff_ecpp >= 200) -! - if (wetscav_onoff_ecpp >= 200) then - - do l = p1st, num_chem_ecpp - if ( skip_gas_scav .and. (inmw_of_aerosol(l) <= 0)) cycle - tmpx = 0.0_r8 ; tmpx2 = 0.0_r8 - do k = kts, ktecen - tmpy = 0.0_r8 ; tmpy2 = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - tmpb = 0.0_r8 - tmpc = 0.0_r8 - do ipp = 1, 2 - tmpa = acen_tmp(k,icc,jcls,ipp) - if ( is_active(k,icc,jcls,ipp) ) then - tmpy = tmpy + tmpa*(chem_tmpb(k,icc,jcls,ipp,l) & - - chem_tmpa(k,icc,jcls,ipp,l)) - tmpb = tmpb + tmpa*chem_tmpb(k,icc,jcls,ipp,l) - tmpc = tmpc + tmpa - end if - tmpd = 0.0_r8 - do inwdt=1, nwdt - tmpd = tmpd + delchem_wetscav(k,icc,jcls,ipp,inwdt,l) /rhodz_cen(k) - end do - del_wetscav3d(k,icc,jcls,ipp,l) = del_wetscav3d(k,icc,jcls,ipp,l) + tmpd - tmpe = 0.0_r8 - do inwdt=1, nwdt - tmpe = tmpe + delchem_wetresu(k,icc,jcls,ipp,inwdt,l) /rhodz_cen(k) - end do - del_wetresu3d(k,icc,jcls,ipp,l) = del_wetresu3d(k,icc,jcls,ipp,l) + tmpe - tmpy2 = tmpy2 + tmpd + tmpe - end do ! ipp - if ((acen_tavg_use(k,icc,jcls) > afrac_cut_0p5) .and. & - (tmpc > 0.0_r8) .and. (wetscav_onoff_ecpp >= 300)) then - chem_sub_new(k,icc,jcls,l) = max( 0.0_r8, tmpb )/tmpc - end if - end do ! icc - end do ! jcls - tmpx = tmpx + tmpy*rhodz_cen(k) - tmpx2 = tmpx2 + tmpy2*rhodz_cen(k) - end do ! k - curdel_chem_clm_wetscav(l) = tmpx - ! *** increment del_chem_clm_wetscav with tmpx2 (new way) - ! instead of tmpx (old way) - del_chem_clm_wetscav(l) = del_chem_clm_wetscav(l) + tmpx2 - end do ! l - - end if ! (wetscav_onoff_ecpp >= 200) - call t_stopf('ecpp_wetscav_endcopy') - - call t_startf('ecpp_wetscav_enddiag') -! -! diagnostic checks on the new arrays to see that they are "making sense" -! - if (lun142 > 0) then - - do l = p1st, num_chem_ecpp - - write(lun142,'(//a,i5)') 'diags for species l =', l - - if (lun142 == -999888777) then ! *** skip for testing - - write(lun142,'(a,i5)') 'chem_tmpa for icc=ipp=2 & grid-avg; chem_tmpb ...; b-a ...' - icc = 2 ; ipp = 2 - do k = ktecen, kts, -1 - write(lun142,'(i3,1p,3(2x,4e10.3))') k, & - ( chem_tmpa(k,icc,jcls,ipp,l), jcls=1,ncls_use ), & - sum( chem_tmpa(k,1:2,1:ncls_use,1:2,l)* & - acen_tmp(k,1:2,1:ncls_use,1:2) ), & - ( chem_tmpb(k,icc,jcls,ipp,l), jcls=1,ncls_use ), & - sum( chem_tmpb(k,1:2,1:ncls_use,1:2,l)* & - acen_tmp(k,1:2,1:ncls_use,1:2) ), & - ( (chem_tmpb(k,icc,jcls,ipp,l) - & - chem_tmpa(k,icc,jcls,ipp,l)), jcls=1,ncls_use ), & - sum( ( chem_tmpb(k,1:2,1:ncls_use,1:2,l) - & - chem_tmpa(k,1:2,1:ncls_use,1:2,l) )* & - acen_tmp(k,1:2,1:ncls_use,1:2) ) - end do - - write(lun142,'(/a,i5)') & - 'delchem_wetscav for icc=ipp=2 & grid-avg; delchem_wetresu ...; chem_prflxdt_xfer ...' - icc = 2 ; ipp = 2 - do k = ktecen, kts, -1 - write(lun142,'(i3,1p,3(2x,4e10.3))') k, & - ( delchem_wetscav( k,icc,jcls,ipp,mwdt,l), jcls=1,ncls_use ), & - sum( delchem_wetscav( k,1:2,1:ncls_use,1:2,1:nwdt,l) ), & - ( delchem_wetresu( k,icc,jcls,ipp,mwdt,l), jcls=1,ncls_use ), & - sum( delchem_wetresu( k,1:2,1:ncls_use,1:2,1:nwdt,l) ), & - ( chem_prflxdt_xfer(k,icc,jcls,ipp,mwdt,l), jcls=1,ncls_use ), & - sum( chem_prflxdt_xfer(k,1:2,1:ncls_use,1:2,1:nwdt,l) ) - end do - - write(lun142,'(/a,i5)') & - 'chem_prflxdt for icc=ipp=2 & grid-avg; conserve check stuff' - icc = 2 ; ipp = 2 - do k = ktecen, kts, -1 - kp1 = min(k+1,ktecen) ; tmpa = kp1 - k - write(lun142,'(i3,1p,3(2x,4e10.3))') k, & - ( chem_prflxdt( k,icc,jcls,ipp,mwdt,l), jcls=1,ncls_use ), & - sum( chem_prflxdt( k,1:2,1:ncls_use,1:2,1:nwdt,l) ), & - ( chem_prflxdt( kp1,icc,jcls,ipp,mwdt,l)*tmpa & - - chem_prflxdt( k,icc,jcls,ipp,mwdt,l) & - - delchem_wetscav( k,icc,jcls,ipp,mwdt,l) & - - delchem_wetresu( k,icc,jcls,ipp,mwdt,l) & - + chem_prflxdt_xfer(k,icc,jcls,ipp,mwdt,l), jcls=1,ncls_use ), & - sum( chem_prflxdt( kp1,1:2,1:ncls_use,1:2,1:nwdt,l)*tmpa & - - chem_prflxdt( k,1:2,1:ncls_use,1:2,1:nwdt,l) & - - delchem_wetscav( k,1:2,1:ncls_use,1:2,1:nwdt,l) & - - delchem_wetresu( k,1:2,1:ncls_use,1:2,1:nwdt,l) & - + chem_prflxdt_xfer(k,1:2,1:ncls_use,1:2,1:nwdt,l) ) - end do - - end if ! (lun142 == -999888777) - - write(lun142,'(/2a,i5)') & - 'sum( delchem_wetscav ), sum( delchem_wetresu ), sum( both ),', & - ' curdel_chem_clm_wetscav, (4)-(5)/max(...)' - tmpa = sum( delchem_wetscav( kts:ktecen,1:2,1:ncls_use,1:2,1:nwdt,l) ) - tmpb = sum( delchem_wetresu( kts:ktecen,1:2,1:ncls_use,1:2,1:nwdt,l) ) - tmpc = tmpa + tmpb - tmpd = curdel_chem_clm_wetscav(l) - tmpe = (tmpc - tmpd)/max( abs(tmpc), abs(tmpd), 1.0e-38_r8 ) - write(lun142,'(1p,3(2x,2e11.3))') & - tmpa, tmpb, tmpc, tmpd, tmpe -! if (l == 2) write(lun142,'(3a)') 'qakee - ktau, it_hyb, it_sub, l', & -! 'sum( delchem_wetscav ), sum( delchem_wetresu ), sum( both ),', & -! ' curdel_chem_clm_wetscav, (4)-(5)/max(...)' -! if (l >= 39) write(lun142,'(a,4i4,1p,3(2x,2e11.3))') & -! 'qakee', ktau, itstep_hybrid, itstep_sub, l, & -! tmpa, tmpb, tmpc, tmpd, tmpe - - write(lun142,'(/2a,i5)') & - 'sum( del_wetscav3d ), sum( del_wetresu3d ), sum( both ),', & - ' del_chem_clm_wetscav, (4)-(5)/max(...)' - tmpa = 0.0_r8 ; tmpb = 0.0_r8 - do k = kts, ktecen - tmpa = tmpa + sum( del_wetscav3d(k,1:2,1:ncls_use,1:2,l) ) * rhodz_cen(k) - tmpb = tmpb + sum( del_wetresu3d(k,1:2,1:ncls_use,1:2,l) ) * rhodz_cen(k) - end do - tmpc = tmpa + tmpb - tmpd = del_chem_clm_wetscav(l) - tmpe = (tmpc - tmpd)/max( abs(tmpc), abs(tmpd), 1.0e-38_r8 ) - write(lun142,'(1p,3(2x,2e11.3))') & - tmpa, tmpb, tmpc, tmpd, tmpe -! if (l == 2) write(lun142,'(3a)') 'qakff - ktau, it_hyb, it_sub, l', & -! 'sum( del_wetscav3d ), sum( del_wetresu3d ), sum( both ),', & -! ' del_chem_clm_wetscav, (4)-(5)/max(...)' -! if (l >= 39) write(lun142,'(a,4i4,1p,3(2x,2e11.3))') & -! 'qakff', ktau, itstep_hybrid, itstep_sub, l, & -! tmpa, tmpb, tmpc, tmpd, tmpe - - end do ! l - - write(lun142,'(//a,i5)') 'qlsink*dt_scav for icc=ipp=2; qcloud ...; ardzcen ...' - icc = 2 ; ipp = 2 - do k = ktecen, kts, -1 - write(lun142,'(i3,1p,4(2x,3e10.3))') k, & - ( qlsink_sub2(k,icc,jcls,ipp)*dt_scav, jcls=1,ncls_use ), & - ( qcloud_sub2(k,icc,jcls,ipp), jcls=1,ncls_use ), & - ( acen_tmp(k,icc,jcls,ipp)*rhodz_cen(k), jcls=1,ncls_use ) - end do - - write(lun142,'(//a,i5)') 'prta for icc=ipp=2; prtb ...; delprtb ...' - icc = 2 ; ipp = 2 - do k = ktecen, kts, -1 - write(lun142,'(i3,1p,4(2x,3e10.3))') k, & - ( prta(k,icc,jcls,ipp), jcls=1,ncls_use ), & - ( prtb(k,icc,jcls,ipp), jcls=1,ncls_use ), & - ( prtb(k,icc,jcls,ipp)-prtb(k+1,icc,jcls,ipp), jcls=1,ncls_use ) - end do - - end if ! (lun142 > 0) - - call t_stopf('ecpp_wetscav_enddiag') - - -! write(*,'(a)') 'wetscav_2 DONE' - return - end subroutine parampollu_tdx_wetscav_2 - - - -!----------------------------------------------------------------------- - subroutine wetscav_2_gasscav( & - ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & - dt_scav, & - idiagaa_ecpp, ldiagaa_ecpp, idiagbb_wetscav, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - is_active, is_precp, is_rain, & - maxgas_scav, ngas_scav, lgas_scav, & - acen_tmp, prra, & - qcloud_sub2, qlsink_sub2, & - gasscav_aa, gasscav_bb, gasscav_cc ) - - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! wetscav_2_gasscav does pre-calculations for in-cloud and below-cloud -! of gases (h2o2, so2, and nh3) by rain -! the results are applied in subr parampollu_tdx_wetscav_2 -! -! main assumptions -! reversible scavenging of gases -! prescribed pH for rainwater and cloudwater -! no aqueous phase reactions are treated here -!----------------------------------------------------------------------- - -! use module_state_description, only: p_qv, p_qc - -! use module_data_radm2, only: epsilc - - use module_data_mosaic_asect, only: & - ai_phase, dens_aer, hygro_aer, & - massptr_aer, maxd_asize, maxd_atype, & - ncomp_aer, nphase_aer, nsize_aer, ntype_aer, numptr_aer, & - dcen_sect, dhi_sect, dlo_sect, sigmag_aer, & - volumhi_sect, volumlo_sect - - use module_data_ecpp1 - - use constituents, only: cnst_get_ind - - use module_ecpp_util, only: ecpp_error_fatal - - implicit none - -! arguments -! ( for definitions see subr parampollu_tdx_wetscav_2 ) - integer, intent(in) :: & - ktau, ktau_pp, itstep_sub, & - it, jt, kts, ktebnd, ktecen - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199), & - idiagbb_wetscav - - real(r8), intent(in) :: dtstep, dtstep_sub, dt_scav - - real(r8), intent(in), dimension( kts:ktecen ) :: & - tcen_bar, pcen_bar, rhocen_bar, dzcen - - integer, intent(in) :: ncls_use - - logical, intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - is_active, is_precp, is_rain - - integer, intent(in) :: maxgas_scav - integer, intent(out) :: ngas_scav - integer, intent(out), dimension( 1:maxgas_scav ) :: & - lgas_scav - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - acen_tmp, qcloud_sub2, qlsink_sub2 - - real(r8), intent(in), dimension( kts:ktebnd, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - prra - - real(r8), intent(out), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, maxgas_scav ) :: & - gasscav_aa, gasscav_bb - - real(r8), intent(out), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - gasscav_cc - - - -! local variables - integer :: icc, ipp - integer :: itmpa - integer :: jcls - integer :: k - integer :: ll, lun143 - integer :: m - integer :: n - integer :: p1st - -! real(r8), parameter :: piover6 = 3.14159265358979323846_r8/6.0_r8 - real(r8), parameter :: qcldwtr_cutoff = 1.0e-6_r8 - real(r8), parameter :: tmp8over9 = 8.0_r8/9.0_r8 - - real(r8) :: frac_c, frac_g - real(r8) :: hen1c(maxgas_scav), hen1r(maxgas_scav) - real(r8) :: hen2c(maxgas_scav), hen2r(maxgas_scav) - real(r8) :: heffcx(maxgas_scav), heffrx(maxgas_scav) - real(r8) :: hionc, hionr - real(r8) :: kxf_cr, kxf_gcr, kxf_gr(maxgas_scav) - real(r8) :: qcwtr, qrwtr - real(r8) :: scavrate_hno3 - real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpg - real(r8) :: vfallr - - -! pointers for gases that are scavenged - p1st = param_first_ecpp - - ngas_scav = 4 - if (ngas_scav > maxgas_scav) then - write(*,*) 'subr wetscav_2_gasscav -- ngas_scav > maxgas_scav', & - ngas_scav > maxgas_scav - call ecpp_error_fatal( lunout, & - 'subr wetscav_2_gasscav -- ngas_scav > maxgas_scav' ) - end if - - lgas_scav(:) = -1 - - call cnst_get_ind( 'so2', itmpa, .false. ) - if (itmpa <= 0) call cnst_get_ind( 'SO2', itmpa, .false. ) - if ((itmpa >= p1st) .and. (itmpa <= num_chem_ecpp)) lgas_scav(1) = itmpa - - call cnst_get_ind( 'h2o2', itmpa, .false. ) - if (itmpa <= 0) call cnst_get_ind( 'H2O2', itmpa, .false. ) - if ((itmpa >= p1st) .and. (itmpa <= num_chem_ecpp)) lgas_scav(2) = itmpa - - call cnst_get_ind( 'nh3', itmpa, .false. ) - if (itmpa <= 0) call cnst_get_ind( 'NH3', itmpa, .false. ) - if ((itmpa >= p1st) .and. (itmpa <= num_chem_ecpp)) lgas_scav(3) = itmpa - - call cnst_get_ind( 'h2so4', itmpa, .false. ) - if (itmpa <= 0) call cnst_get_ind( 'H2SO4', itmpa, .false. ) - if ((itmpa >= p1st) .and. (itmpa <= num_chem_ecpp)) lgas_scav(4) = itmpa - -! write(*,'(a,10i5)') 'wetscav_2_gasscav - ngas_scav', ngas_scav -! write(*,'(a,10i5)') 'wetscav_2_gasscav - lgas_scav', lgas_scav(1:maxgas_scav) -! if (ngas_scav /= -13579) stop - - -! -! treatment of gas scavenging (by rain) -! -! primary assumptions are -! gases are reversibly scavenging in rain (e.g., transfer from gas to rain -! and transfer from rain to gas are both treated) -! rainborne gases are treated a locally steady-state, but vary with height -! cloudborne gases in equilibrium with the "interstitial gases" -! and are collected by rain -! pH for the cloud and rainwater are prescribed -! aqueous chemical reaction in rain are not treated -! -! define -! qrx = mixing ratio of rainborne species x (kg-x/kg-air) -! qcx = mixing ratio of cloudborne species x (kg-x/kg-air) -! qgx = mixing ratio of gaseous species x (kg-x/kg-air) -! qgcx = qgx + qcx -! -! the above are defined for each vertical layer and each ecpp subarea -! (in wrf-chem, they are units are actually mg-x/kg-air after a molecular weight -! ratio is applied, but the equations work anyway) -! -! basic equations: -! -! d[acen*rho*qgcx]/dt = acen*rho*[ -kxf_gr*(qgx - qrx/heffrx) - kxf_ct*qcx ] -! -! d[acen*rho*vfallr*qrx]/dz = acen*rho*[ -kxf_gr*(qgx - qrx/heffrx) - kxf_ct*qcx ] -! -! qcx = heffcx*qgx -! -! where -! acen = fractional area of subarea -! rho = air density (kg-air/m^3) -! vfallr = rain fall velocity (m/s, and positive) -! kxf_gr = mass transfer coefficient for gas <--> rain (1/s) -! a power-law curve fit to Schwarz and Levine (19xx) is used -! kxf_ct = rate of collection of cloudwater by rainwater (1/s) == qlsink -! heffrx, heffcx = gaseous-rainborne and gaseous-cloudborne equilibirum partitioning -! coefficients (i.e., modified effective henry law constants) with units of -! [(mol-x/kg-h2o)/(mol-x/kg-air)] == [(kg-x/kg-h2o)/(kg-x/kg-air)] -! -! define -! frac_c = heffcx/(1 + heffgx) so qcx = frac_c*qgcx -! frac_g = 1 - frac_c so qgx = frac_g*qgcx -! kxf_gcr = frac_g*kxf_gr + frac_c*kxf_cr -! -! then -! -! d[acen*rho*qgcx]/dt = acen*rho*[ -kxf_gcr*qgcx + kxf_gr*qrx/heffrx) ] -! -! d[acen*rho*vfallr*qrx]/dz = acen*rho*[ -kxf_gcr*qgcx + kxf_gr*qrx/heffrx) ] -! -! define -! dt = time step ( = ecpp sub time step ) -! flxdt = acen*rho*vfallr*qrx*dt = chem_prflxdt of subr parampollu_tdx_wetscav_2 -! -! then -! -! d[acen*rho*qgcx]/dt = -[acen*rho*kxf_gcr]*qgcx + [kxf_gr/(heffrx*vfallr*dt)]*flxdt -! -! d[flxdt]/dz = -[acen*rho*kxf_gcr*dt]*qgcx + [kxf_gr/(heffrx*vfallr)]*flxdt -! -! now define -! dt = time step (s) -! dz = thickness of layer k (m) -! qgcx = qgcx in layer k at end of time step -! qgcx_bgn = qgcx in layer k at beginning of time step -! flxdt = flxdt in layer k at end of time step -! flxdt_kp1 = flxdt in layer k+1 at end of time step -! -! and use the following finite differencing which is implicit in time -! -! (acen*rho)*(qgcx - qgcx_o)/dt = -[acen*rho*kxf_gcr]*qgcx + [kxf_gr/(heffrx*vfallr*dt)]*flxdt -! which yields -! qgcx*[1 + kxf_gcr*dt] + flxdt*[-kxf_gr/(heffrx*vfallr*acen*rho)] = qgcx_bgn -! -! (flxdt+kp1 - flxdt)/dz = -[acen*rho*kxf_gcr*dt]*qgcx + [kxf_gr/(heffrx*vfallr)]*flxdt -! which yields -! qgcx*[-kxf_gcr*dt] + flxdt*[1/(dz*acen*rho) + kxf_gr/(heffrx*vfallr*acen*rho)] = flxdt_kp1*[1/(dz*acen*rho)] -! -! define -! aa = kxf_gcr*dt -! bb = kxf_gr/(heffrx*vfallr*acen*rho) -! cc = 1/(dz*acen*rho) -! -! then -! qgcx*[1 + aa] + flxdt*[-bb] = qgcx_bgn -! qgcx*[-aa] + flxdt*[cc + bb] = flxdt_kp1*[cc] -! -! these 2 equations are solved in the gas-scavenging section of subr parampollu_tdx_wetscav_2, -! starting at ktecen (where flxdt_kp1 = ) -! the purpose of this routine (subr wetscav_2_gasscav) is to provide the aa, bb, and cc -! - - - lun143 = -1 - if (idiagaa_ecpp(143) > 0) lun143 = ldiagaa_ecpp(143) - if (idiagbb_wetscav /= 1) lun143 = -1 - -! hionr, hionc = prescribed hydrogen ion concentrations (mol/liter-h2o) -! for rainwater and cloudwater - hionr = 10.0_r8**(-5.0_r8) - hionc = 10.0_r8**(-4.5_r8) - -! calculate information needed for the gas scavenging equations -main_kloop_aa: & - do k = kts, ktecen - - do ipp = 1, 2 - do jcls = 1, ncls_use - do icc = 1, 2 - - if ( .not. is_rain(k,icc,jcls,ipp) ) cycle - if (lun143 > 0) write(lun143,'(/a,5i5)') 'wetscav_2_gasscav', & - ktau, k, icc, jcls, ipp - if (lun143 > 0) write(lun143,'(a,1p,8e11.3)') 'aaaa stuff ', & - tcen_bar(k), pcen_bar(k), rhocen_bar(k), dzcen(k), dt_scav - - -! calculate rain fallspeed and rainwater mixing ratio using Kessler (1969) - tmpa = prra(k,icc,jcls,ipp) ! rain precip rate (kg/m^2/s) - tmpb = sqrt( 1.22_r8/rhocen_bar(k) ) ! density factor for fallspeed -! tmpc = first guess rain water conc (kg/m^3) from Kessler (1969) - tmpc = (tmpa/(12.11_r8*tmpb))**tmp8over9 -! vfallr = rain mean fallspeed (m/s) from its definition, but forced to >= 1 m/s - vfallr = max( 1.0_r8, (tmpa/tmpc) ) -! qrwtr = rain water mixing ratio (kg/kgair) from its definition - qrwtr = tmpa/(vfallr*rhocen_bar(k)) - if (lun143 > 0) write(lun143,'(a,1p,8e11.3)') 'rain stuff ', & - prra(k,icc,jcls,ipp), acen_tmp(k,icc,jcls,ipp), & - tmpa, tmpb, tmpc, vfallr, qrwtr - -! qcwtr = cloud water mixing ratio (kg/kgair) from its definition - qcwtr = qcloud_sub2(k,icc,jcls,ipp) - if (qcwtr > qcldwtr_cutoff) then - kxf_cr = max( 0.0_r8, qlsink_sub2(k,icc,jcls,ipp) ) - else - qcwtr = 0.0_r8 - kxf_cr = 0.0_r8 - end if - - -! gas-liquid partitioning coefficients -! -! hen1 = effective henry law constant at prescribed ph -! [(mol-x/liter-h2o)/atm] = [(mol-x/kg-h2o)/atm] - hen1r(:) = 0.0_r8 - hen1c(:) = 0.0_r8 - tmpa = (1.0_r8/tcen_bar(k)) - (1.0_r8/298.16_r8) - if (lun143 > 0) write(lun143,'(a,1p,8e11.3)') '0000 hen1 ', & - tcen_bar(k), tmpa, qrwtr, qcwtr -! so2 - tmpb = 1.23_r8*exp(3150.0_r8*tmpa) ! henry law constant - tmpc = 1.3e-2_r8*exp(1960.0_r8*tmpa) ! 1st dissociation constant - hen1r(1) = tmpb*(1.0_r8 + tmpc/hionr) ! effective henry - hen1c(1) = tmpb*(1.0_r8 + tmpc/hionc) ! effective henry - if (lun143 > 0) write(lun143,'(a,1p,8e11.3)') 'so2 hen1 ', & - tmpb, tmpc, hen1r(1), hen1c(1) -! h2o2 - tmpb = 7.45e4_r8*exp(7300.0_r8*tmpa) ! henry law constant - hen1r(2) = tmpb - hen1c(2) = tmpb - if (lun143 > 0) write(lun143,'(a,1p,8e11.3)') 'h2o2 hen1 ', & - tmpb, 0.0_r8, hen1r(2), hen1c(2) -!+++mhwang -! set hen1r and hen1d of so2 to be the same as H2O2, which is what used -! in the conventional NCAR CAM. -! Minghuai Wang (Minghuai.Wang@pnl.gov), 2010-02 -! hen1r(1) = hen1r(2) -! hen1c(1) = hen1c(2) -!---mhwang - -! nh3 - tmpb = 6.21e1_r8*exp(4110.0_r8*tmpa) ! henry law constant - tmpc = 1.7e-5_r8*exp(-450.0_r8*tmpa) ! 1st dissociation constant - tmpd = 1.0e-14_r8*exp(-6710.0_r8*tmpa) ! water dissociation constant - hen1r(3) = tmpb*(1.0_r8 + (tmpc/tmpd)*hionr) ! effective henry - hen1c(3) = tmpb*(1.0_r8 + (tmpc/tmpd)*hionc) ! effective henry - if (lun143 > 0) write(lun143,'(a,1p,8e11.3)') 'nh3 hen1 ', & - tmpb, tmpc, hen1r(3), hen1c(3) -! h2so4 (values are from CAPRAM website) - tmpb = 8.7e11_r8 ! henry law constant - tmpc = 1.0e3_r8 ! 1st dissociation constant - hen1r(4) = tmpb*(1.0_r8 + tmpc/hionr) ! effective henry - hen1c(4) = tmpb*(1.0_r8 + tmpc/hionc) ! effective henry - if (lun143 > 0) write(lun143,'(a,1p,8e11.3)') 'h2so4 hen1 ', & - tmpb, tmpc, hen1r(4), hen1c(4) - -! hen2 = like hen1 but units = [(mol-x/kg-h2o)/(mol-x/kg-air)] -! ax atm of x = ax*p0 Pa of x = ax*p0/pair (mol-x/mol-air) -! = ax*p0/(pair*0.029) (mol-x/kg-air) - tmpa = (pcen_bar(k)/1.01325e5_r8)*0.028966_r8 - hen2r(1:ngas_scav) = hen1r(1:ngas_scav)*tmpa - hen2c(1:ngas_scav) = hen1c(1:ngas_scav)*tmpa - -! heffrx,cx units = [(mol-x/kg-air)/(mol-x/kg-air)] and includes -! rainwater,cloudwater mixing ratio factor - heffrx(1:ngas_scav) = hen2r(1:ngas_scav)*qrwtr - heffcx(1:ngas_scav) = hen2c(1:ngas_scav)*qcwtr - if (lun143 > 0) write(lun143,'(a,1p,8e11.3)') 'heffrx,cx ', & - heffrx(1:4), heffcx(1:4) - - -! gas-rain mass transfer rates -! -! scavrate_hno3 = rain scavenging rate for hno3 (1/s) -! this is power law fit to levine and schwartz (1982, atmos environ) -! results, with temperature and pressure adjustments - tmpa = prra(k,icc,jcls,ipp)*3600.0_r8 ! precip rate in mm/hr = kg/m^2/hr - scavrate_hno3 = 6.262e-5_r8*(tmpa**0.7366_r8) & - * ((tcen_bar(k)/298.0_r8)**1.12_r8) & - * ((1.01325e5_r8/pcen_bar(k))**.75_r8) -! for other gases, multiply hno3 rate by ratio of gas diffusivities - kxf_gr(1) = scavrate_hno3*1.08_r8 ! so2 - kxf_gr(2) = scavrate_hno3*1.38_r8 ! h2o2 - kxf_gr(3) = scavrate_hno3*1.59_r8 ! nh3 - kxf_gr(4) = scavrate_hno3*0.80_r8 ! h2so4 - if (lun143 > 0) write(lun143,'(a,1p,8e11.3)') 'kxf_gr,cr ', & - kxf_gr(1:4), kxf_cr - - -! aa, bb, and cc coefficients of the 2 final equations - tmpa = acen_tmp(k,icc,jcls,ipp)*rhocen_bar(k) -! cc = 1/(dz*acen*rho) - gasscav_cc(k,icc,jcls,ipp) = 1.0_r8/(dzcen(k)*tmpa) - - do ll = 1, ngas_scav - frac_c = heffcx(ll)/(1.0_r8 + heffcx(ll)) - frac_g = 1.0_r8 - frac_c - kxf_gcr = frac_g*kxf_gr(ll) + frac_c*kxf_cr -! aa = kxf_gcr*dt - gasscav_aa(k,icc,jcls,ipp,ll) = kxf_gcr*dt_scav - -! bb = kxf_gr/(heffrx*vfallr*acen*rho) - gasscav_bb(k,icc,jcls,ipp,ll) = kxf_gr(ll)/(heffrx(ll)*vfallr*tmpa) -! setting gasscav_bb=0 (heffrx = infinity) gives irreversible scavenging -! gasscav_bb(k,icc,jcls,ipp,ll) = 0.0 - - if (lun143 > 0) write(lun143,'(a,i1,1p,8e11.3)') 'aa/bb/cc ', & - ll, gasscav_aa(k,icc,jcls,ipp,ll), gasscav_bb(k,icc,jcls,ipp,ll), & - gasscav_cc(k,icc,jcls,ipp), frac_g, frac_c, kxf_gcr - end do ! l - - - - end do ! icc - end do ! jcls - end do ! ipp - - end do main_kloop_aa - - - return - end subroutine wetscav_2_gasscav - - - -!----------------------------------------------------------------------- - subroutine wetscav_2_bcscavcoef( & - ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & - idiagaa_ecpp, ldiagaa_ecpp, idiagbb_wetscav, & - tcen_bar, pcen_bar, rhocen_bar, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - rh_sub2, & - is_active, is_precp, & - chem_tmpa, scavcoef_num, scavcoef_vol ) - - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! wetscav_2_bcscavcoef calculates below-cloud scavenging coefficents -! similar to subr modal_aero_bcscavcoef_get -! -!----------------------------------------------------------------------- - -! use module_state_description, only: p_qv, p_qc - -! use module_data_radm2, only: epsilc - -! use module_data_mosaic_asect, only: ai_phase, cw_phase, & -! massptr_aer, maxd_asize, maxd_atype, & -! ncomp_aer, nphase_aer, nsize_aer, ntype_aer, numptr_aer, & -! waterptr_aer - use module_data_mosaic_asect, only: & - ai_phase, dens_aer, hygro_aer, & - massptr_aer, maxd_asize, maxd_atype, & - ncomp_aer, nphase_aer, nsize_aer, ntype_aer, numptr_aer, & - dcen_sect, dhi_sect, dlo_sect, sigmag_aer, & - volumhi_sect, volumlo_sect - - use modal_aero_wateruptake, only: modal_aero_kohler - - use aero_model, only: & - calc_1_impact_rate, & - get_dlndg_nimptblgrow, nimptblgrow_mind, nimptblgrow_maxd, & - get_scavimptblnum, get_scavimptblvol - - use modal_aero_data,only: ntot_amode - - use module_data_ecpp1 - -! use module_ecpp_hoststuff, only: config_flags_ecpp - -! use module_mosaic_wetscav, only: wetscav_cbmz_mosaic - -! use module_ecpp_util, only: ecpp_error_fatal, ecpp_message, & -! parampollu_1clm_set_opts - - implicit none - -! arguments -! ( for definitions see subr parampollu_tdx_wetscav_2 ) - integer, intent(in) :: & - ktau, ktau_pp, itstep_sub, & - it, jt, kts, ktebnd, ktecen - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199), & - idiagbb_wetscav - - real(r8), intent(in) :: dtstep, dtstep_sub - - real(r8), intent(in), dimension( kts:ktecen ) :: & - tcen_bar, pcen_bar, rhocen_bar - - integer, intent(in) :: ncls_use - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - rh_sub2 - - logical, intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - is_active, is_precp - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:num_chem_ecpp ) :: & - chem_tmpa - - real(r8), intent(inout), & - dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:maxd_asize, 1:maxd_atype ) :: & - scavcoef_num, scavcoef_vol -! scavcoef_vol = below-cloud scavenging coeficient for volume (1/mm) -! scavcoef_num = below-cloud scavenging coeficient for number (1/mm) -! when precip rate = xxx kg/m2/s == xxx mm/s, the scavenging rate (1/s) = scavcoef*xxx - - -! local variables - integer :: icc, ipp - integer :: jcls, jgrow - integer :: k - integer :: l, ll, lun142 - integer :: m - integer :: n - integer :: p1st - - real(r8) :: dgratio - real(r8) :: dry_dens, dry_diam, dry_mass, dry_volu - real(r8) :: dry_mass_cut, dry_volu_cut - real(r8) :: fact_leng, fact_mass - real(r8), parameter :: onethird = 1.0_r8/3.0_r8 - real(r8), parameter :: piover6 = 3.14159265358979323846_r8/6.0_r8 - real(r8) :: scavimpnum, scavimpvol - real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpg - real(r8) :: tmpflo, tmpfhi - real(r8) :: tmp_hygro, tmp_num, tmp_rdry, tmp_rwet, tmp_rh - real(r8) :: watr_mass, wet_dens, wet_diam, wet_volu - real(r8) :: xgrow - real(r8) :: rdry_in_mak(1), hygro_mak(1), s_mak(1), rwet_out_mak(1) - - real(r8) :: scavimptblnum(nimptblgrow_mind:nimptblgrow_maxd, ntot_amode) - real(r8) :: scavimptblvol(nimptblgrow_mind:nimptblgrow_maxd, ntot_amode) - -! NOTE ON UNITS -! -! hostcode wrfchem cam -! mass mixing ratios ug/kg kg/kg -! dry/wet_mass g/kgair kg/kgair -! dens_aer g/cm^3 kg/m^3 -! dry/wet_volu cm^3/kgair m^3/kgair -! volumlo/hi_sect cm^3 m^3 -! dcen_sect cm m -! dry/wet_diam cm m -! - if ( hostcode_is_wrfchem ) then - fact_mass = 1.0e-6_r8 ! ug/kgair --> g/kgair - fact_leng = 1.0e-2_r8 ! cm --> m - dry_mass_cut = 1.0e-26_r8 ! g/kgair = 1.0e-20 ug/kgair - dry_volu_cut = 1.0e-26_r8 ! cm^3/kgair - else - fact_mass = 1.0_r8 ! kg/kgair, unchanged - fact_leng = 1.0_r8 ! m, unchanged - dry_mass_cut = 1.0e-29_r8 ! kg/kgair = 1.0e-20 ug/kgair - dry_volu_cut = 1.0e-32_r8 ! m^3/kgair - end if - -! -! calc below-cloud scavenging coefficients of interstitial aerosols -! - scavcoef_num(:,:,:,:,:,:) = 0.0_r8 - scavcoef_vol(:,:,:,:,:,:) = 0.0_r8 - - - scavimptblvol = get_scavimptblvol() - scavimptblnum = get_scavimptblnum() - - do k = kts, ktecen - do jcls = 1, ncls_use - do ipp = 1, 2 -icc_loop: & - do icc = 1, 2 - if ( .not. is_active(k,icc,jcls,ipp) ) cycle -! if ( .not. is_precp( k,icc,jcls,ipp) ) cycle - - lun142 = 0 -! if ((ktau == 1) .and. (k == 5)) lun142 = 142 - if (k == 5) lun142 = 142 - if (idiagbb_wetscav <= 0) lun142 = -1 - - -! calc below-cloud scavenging coefficients for each aerosol mode - do n = 1, ntype_aer - do m = 1, nsize_aer(n) - -! calc dry mass and dry volume mixing ratios - dry_volu = 0.0_r8 - dry_mass = 0.0_r8 - tmp_hygro = 0.0_r8 - do l = 1, ncomp_aer(n) - tmpa = chem_tmpa(k,icc,jcls,ipp,massptr_aer(l,m,n,ai_phase)) - dry_mass = dry_mass + tmpa - dry_volu = dry_volu + tmpa/dens_aer(l,n) - tmp_hygro = tmp_hygro + (tmpa/dens_aer(l,n))*hygro_aer(l,n) - end do - dry_mass = dry_mass*fact_mass ! g/kgair OR kg/kgair - dry_volu = dry_volu*fact_mass ! cm^3/kgair OR m^3/kgair - -! if negligible aerosol is present at this size and type, cycle - if ((dry_mass < dry_mass_cut) .or. (dry_volu < dry_volu_cut)) then - ! BUT FIRST set dgn_dry/wet and chem_sub( ... water ... ) to default values - cycle - end if - -! calc volume-mean dry diameter - tmp_num = chem_tmpa(k,icc,jcls,ipp,numptr_aer(m,n,ai_phase)) - if (dry_volu <= tmp_num*volumlo_sect(m,n)) then - dry_diam = dlo_sect(m,n) - else if (dry_volu >= tmp_num*volumhi_sect(m,n)) then - dry_diam = dhi_sect(m,n) - else - dry_diam = (dry_volu/(tmp_num*piover6))**onethird - end if - -! calc volume-mean wet diameter - tmp_hygro = tmp_hygro*fact_mass/dry_volu - tmp_rh = max( 0.0_r8, min( 0.99_r8, rh_sub2(k,icc,jcls,ipp) ) ) - tmp_rdry = dry_diam*0.5_r8*fact_leng ! cm OR m --> m - tmp_rwet = tmp_rdry - - rdry_in_mak(1) = tmp_rdry - hygro_mak(1) = tmp_hygro - s_mak(1) = tmp_rh - rwet_out_mak(1) = tmp_rwet -! call modal_aero_kohler( tmp_rdry, tmp_hygro, tmp_rh, tmp_rwet, 1, 1 ) - call modal_aero_kohler( rdry_in_mak, hygro_mak, s_mak, rwet_out_mak, 1) - tmp_rwet = rwet_out_mak(1) - - wet_diam = tmp_rwet*2.0_r8/fact_leng ! m --> cm OR m - wet_diam = min( wet_diam, dry_diam*100.0_r8, 50.0e-6_r8/fact_leng ) - wet_diam = max( wet_diam, dry_diam ) - -! wet_diam = dry_diam ! force water == 0 (for testing) - - wet_volu = dry_volu * (wet_diam/dry_diam)**3 ! cm^3/kgair - watr_mass = max( 0.0_r8, (wet_volu-dry_volu) ) ! g/kgair, as rho_water = 1.0 g/cm^3 -! *** eventually should store this in some array that can be used by cam3 -! for now, leave it alone -! chem_tmpa(k,icc,jcls,ipp,waterptr_aer(m,n)) = watr_mass/fact_mass - - wet_dens = (dry_mass + watr_mass)/wet_volu - dry_dens = dry_mass/dry_volu - -! compute impaction scavenging removal amount for volume -! interpolate table values using log of (actual-wet-size)/(base-dry-size) - -! in the bcscavcoef_get routine, dgratio = dgnum_wet/dgnum_amode -! BUT dgnum_wet/dgnum_amode = (b*dgnum_wet)/(b*dgnum_amode) = dvolmean_wet/dcen_sect -! where b = exp( 1.5 * (log(sigmag)**2) ) -! dgratio = ((wet_volu/dry_volu)**onethird) * (dry_diam/dcen_sect(m,n)) - dgratio = wet_diam/dcen_sect(m,n) - - if ((dgratio .ge. 0.99_r8) .and. (dgratio .le. 1.01_r8)) then - scavimpvol = scavimptblvol(0,m) - scavimpnum = scavimptblnum(0,m) - else - xgrow = log( dgratio ) / get_dlndg_nimptblgrow() - jgrow = int( xgrow ) - if (xgrow .lt. 0._r8) jgrow = jgrow - 1 - if (jgrow .lt. nimptblgrow_mind) then - jgrow = nimptblgrow_mind - xgrow = jgrow - else - jgrow = min( jgrow, nimptblgrow_maxd-1 ) - end if - - tmpfhi = xgrow - jgrow - tmpfhi = max( 0.0_r8, min( 1.0_r8, tmpfhi ) ) - tmpflo = 1.0_r8 - tmpfhi - scavimpvol = tmpflo*scavimptblvol(jgrow,m) + & - tmpfhi*scavimptblvol(jgrow+1,m) - scavimpnum = tmpflo*scavimptblnum(jgrow,m) + & - tmpfhi*scavimptblnum(jgrow+1,m) - end if - - !impaction scavenging removal amount for volume - scavcoef_vol(k,icc,jcls,ipp,m,n) = exp( scavimpvol ) - !impaction scavenging removal amount to number - scavcoef_num(k,icc,jcls,ipp,m,n) = exp( scavimpnum ) - -! test diagnostics - if (lun142 > 0) then - write(lun142,'(/a,8i4)') 'wetscav_2_bcscavcoef diags', & - ktau, k, jcls, ipp, icc, n, m - tmpb = sigmag_aer(m,n) - tmpg = log( sigmag_aer(m,n) ) - tmpg = exp( 1.5_r8*tmpg*tmpg ) - tmpa = dcen_sect(m,n)*dgratio/tmpg - tmpc = dens_aer(1,n) ! bcscavcoef_init uses this - if ( .not. hostcode_is_wrfchem ) then - tmpa = tmpa*1.0e2_r8 ! m --> cm - tmpc = tmpc*1.0e-3_r8 ! kg/m^3 --> g/cm^3 - end if - tmpd = 273.16_r8 ! bcscavcoef_init uses this - tmpe = 0.75e6_r8 ! bcscavcoef_init uses this -! call calc_1_impact_rate( & -! dg0, sigmag, rhoaero, temp, press, & -! scavratenum, scavratevol, lunerr ) - call calc_1_impact_rate( & - tmpa, tmpb, tmpc, tmpd, tmpe, & - tmpf, tmpg, lun142 ) - write(lun142,'(1p,8e11.3)') dgratio, & - tmpa, tmpb, tmpc, tmpd, tmpe - write(lun142,'(1p,8e11.3)') & - scavcoef_num(k,icc,jcls,ipp,m,n), tmpf, & - scavcoef_vol(k,icc,jcls,ipp,m,n), tmpg - write(lun142,'(1p,8e11.3)') & - dry_mass, dry_volu, wet_volu, dry_diam, wet_diam, tmp_rh, & - chem_tmpa(k,icc,jcls,ipp,numptr_aer(m,n,ai_phase)) - end if - - end do ! m - end do ! n - - end do icc_loop ! icc - end do ! ipp - end do ! jcls - end do ! k - - -! write(*,'(a)') 'wetscav_2_bcscavcoef DONE' - return - end subroutine wetscav_2_bcscavcoef - - - -!----------------------------------------------------------------------- - subroutine wetscav_2_precip_evap_xfer( & - ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & - idiagaa_ecpp, ldiagaa_ecpp, idiagbb_wetscav, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - is_active, is_precp, is_ptgain, is_ptloss, & - acen_tmp, prtb, frac_evap_prtb, frac_xfer_prtb, & - fxaa_evap_prtb ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! wetscav_2_precip_evap_xfer calculates the fractions of precip -! (and precip-borne aerosols) entering the top of a subarea that are either -! > evaporated/resuspended or -! > transferred to another subarea -! -!----------------------------------------------------------------------- - -! use module_state_description, only: p_qv, p_qc - -! use module_data_radm2, only: epsilc - -! use module_data_mosaic_asect, only: ai_phase, cw_phase, & -! massptr_aer, maxd_asize, maxd_atype, & -! ncomp_aer, nphase_aer, nsize_aer, ntype_aer, numptr_aer, & -! waterptr_aer - - use module_data_ecpp1 - - implicit none - -! subr arguments - integer, intent(in) :: & - ktau, ktau_pp, itstep_sub, & - it, jt, kts, ktebnd, ktecen - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199), & - idiagbb_wetscav - integer, intent(in) :: ncls_use - - real(r8), intent(in) :: dtstep, dtstep_sub - - logical, intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - is_active, is_precp - logical, intent(out), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - is_ptgain, is_ptloss - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: acen_tmp - real(r8), intent(in), dimension( kts:ktebnd, 1:2, 1:maxcls_ecpp, 1:2 ) :: prtb - - real(r8), intent(out), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: frac_evap_prtb - real(r8), intent(out), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, & - 1:2, 1:maxcls_ecpp, 1:2 ) :: frac_xfer_prtb - real(r8), intent(out), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, & - 1:2, 1:maxcls_ecpp, 1:2 ) :: fxaa_evap_prtb -! frac_evap_prtb = fraction of precip (and precip-borne aerosols) entering the -! top of a subarea that is evaporated/resuspended -! frac_xfer_prtb = fraction of precip (and precip-borne aerosols) entering the -! top of a subarea that is transferred to another subarea -! (the first set of icc,jcls,ipp indices are the "xfer from" subarea) -! (the second set of icc,jcls,ipp indices are the "xfer to " subarea) - -! local variables - integer :: icc, icc_g, icc_l, iphase, ipp, ipp_l, ipp_g - integer :: jcls, jcls_g, jcls_l - integer :: k, km1 - integer :: lun141 - integer :: m - - real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpg, tmph - real(r8) :: tmpvecb(100), tmpvece(100), tmpvecf(100) - - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - delprtb, delprtb_g, delprtb_l - real(r8), dimension( kts:ktecen ) :: & - delprtb_gtot, delprtb_ltot, delprtb_xtot, & - frac_evap, frac_xferg, frac_xferl - - - lun141 = -1 - if (idiagaa_ecpp(141) > 0) lun141 = ldiagaa_ecpp(141) - if (idiagbb_wetscav <= 0) lun141 = -1 - - is_ptloss(kts:ktecen,1:2,1:ncls_use,1:2) = .false. - is_ptgain(kts:ktecen,1:2,1:ncls_use,1:2) = .false. - - frac_evap_prtb(kts:ktecen,1:2,1:ncls_use,1:2) = 0.0_r8 - frac_xfer_prtb(kts:ktecen,1:2,1:ncls_use,1:2, 1:2,1:ncls_use,1:2) = 0.0_r8 - fxaa_evap_prtb(kts:ktecen,1:2,1:ncls_use,1:2, 1:2,1:ncls_use,1:2) = 0.0_r8 - - delprtb_gtot(:) = 0.0_r8 ; delprtb_ltot(:) = 0.0_r8 ; delprtb_xtot(:) = 0.0_r8 - frac_evap(:) = 0.0_r8 ; frac_xferg(:) = 0.0_r8 ; frac_xferl(:) = 0.0_r8 - -main_kloop_aa: & - do k = ktecen, kts, -1 - -! -! calculate the fractions of precip (and precip-borne aerosols) -! entering the top of a subarea that are either -! > evaporated/resuspended or -! > transferred to another subarea -! -! this is a bit tricky because we do not have evaporation information, -! and a decrease in precip from k+1 to k for one subarea -! can be due to that precip being classified as in another subarea -! -! approach here is to calculate precip loss and gains (from k+1 to k) -! for each subarea, then try to balance them out -! any "unbalanced" loss is treated as true evaporation -! - - do ipp = 1, 2 - do jcls = 1, ncls_use - do icc = 1, 2 -! delprtb = change in subarea precip from k+1 to k -! delprtb_g = gain in subarea precip from k+1 to k -! delprtb_l = loss in subarea precip from k+1 to k, but sign is positive - delprtb(k,icc,jcls,ipp) = prtb(k, icc,jcls,ipp) & - - prtb(k+1,icc,jcls,ipp) - delprtb_g(k,icc,jcls,ipp) = max( 0.0_r8, delprtb(k,icc,jcls,ipp) ) - delprtb_l(k,icc,jcls,ipp) = max( 0.0_r8, -delprtb(k,icc,jcls,ipp) ) - if (delprtb_g(k,icc,jcls,ipp) > 0.0_r8) is_ptgain(k,icc,jcls,ipp) = .true. - if (delprtb_l(k,icc,jcls,ipp) > 0.0_r8) is_ptloss(k,icc,jcls,ipp) = .true. - end do - end do - end do - -! delprtb_gtot = sum of delprtb_g over all subareas ; similar for depltrb_ltot - delprtb_gtot(k) = sum( delprtb_g(k,1:2,1:ncls_use,1:2) ) - delprtb_ltot(k) = sum( delprtb_l(k,1:2,1:ncls_use,1:2) ) -! delprtb_xtot = is amount of precip loss that can be balance by precip gain - delprtb_xtot(k) = min( delprtb_gtot(k), delprtb_ltot(k) ) - - if (delprtb_gtot(k) > 0.0_r8) then - frac_xferg(k) = delprtb_xtot(k) / delprtb_gtot(k) - frac_xferg(k) = max( 0.0_r8, min( 1.0_r8, frac_xferg(k) ) ) - end if - - if (delprtb_ltot(k) <= 0.0_r8) cycle main_kloop_aa ! bypass next steps if no loss - - frac_xferl(k) = delprtb_xtot(k) / delprtb_ltot(k) - frac_xferl(k) = max( 0.0_r8, min( 1.0_r8, frac_xferl(k) ) ) - frac_evap(k) = 1.0_r8 - frac_xferl(k) - - -! do calcs associated with balancing of precip loss and gain -! current approach is that there is no preferred pairing of -! "losing" and "gaining" subareas -! one might want to pair the clear and cloud subareas of a -! transport class first -- something to think about in the future -! *** this code is incomplete *** -! -! loop over the "losing" subareas - do jcls_l = 1, ncls_use - do ipp_l = 1, 2 - do icc_l = 1, 2 - if ( .not. is_ptloss(k,icc_l,jcls_l,ipp_l) ) cycle - tmpa = delprtb_l(k,icc_l,jcls_l,ipp_l)/prtb(k+1,icc_l,jcls_l,ipp_l) - frac_evap_prtb(k,icc_l,jcls_l,ipp_l) = frac_evap(k)*tmpa - -! loop over the "gaining" subareas - if (frac_xferl(k) <= 1.0e-7_r8) cycle - do jcls_g = 1, ncls_use - do ipp_g = 1, 2 - do icc_g = 1, 2 - if ( .not. is_ptgain(k,icc_g,jcls_g,ipp_g) ) cycle - tmpb = delprtb_g(k,icc_g,jcls_g,ipp_g)/delprtb_gtot(k) - frac_xfer_prtb(k,icc_l,jcls_l,ipp_l, icc_g,jcls_g,ipp_g) = & - frac_xferl(k)*tmpa*tmpb - end do ! icc_g - end do ! ipp_g - end do ! jcls_g - -! if a subarea exists ( is_active ) and has precip>0 at k+1, -! but does not exist at k, then the evaporated/resuspended material -! from the losing subarea must go to other subareas -! the fxaa_evap_prtb are used for this - if ( .not. is_active(k,icc_l,jcls_l,ipp_l) ) then - tmpf = 0.0_r8 - do jcls_g = 1, ncls_use - do ipp_g = 1, 2 - do icc_g = 1, 2 - if ( .not. is_active(k,icc_g,jcls_g,ipp_g) ) cycle - if ((jcls_g == jcls_l) .and. & - (ipp_g == ipp_l) .and. (icc_g == icc_l)) cycle - tmpf = tmpf + acen_tmp(k,icc_g,jcls_g,ipp_g) - fxaa_evap_prtb(k,icc_l,jcls_l,ipp_l, icc_g,jcls_g,ipp_g) = 1.0_r8 - end do ! icc_g - end do ! ipp_g - end do ! jcls_g - fxaa_evap_prtb(k,icc_l,jcls_l,ipp_l, 1:2,1:ncls_use,1:2) = & - fxaa_evap_prtb(k,icc_l,jcls_l,ipp_l, 1:2,1:ncls_use,1:2)*tmpf - end if - - end do ! icc_l - end do ! ipp_l - end do ! jcls_l - - - end do main_kloop_aa - - -! -! diagnostics for testing -! -! first set shows main arrays that can be inspected visually - if (lun141 > 0) then - - tmph = 3600.0_r8 - do k = ktecen, kts, -1 - - write(lun141,'(a,i3)') 'k =', k - - tmpa = delprtb_ltot(k) - delprtb_xtot(k) - tmpb = sum( frac_evap_prtb(k,1:2,1:ncls_use,1:2)*prtb(k+1,1:2,1:ncls_use,1:2) ) - write(lun141,'(a,2f9.5,2x,3f9.5,2x,2f9.5)') 'frac_xferl/evap, delg/l/xtot=', frac_xferl(k), frac_evap(k), & - 3600.0_r8*delprtb_gtot(k), 3600.0_r8*delprtb_ltot(k), 3600.0_r8*delprtb_xtot(k), & - 3600.0_r8*tmpa, 3600.0_r8*tmpb - - write(lun141,'(a,3(2x,4f9.5))') 'acen =', (((acen_tmp(k,icc,jcls,ipp), icc=1,2), ipp=1,2), jcls=1,ncls_use) - write(lun141,'(a,3(2x,4f9.5))') 'prtb =', (((prtb(k,icc,jcls,ipp)*tmph, icc=1,2), ipp=1,2), jcls=1,ncls_use) - write(lun141,'(a,3(2x,4f9.5))') 'delprtb =', (((delprtb(k,icc,jcls,ipp)*tmph, icc=1,2), ipp=1,2), jcls=1,ncls_use) - write(lun141,'(a,3(2x,4f9.5))') 'delprtb_g =', (((delprtb_g(k,icc,jcls,ipp)*tmph, icc=1,2), ipp=1,2), jcls=1,ncls_use) - write(lun141,'(a,3(2x,4f9.5))') 'delprtb_l =', (((delprtb_l(k,icc,jcls,ipp)*tmph, icc=1,2), ipp=1,2), jcls=1,ncls_use) - icc_l = 2 ; ipp_l = 2 ; icc_g = 2 ; ipp_g = 2 - write(lun141,'(a,3(2x,4f9.5))') 'frac_ev/xf =', ( frac_evap_prtb(k,icc_l,jcls_l,ipp_l), & - ( frac_xfer_prtb(k,icc_l,jcls_l,ipp_l, icc_g,jcls_g,ipp_g), jcls_g=1,ncls_use), jcls_l=1,ncls_use) - - end do - - -! second set does "conservation checks" -! is prtb(k) equal to [prtb(k+1) + gains - losses] ? - do k = ktecen, kts, -1 - - write(lun141,'(a,i3)') 'k =', k - -! here check sum( prtb ) over all subareas - tmpa = sum( prtb(k+1,1:2,1:ncls_use,1:2) ) - tmpb = sum( prtb(k ,1:2,1:ncls_use,1:2) ) - tmpc = tmpa + delprtb_gtot(k) - delprtb_ltot(k) - tmpd = tmpa + delprtb_gtot(k)*(1.0_r8 - frac_xferg(k)) - delprtb_ltot(k)*(1.0_r8 - frac_xferl(k)) - tmpe = (tmpb-tmpc)*tmph ! absolute error in mm/h - tmpf = (tmpb-tmpd)*tmph - tmpe = (tmpb-tmpc)/max(tmpa,tmpb,1.0e-30_r8) ! relative error - tmpf = (tmpb-tmpd)/max(tmpa,tmpb,1.0e-30_r8) - write(lun141,'(a,1p,2e10.2)') 'relerr1/2 =', tmpe, tmpf - -! here check prtb for each subarea - m = 0 - do jcls = 1, ncls_use - do ipp = 1, 2 - do icc = 1, 2 - tmpa = prtb(k+1,icc,jcls,ipp) - tmpb = prtb(k ,icc,jcls,ipp) - tmpc = tmpa + delprtb_g(k,icc,jcls,ipp) - delprtb_l(k,icc,jcls,ipp) - if ( is_ptgain(k,icc,jcls,ipp) ) then - tmpd = tmpa + delprtb_g(k,icc,jcls,ipp)*(1.0_r8 - frac_xferg(k)) & - + sum( frac_xfer_prtb(k,1:2,1:ncls_use,1:2,icc,jcls,ipp)*prtb(k+1,1:2,1:ncls_use,1:2) ) - else if ( is_ptloss(k,icc,jcls,ipp) ) then - tmpd = tmpa - prtb(k+1,icc,jcls,ipp)*( frac_evap_prtb(k,icc,jcls,ipp) & - + sum( frac_xfer_prtb(k,icc,jcls,ipp,1:2,1:ncls_use,1:2) ) ) - else - tmpd = tmpb - end if - tmpe = (tmpb-tmpc)*tmph ! absolute error in mm/h - tmpf = (tmpb-tmpd)*tmph - tmpe = (tmpb-tmpc)/max(tmpa,tmpb,1.0e-30_r8) ! relative error - tmpf = (tmpb-tmpd)/max(tmpa,tmpb,1.0e-30_r8) - m = m + 1 - tmpvece(m) = tmpe - tmpvecf(m) = tmpf - tmpvecb(m) = tmpb*tmph - end do - end do - end do - write(lun141,'(a,1p,3(2x,4e10.2))') 'tmpvecb =', tmpvecb(1:m) - write(lun141,'(a,1p,3(2x,4e10.2))') 'tmpvece =', tmpvece(1:m) - write(lun141,'(a,1p,3(2x,4e10.2))') 'tmpvecf =', tmpvecf(1:m) - - end do ! k = ktecen, kts, -1 - - end if ! (lun141 > 0) - - - end subroutine wetscav_2_precip_evap_xfer - - -end module ecpp_modal_wetscav - diff --git a/src/physics/spcam/ecpp/module_data_ecpp1.F90 b/src/physics/spcam/ecpp/module_data_ecpp1.F90 deleted file mode 100644 index 3c64e259b7..0000000000 --- a/src/physics/spcam/ecpp/module_data_ecpp1.F90 +++ /dev/null @@ -1,229 +0,0 @@ -! file module_data_ecpp1.F -!----------------------------------------------------------------------- - - module module_data_ecpp1 - - use shr_kind_mod, only: r8=>shr_kind_r8 - -! integer, parameter :: r4=4 -! integer, parameter :: r8=8 - - -! following are used to dimension several arrays -! declared in module_ecpp_ppdriver.F with "save" -! in mmf framework, these arrays will be subr parameters -! in wrf-chem framework, doing this is just too much trouble -! because of registry limitations - integer, parameter :: its_ecpptmp=1 - integer, parameter :: ite_ecpptmp=1 - integer, parameter :: jts_ecpptmp=1 - integer, parameter :: jte_ecpptmp=1 - integer, parameter :: kts_ecpptmp=1 - integer, parameter :: kte_ecpptmp=51 - integer, parameter :: ktebnd_ecpptmp=kte_ecpptmp - integer, parameter :: ktecen_ecpptmp=kte_ecpptmp-1 - integer, parameter :: num_chem_ecpptmp=101 - - -! maximum number of ecpp transport classes, used for dimensioning various arrays - integer, parameter :: maxcls_ecpp=3 - integer, parameter :: maxsub_ecpp=maxcls_ecpp - -! maximum number of "precipitation types" for wetscav diagnostics -! currently this is 1 -! the wetscav diagnostics are done for each subarea type, so -! have info on where (up, down, quiescent) the scavenging happens. -! however, they do no account for the fact that precip formed -! in updraft can fall (or shift) into quiescent, etc. -! eventually it might be 2, so would have diagnostics involving -! where precip is formed -- quiescent versus (convective) up/downdrafts) - integer, parameter :: max_wetdiagtype = 1 - -! set this to .false. for cam3-mmf - logical, parameter :: hostcode_is_wrfchem = .false. - - -! these are possible values for mtype_updnenv_ecpp_3d & ..._clm3d & ..._clm3d & ..._clm - integer, parameter :: mtype_updraft_ecpp=1 - integer, parameter :: mtype_dndraft_ecpp=2 - integer, parameter :: mtype_quiescn_ecpp=3 - integer, parameter :: mtype_upempty_ecpp=-1 - integer, parameter :: mtype_dnempty_ecpp=-2 - integer, parameter :: mtype_quempty_ecpp=-3 - -! these are possible values for mtype_clrcldy_ecpp_3d & ..._clm3d & ..._clm3d & ..._clm - integer, parameter :: mtype_iscloud_ecpp=11 - integer, parameter :: mtype_nocloud_ecpp=0 - -! these are possible values for mtype_precip_ecpp_3d & ..._clm3d & ..._clm3d & ..._clm - integer, parameter :: mtype_isprecip_ecpp=21 - integer, parameter :: mtype_noprecip_ecpp=0 - - -! this flag determines whether updraft & dndraft profiles are calculated -! using the "primed" mass fluxes or "full" mass fluxes - integer, save :: ppopt_updn_prof_aa -! these are possible values for the flag - integer, parameter :: ppopt_updn_prof_aa_wfull=2001 - integer, parameter :: ppopt_updn_prof_aa_wprime=2002 - - -! this flag determines whether quiescent subarea mass fluxes are -! provided by the host or calculated in the ppm - integer, save :: ppopt_quiescn_mf - integer, parameter :: ppopt_quiescn_mf_byhost=2101 -! these are possible values for the flag - integer, parameter :: ppopt_quiescn_mf_byppmx1=2101 - - -! this flag determines how the quiescent subarea mixing ratios -! are obtained for source-sink calculations - integer, save :: ppopt_quiescn_sosi -! these are possible values for the flag -! 2201 -- qe = qbar - integer, parameter :: ppopt_quiescn_sosi_x1=2201 -! 2202 -- ae*qe = max( 0.0, (qbar-au*qu-ad*qd) ) - integer, parameter :: ppopt_quiescn_sosi_x2=2202 - - -! this flag determines how the subgrid vertical fluxes (and the -! finite differencing for flux divergence) is calculated - integer, save :: ppopt_chemtend_wq -! these are possible values for the flag -! 2301 -- vertflux = mu*qu + md*qd - (mu+md)*qbar; -! upstream approach for qbar at layer boundaries - integer, parameter :: ppopt_chemtend_wq_wfullx1=2301 -! 2302 -- vertflux = mu'*qu + md'*qd - (mu'+md')*qbar; -! upstream approach for qbar at layer boundaries - integer, parameter :: ppopt_chemtend_wq_wprimex1=2302 - - -! this flag determines how the sub-time-step for integrating the -! d(qbar)/dt equation is determined -! (use sub-timesteps to keep courant number < 1 and -! avoid negative mixing ratios) - integer, save :: ppopt_chemtend_dtsub -! these are possible values for the flag - integer, parameter :: ppopt_chemtend_dtsub_x1=2401 -! 2401 -- dumcournomax = max( dumcourentmax, dumcouroutbmax ) - integer, parameter :: ppopt_chemtend_dtsub_x2=2402 -! 2402 -- dumcournomax = max( dumcourentmax, dumcouroutamax, -! dumcouroutbmax ) - integer, parameter :: ppopt_chemtend_dtsub_x3=2403 -! 2403 -- dtstep_sub = largest value that does not produce -! negative mixing ratios - - -! this flag determines how frequently xxx -! is called to calculate up & dndraft profiles and source/sinks - integer, save :: ppopt_chemtend_updnfreq -! these are possible values for the flag - integer, parameter :: ppopt_chemtend_updnfreq_x1=2501 -! 2501 -- called just once, when istep_sub=1 - integer, parameter :: ppopt_chemtend_updnfreq_x2=2502 -! 2502 -- called for each istep_sub - - - integer, parameter :: lunout = 0 - - -! index of quiescent transport class - integer, parameter :: jcls_quiescn = 1 - integer, parameter :: jcls_qu = jcls_quiescn - - -! subarea-average vertical mass fluxes (kg/m2/s) smaller than this -! are treated as zero -! largest expected flux is ~1 (rho=1, w=10, afrac=0.1) -! so could expect truncation errors between 1e-7 and 1e-6 - real(r8), parameter :: mf_smallaa = 1.0e-6_r8 - - -! subarea-average vertical mass fluxes (kg/m2/s) smaller than -! aw_draft_cut*rho are treated as zero -! note that with a*w = 1e-4 m/s, dz over 1 day = 8.6 m which -! is small -! real(r8), parameter :: aw_draft_cut = 1.0e-4_r8 ! m/s -!! maximum expected updraft -! real(r8), parameter :: w_draft_max = 50.0_r8 ! m/s -!! fractional areas below afrac_cut are ignored -! real(r8), parameter :: afrac_cut = aw_draft_cut/w_draft_max -! real(r8), parameter :: afrac_cut_bb = afrac_cut*0.5_r8 -! real(r8), parameter :: afrac_cut_0p5 = afrac_cut*0.5_r8 -! real(r8), parameter :: afrac_cut_0p2 = afrac_cut*0.2_r8 -! real(r8), parameter :: afrac_cut_0p1 = afrac_cut*0.1_r8 - - real(r8), save :: aw_draft_cut = 1.0e-4_r8 ! m/s -! maximum expected updraft - real(r8), save :: w_draft_max = 50.0_r8 ! m/s -! fractional areas below afrac_cut are ignored - real(r8), save :: afrac_cut - real(r8), save :: afrac_cut_bb, afrac_cut_0p5, afrac_cut_0p2, afrac_cut_0p1 - - -! draft lifetime (s) - real(r8), save :: draft_lifetime - -! activat_onoff_ecpp - if positive, do aerosol activation in ecpp -! (set to +1 for normal runs) - integer, save :: activat_onoff_ecpp - -! cldchem_onoff_ecpp - if positive, do aerosol activation in ecpp -! (set to +1 for normal runs) - integer, save :: cldchem_onoff_ecpp - -! rename_onoff_ecpp - if positive, do aerosol activation in ecpp -! (set to +1 for normal runs) - integer, save :: rename_onoff_ecpp - -! wetscav_onoff_ecpp - if positive, do aerosol activation in ecpp -! (set to +1 for normal runs) - integer, save :: wetscav_onoff_ecpp - -! iflag_ecpp_startup_acw_partition - when positive, do -! "special partitioning" of cloudborne and interstitial aerosol to -! clear and cloudy subareas (cloudy gets less interstitial than clear) -! in subr parampollu_tdx_startup -! for normal runs, set this to +1 - integer, save :: iflag_ecpp_startup_acw_partition - -! iflag_ecpp_startup_host_chemtend - when positive, apply -! host changes to chem mixing ratios (e.g., emissions, gas chem) -! in subr parampollu_tdx_startup -! for normal runs, set this to +1 - integer, save :: iflag_ecpp_startup_host_chemtend - -! iflag_ecpp_test_bypass_1 used for early testing - -! when positive, bypass the parampollu_td--- routine -! for normal runs, set this to 0 - integer, save :: iflag_ecpp_test_bypass_1 - -! iflag_ecpp_test_fixed_fcloud used for (early) testing with various fixed cloud fracs -! for normal runs, set this to zero - integer, save :: iflag_ecpp_test_fixed_fcloud - -! "method" flag for parameterized-pollutants module -! (set to +2223 for normal runs and in mmf) - integer, save :: parampollu_opt - -! minimum fractional area for total quiescent class - real(r8), save :: a_quiescn_minaa = 0.60_r8 ! min area for initial total quiescent - real(r8), save :: a_quiescn_minbb = 0.30_r8 ! min area for final total quiescent - - - integer, save :: num_chem_ecpp, param_first_ecpp - - integer, save :: num_chem - integer, save :: p_qc - integer, save :: p_qv - - integer, save :: p_num_a01, p_num_cw01, p_oin_a01, p_oin_cw01, & - p_num_a03, p_num_cw03, p_oin_a03, p_oin_cw03 - -! time step for the ECPP -! It is fixed to be 1800 s. The GCM time step can be less than 1800s. -! For example, if GCM time step is 600s, ECPP will be called at every third GCM time step - real(r8), parameter :: dtstep_pp_input = 1800.0_r8 - - end module module_data_ecpp1 - diff --git a/src/physics/spcam/ecpp/module_data_mosaic_asect.F90 b/src/physics/spcam/ecpp/module_data_mosaic_asect.F90 deleted file mode 100644 index e07cb29f44..0000000000 --- a/src/physics/spcam/ecpp/module_data_mosaic_asect.F90 +++ /dev/null @@ -1,131 +0,0 @@ -!********************************************************************************** -! This computer software was prepared by Battelle Memorial Institute, hereinafter -! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of -! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, -! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. -! -! MOSAIC module: see module_mosaic_driver.F for information and terms of use -!********************************************************************************** - module module_data_mosaic_asect - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - - -!----------------------------------------------------------------------- -! -! The variables in this module provide a means of organizing and accessing -! aerosol species in the "chem" array by their chemical component, -! size bin (or mode), "type", and "phase" -! -! Their purpose is to allow flexible coding of process modules, -! compared to "hard-coding" using the chem array p_xxx indices -! (e.g., p_so4_a01, p_so4_a02, ...; p_num_a01, ...) -! -!----------------------------------------------------------------------- -! -! rce & sg 2004-dec-03 - added phase and type capability, -! which changed this module almost completely -! -!----------------------------------------------------------------------- -! -! maxd_atype = maximum allowable number of aerosol types -! maxd_asize = maximum allowable number of aerosol size bins -! maxd_acomp = maximum allowable number of chemical components -! in each aerosol size bin -! maxd_aphase = maximum allowable number of aerosol phases -! (gas, cloud, ice, rain, ...) -! -! ntype_aer = number of aerosol types -! The aerosol type will allow treatment of an externally mixed -! aerosol. The current MOSAIC code has only 1 type, with the implicit -! assumption of internal mixing. Eventually, multiple types -! could treat fresh primary BC/OC, fresh SO4 from nucleation, -! aged BC/OC/SO4/... mixture, soil dust, sea salt, ... -! -! nphase_aer = number of aerosol phases -! -! ai_phase = phase (p) index for interstitial (unactivated) aerosol particles -! cw_phase = phase (p) index for aerosol particles in cloud water -! ci_phase = phase (p) index for aerosol particles in cloud ice -! rn_phase = phase (p) index for aerosol particles in rain -! sn_phase = phase (p) index for aerosol particles in snow -! gr_phase = phase (p) index for aerosol particles in graupel -! [Note: the value of "xx_phase" will be between 1 and nphase_aer -! for phases that are active in a simulation. The others -! will have non-positive values.] -! -! nsize_aer(t) = number of aerosol size bins for aerosol type t -! -! ncomp_aer(t) = number of "regular" chemical components for aerosol type t -! -! massptr_aer(c,s,t,p) = the position/index in the chem array for mixing- -! ratio for chemical component c, size bin s, type t, and phase p. -! -! numptr_aer(s,t,p) = the position/index in the chem array for mixing- -! ratio of particle number for size bin s, type t, and phase p. -! -!----------------------------------------------------------------------- -! -! dens_aer(c,t) = dry density (g/cm^3) of aerosol chemical component -! c of type t -! [Note: dens_aer(c,t) == dens_mastercomp_aer(mastercompptr_aer(c,t)) -! The dens_mastercomp_aer is used in some initialization routines. -! The dens_aer is used in most other places because of convenience.] -! -!----------------------------------------------------------------------- -! -! volumlo_sect(s,t) = 1-particle volume (cm^3) at lower boundary of section m -! volumhi_sect(s,t) = 1-particle volume (cm^3) at upper boundary of section m -! volumcen_sect(s,t)= 1-particle volume (cm^3) at "center" of section m -! -! [Note: the "center" values are defined as follows: -! volumcen_sect == 0.5*(volumlo_sect + volumhi_sect) -! == (pi/6) * (dcen_sect**3) ] -! -! -!----------------------------------------------------------------------- - - integer, save :: maxd_atype = 0 - integer, save :: maxd_asize = 0 - integer, save :: maxd_acomp = 0 - integer, save :: maxd_aphase = 0 - - integer, save :: ai_phase = -999888777 - integer, save :: cw_phase = -999888777 -! integer, save :: ci_phase = -999888777 -! integer, save :: rn_phase = -999888777 -! integer, save :: sn_phase = -999888777 -! integer, save :: gr_phase = -999888777 - - integer, save :: ntype_aer = 0 ! number of types - integer, save :: nphase_aer = 0 ! number of phases - - integer, allocatable :: & - nsize_aer (:), & ! number of size bins - ncomp_aer (:), & ! number of chemical components - massptr_aer( :, :, :, :), & - ! index for mixing ratio - numptr_aer( :, :, :) ! index for the number mixing ratio - - real(r8), allocatable :: dens_aer(:,:) ! aerosol density - real(r8), allocatable :: hygro_aer(:,:) ! hygroscopicity - real(r8), allocatable :: sigmag_aer(:,:) ! geometric standard deviation for aerosol - -! added by Yang Zhang - real(r8), allocatable :: & - volumhi_sect(:,:), & - volumlo_sect(:,:), & - dcen_sect(:,:), & - dlo_sect(:,:), & - dhi_sect(:,:) - -! flag for aerosols +++mhwang - logical, allocatable :: is_aerosol(:) ! true if field is aerosol (any phase) - - integer, allocatable :: & - iphase_of_aerosol(:), isize_of_aerosol(:), itype_of_aerosol(:), & - inmw_of_aerosol(:), laicwpair_of_aerosol(:) - - end module module_data_mosaic_asect diff --git a/src/physics/spcam/ecpp/module_data_radm2.F90 b/src/physics/spcam/ecpp/module_data_radm2.F90 deleted file mode 100644 index 7408bc7249..0000000000 --- a/src/physics/spcam/ecpp/module_data_radm2.F90 +++ /dev/null @@ -1,178 +0,0 @@ -!WRF:MODEL_LAYER:CHEMICS -! - MODULE module_data_radm2 - - use shr_kind_mod, only: r8 => shr_kind_r8 - - IMPLICIT NONE -! REAL(r8), PARAMETER :: epsilc = 1.E-16_r8 - REAL(r8), PARAMETER :: epsilc = 1.E-12_r8 - -!--- for radm solver -! .. Parameters .. - INTEGER, PARAMETER :: ldiag = 18, lpred = 39, lss = 2, & - lump = 4, naqre = 70, nreacj = 21, nreack = 140, & - ntroe = 7, numchem_radm = 41 - INTEGER, PARAMETER :: lspec = lpred + lss - INTEGER, DIMENSION(1:NTROE) :: itroe = (/11, 22, 10, 15, 21, 24, 28/) -! -! -! - INTEGER, PARAMETER :: lso2=1 - INTEGER, PARAMETER :: lsulf=2 - INTEGER, PARAMETER :: lno2=3 - INTEGER, PARAMETER :: lno=4 - INTEGER, PARAMETER :: lo3=5 - INTEGER, PARAMETER :: lhno3=6 - INTEGER, PARAMETER :: lh2o2=7 - INTEGER, PARAMETER :: lald=8 - INTEGER, PARAMETER :: lhcho=9 - INTEGER, PARAMETER :: lop1=10 - INTEGER, PARAMETER :: lop2=11 - INTEGER, PARAMETER :: lpaa=12 - INTEGER, PARAMETER :: lora1=13 - - INTEGER, PARAMETER :: lora2=14 - INTEGER, PARAMETER :: lnh3=15 - INTEGER, PARAMETER :: ln2o5=16 - INTEGER, PARAMETER :: lno3=17 - INTEGER, PARAMETER :: lpan=18 - INTEGER, PARAMETER :: lhc3=19 - INTEGER, PARAMETER :: lhc5=20 - INTEGER, PARAMETER :: lhc8=21 - - INTEGER, PARAMETER :: leth=22 - INTEGER, PARAMETER :: lco=23 - INTEGER, PARAMETER :: lol2=24 - INTEGER, PARAMETER :: lolt=25 - INTEGER, PARAMETER :: loli=26 - INTEGER, PARAMETER :: ltol=27 - INTEGER, PARAMETER :: lxyl=28 - INTEGER, PARAMETER :: laco3=29 - - INTEGER, PARAMETER :: ltpan=30 - INTEGER, PARAMETER :: lhono=31 - INTEGER, PARAMETER :: lhno4=32 - INTEGER, PARAMETER :: lket=33 - INTEGER, PARAMETER :: lgly=34 - INTEGER, PARAMETER :: lmgly=35 - INTEGER, PARAMETER :: ldcb=36 - INTEGER, PARAMETER :: lonit=37 - - INTEGER, PARAMETER :: lcsl=38 - INTEGER, PARAMETER :: liso=39 - INTEGER, PARAMETER :: lho=40 - INTEGER, PARAMETER :: lho2=41 -! parameters for timestep, integration - INTEGER, DIMENSION(1:lpred) :: intgrt = (/1, 1, 1, 0, 1, & - 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, & - 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1 /) -! INTEGER, DIMENSION(1:lspec) :: qdtc = (/0, 0, 1, 0, 1, & -! 0, 1, 0, 1, 0, 0, 0, 1, 0, 0, & -! 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, & -! 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, & -! 0, 0, 0, 0, 0, 0 /) - INTEGER, DIMENSION(1:lspec) :: qdtc = (/1, 1, 1, 0, 1, & - 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, & - 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 0, 0 /) -! max, min values, - INTEGER :: itrdu -! - REAL(r8), DIMENSION(1:lspec) :: cmin =(/(1.E-16_r8,itrdu=1,lspec)/) -! - REAL(r8), DIMENSION(1:lspec) :: cmax=(/1._r8, 1._r8, 1._r8, 1._r8, .2_r8, & - 3._r8, .05_r8, .01_r8, .01_r8, .01_r8, .05_r8, .01_r8, .05_r8, .05_r8,.05_r8, & - 1._r8, 1._r8, 1._r8, 1._r8, 1._r8, 1._r8, 1._r8, 1._r8, 1._r8, 1._r8, & - 1._r8, 1._r8, 1._r8, 1._r8, 1._r8, 1._r8, 1._r8, 1._r8,.0001_r8, .1_r8, & - 1._r8, .001_r8, .01_r8, .01_r8, .01_r8, .01_r8/) - -! -! -! - INTEGER, PARAMETER :: lo3p=1 - INTEGER, PARAMETER :: lo1d=2 - INTEGER, PARAMETER :: ltco3=3 - INTEGER, PARAMETER :: lhc3p=4 - INTEGER, PARAMETER :: lhc5p=5 - INTEGER, PARAMETER :: lhc8p=6 - - INTEGER, PARAMETER :: lol2p=7 - INTEGER, PARAMETER :: loltp=8 - INTEGER, PARAMETER :: lolip=9 - INTEGER, PARAMETER :: ltolp=10 - INTEGER, PARAMETER :: lxylp=11 - INTEGER, PARAMETER :: lethp=12 - INTEGER, PARAMETER :: lketp=13 - INTEGER, PARAMETER :: loln=14 - - INTEGER, PARAMETER :: lxo2=15 - INTEGER, PARAMETER :: lxno2=16 - INTEGER, PARAMETER :: lxho=17 - INTEGER, PARAMETER :: lmo2=18 -! -! - INTEGER, PARAMETER :: lnox=1 - INTEGER, PARAMETER :: lhox=2 - INTEGER, PARAMETER :: lpao3=3 - INTEGER, PARAMETER :: ln2n3=4 -! .. - REAL(r8), PARAMETER :: ch4=1.7_r8 - REAL(r8), PARAMETER :: co2=350._r8 - REAL(r8), PARAMETER :: n2=7.81E5_r8 - REAL(r8), PARAMETER :: o2=2.09E5_r8 - REAL(r8), PARAMETER :: pi=3.141592654_r8 - -! .. - REAL(r8) :: afac(2), & - bfac(2), const(3), eor(nreack), & - thafac(nreack), & - xk0300(ntroe), & - xkf300(ntroe), xmtroe(ntroe), xntroe(ntroe) - -! .. -! .. Data Statements .. - DATA thafac/0.00_r8, 6.50E-12_r8, 1.80E-11_r8, 3.20E-11_r8, 2.20E-10_r8, 2.00E-12_r8, & - 1.60E-12_r8, 1.10E-14_r8, 3.70E-12_r8, 4*0.00_r8, 3.30E-12_r8, 0.00_r8, 3.30E-19_r8, & - 1.40E-13_r8, 1.70E-11_r8, 2.50E-14_r8, 2.50E-12_r8, 2*0.00_r8, 2.00E-21_r8, 2*0.00_r8, & - 1.30E-12_r8, 4.60E-11_r8, 2*0.00_r8, 6.95E-18_r8, 1.37E-17_r8, 1.59E-11_r8, 1.73E-11_r8, & - 3.64E-11_r8, 2.15E-12_r8, 5.32E-12_r8, 1.07E-11_r8, 2.10E-12_r8, 1.89E-11_r8, 4.00E-11_r8, & - 9.00E-12_r8, 6.87E-12_r8, 1.20E-11_r8, 1.15E-11_r8, 1.70E-11_r8, 2.80E-11_r8, 1.00E-11_r8, & - 1.00E-11_r8, 1.00E-11_r8, 6.85E-18_r8, 1.55E-11_r8, 2.55E-11_r8, 2.80E-12_r8, 1.95E+16_r8, & - 4.70E-12_r8, 1.95E+16_r8, 4.20E-12_r8, 4.20E-12_r8, 0.00_r8, 4.20E-12_r8, 0.00_r8, & - 4.20E-12_r8, 0.00_r8, 10*4.20E-12_r8, 6.00E-13_r8, 1.40E-12_r8, 6.00E-13_r8, 1.40E-12_r8, & - 1.40E-12_r8, 2.20E-11_r8, 2.00E-12_r8, 1.00E-11_r8, 3.23E-11_r8, 5.81E-13_r8, 1.20E-14_r8, & - 1.32E-14_r8, 7.29E-15_r8, 1.23E-14_r8, 14*7.70E-14_r8, 1.90E-13_r8, 1.40E-13_r8, & - 4.20E-14_r8, 3.40E-14_r8, 2.90E-14_r8, 1.40E-13_r8, 1.40E-13_r8, 1.70E-14_r8, 1.70E-14_r8, & - 9.60E-13_r8, 1.70E-14_r8, 1.70E-14_r8, 9.60E-13_r8, 3.40E-13_r8, 1.00E-13_r8, 8.40E-14_r8, & - 7.20E-14_r8, 3.40E-13_r8, 3.40E-13_r8, 4.20E-14_r8, 4.20E-14_r8, 1.19E-12_r8, 4.20E-14_r8, & - 4.20E-14_r8, 1.19E-12_r8, 7.70E-14_r8, 1.70E-14_r8, 4.20E-14_r8, 3.60E-16_r8, 4.20E-12_r8, & - 4.20E-12_r8, 7.70E-14_r8, 1.70E-14_r8, 4.20E-14_r8, 3.60E-16_r8, 0.00_r8, 1.70E-14_r8, & - 4.20E-14_r8, 3.60E-16_r8/ -! .. -! constants for RADM2 rate coefficients - DATA eor/0._r8, -120._r8, -110._r8, -70._r8, 0._r8, 1400._r8, 940._r8, 500._r8, -240._r8, 0._r8, 0._r8, & - 0._r8, 0._r8, 200._r8, 0._r8, -530._r8, 2500._r8, -150._r8, 1230._r8, 0._r8, 0._r8, 0._r8, 0._r8, 0._r8, 0._r8, & - -380._r8, -230._r8, 0._r8, 0._r8, 1280._r8, 444._r8, 540._r8, 380._r8, 380._r8, -411._r8, -504._r8, & - -549._r8, -322._r8, -116._r8, 0._r8, 0._r8, -256._r8, 745._r8, 0._r8, 0._r8, 0._r8, 0._r8, 0._r8, 0._r8, & - 444._r8, 540._r8, -409._r8, -181._r8, 13543._r8, 0._r8, 13543._r8, -180._r8, -180._r8, 0._r8, -180._r8, & - 0._r8, -180._r8, 0._r8, -180._r8, -180._r8, -180._r8, -180._r8, -180._r8, -180._r8, -180._r8, -180._r8, & - -180._r8, -180._r8, 2058._r8, 1900._r8, 2058._r8, 1900._r8, 1900._r8, 0._r8, 2923._r8, 1895._r8, & - 975._r8, 0._r8, 2633._r8, 2105._r8, 1136._r8, 2013._r8, -1300._r8, -1300._r8, -1300._r8, -1300._r8, & - -1300._r8, -1300._r8, -1300._r8, -1300._r8, -1300._r8, -1300._r8, -1300._r8, -1300._r8, & - -1300._r8, -1300._r8, 25* -220._r8, -1300._r8, -220._r8, -220._r8, -220._r8, -180._r8, -180._r8, & - -1300._r8, -220._r8, -220._r8, 0._r8, 0._r8, -220._r8, -220._r8, -220._r8/ - - DATA xk0300/1.8E-31_r8, 2.2E-30_r8, 1.8E-31_r8, 7.E-31_r8, 2.2E-30_r8, 2.6E-30_r8, 3.E-31_r8/ - DATA xntroe/3.2_r8, 4.3_r8, 3.2_r8, 2.6_r8, 4.3_r8, 3.2_r8, 3.3_r8/ - DATA xkf300/4.7E-12_r8, 1.5E-12_r8, 4.7E-12_r8, 1.5E-11_r8, 1.5E-12_r8, 2.4E-11_r8, & - 1.5E-12_r8/ - DATA xmtroe/1.4_r8, 0.5_r8, 1.4_r8, 2*.5_r8, 1.3_r8, 0._r8/ - DATA afac/2.1E-27_r8, 1.1E-27_r8/ - DATA bfac/10900._r8, 11200._r8/ - DATA const/7.34E21_r8, 4.4E17_r8, 3.23E33_r8/ - - END MODULE module_data_radm2 diff --git a/src/physics/spcam/ecpp/module_ecpp_ppdriver2.F90 b/src/physics/spcam/ecpp/module_ecpp_ppdriver2.F90 deleted file mode 100644 index 4e2a52f86a..0000000000 --- a/src/physics/spcam/ecpp/module_ecpp_ppdriver2.F90 +++ /dev/null @@ -1,1436 +0,0 @@ -module module_ecpp_ppdriver2 - -!------------------------------------------------------------------------------------- -! Purpose: -! Provide the CAM interface to the Explicit-Cloud Parameterized-Pollutant hygrid -! approach for aerosol-cloud interactions in the MMF models. -! -! This module was adopted from the one written for the WRF-chem by Dick Easter. -! -! Minghuai Wang (Minghuai.Wang@pnl.gov), 2009-11 -!--------------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8=>shr_kind_r8 - use ppgrid, only: pcols, pver, pverp - use constituents, only: pcnst, cnst_name, cnst_species_class, cnst_spec_class_aerosol, cnst_spec_class_gas - use crmclouds_camaerosols, only: ecpp_mixnuc_tend => crmclouds_mixnuc_tend - use cam_abortutils, only: endrun - - use crmx_ecppvars, only: nupdraft_in, ndndraft_in, ncls_ecpp_in, ncc_in, nprcp_in - use module_data_ecpp1 - use module_data_mosaic_asect - - use modal_aerosol_properties_mod, only: modal_aerosol_properties - - implicit none - - public :: parampollu_driver2 - public :: papampollu_init - public :: ecpp_mixnuc_tend - -!+++mhwang follow what done in ndrop.F90. this is for qqcw -! ptr2d_t is used to create arrays of pointers to 2D fields -type ptr2d_t - real(r8), pointer :: fldcw(:,:) -end type ptr2d_t - - contains - -!----------------------------------------------------------------------------------------------- -! -! rce 2005-mar-10 - created -! -!------------------------------------------------------------------------------------------------ - subroutine papampollu_init ( ) -!------------------------------------------------------------------------------------------------ -! -! initialize some data used in ECPP, and map aerosol inforation in cam4 into mosaic. -! -! Minghuai Wang, 2009-11 -!------------------------------------------------------------------------------------------------- - use cam_history, only: addfld, add_default, horiz_only - use modal_aero_data - use module_ecpp_td2clm, only: set_of_aerosol_stuff - use module_ecpp_util, only: parampollu_1clm_set_opts - use phys_control, only: phys_getopts - -! Local variables - integer :: n, ll - integer :: ichem, ichem2 - real(r8) :: pi - real(r8) :: tmpa - logical :: history_aerosol - -! get history_aerosol - call phys_getopts(history_aerosol_out = history_aerosol) - -! calculate pi - pi = 4._r8*atan(1._r8) - -! -! set pp options (should this be done from driver?) -! - - num_chem_ecpp = 2* pcnst - num_chem = num_chem_ecpp - param_first_ecpp = 1 ! set to 1 as this can change - p_qv = 1 - p_qc = 2 - - allocate (is_aerosol(1:num_chem_ecpp)) - allocate (iphase_of_aerosol(1:num_chem_ecpp)) - allocate (isize_of_aerosol(1:num_chem_ecpp)) - allocate (itype_of_aerosol(1:num_chem_ecpp)) - allocate (inmw_of_aerosol(1:num_chem_ecpp)) - allocate (laicwpair_of_aerosol(1:num_chem_ecpp)) - -! -! Map the modal aerosol information in modal_aero_data.F90 to module_data_mosaic_asect.F90 -! In the ECPP written for the WRF-chem, it used the MOSAIC aerosol data. MOSAIC have different -! classifications, and use aeroso types, aerosol size bins, chemical components, and aerosol phases -! to describe aerosols. In the CAM4's modal aerosol treatment, it use aerosol modes, and chemical -! components to describe aerosols, and interstial and cloud-borne aerosols are separately tracked. -! When the ECPP codes are ported from the WRF-chem into the MMF model (CAM4.0_SAM), -! the MOSAIC's description of the aerosols are kept, in order to minimize -! the codes changes, but the aerosol information in CAM4.0 is mapped into the MOSAIC one in the -! following way: aeroso type is equivalent to aerosol modes in CAM4, and aerosol size is one for each aerosol type, -! and the aerosol chemical composition is just the same as that in CAM4. Interstitial aerosols in CAM4 is put into -! the phase 1, and cloud-borne aerosol in CAM4 is put into the pase 2. -Minghuai Wang (minghuai.wang@pnl.gov) -! - maxd_atype = ntot_amode - maxd_asize = 1 - maxd_acomp = nspec_max - maxd_aphase = 2 - - ai_phase = 1 ! index for interstial aerosols - cw_phase = 2 ! index for cloud-borne aerosols - - ntype_aer = ntot_amode - nphase_aer = 2 - - allocate (nsize_aer( 1:maxd_atype )) - allocate (ncomp_aer( 1:maxd_atype )) - allocate (massptr_aer( 1:maxd_acomp, 1:maxd_asize, 1:maxd_atype, 1:maxd_aphase )) - allocate (numptr_aer( 1:maxd_asize, 1:maxd_atype, 1:maxd_aphase )) - allocate (dens_aer( 1:maxd_acomp, 1:maxd_atype )) - allocate (hygro_aer( 1:maxd_acomp, 1:maxd_atype )) - allocate (volumhi_sect( 1:maxd_asize, 1:maxd_atype )) - allocate (volumlo_sect( 1:maxd_asize, 1:maxd_atype )) - allocate (sigmag_aer( 1:maxd_asize, 1:maxd_atype )) - allocate (dcen_sect(1:maxd_asize, 1:maxd_atype )) - allocate (dlo_sect(1:maxd_asize, 1:maxd_atype )) - allocate (dhi_sect(1:maxd_asize, 1:maxd_atype )) - - - nsize_aer(1:maxd_atype) = 1 - ncomp_aer(1:maxd_atype) = nspec_amode(1:ntot_amode) - - massptr_aer(1:maxd_acomp, 1, 1:maxd_atype, 1) = lmassptr_amode(1:nspec_max, 1:ntot_amode) - massptr_aer(1:maxd_acomp, 1, 1:maxd_atype, 2) = lmassptrcw_amode(1:nspec_max, 1:ntot_amode) + pcnst - - numptr_aer(1, 1:maxd_atype, 1) = numptr_amode(1:ntot_amode) - numptr_aer(1, 1:maxd_atype, 2) = numptrcw_amode(1:ntot_amode) + pcnst - - do n=1, ntype_aer - do ll=1, ncomp_aer(n) - dens_aer(ll, n) = specdens_amode(ll, n) - hygro_aer(ll, n) = spechygro(ll, n) - end do - - sigmag_aer(1, n) = sigmag_amode(n) - -! Notes: -! the tmpa factor is because -! dcen_sect, dlo_sect, dhi_sect are used as, -! and are compared to, volume-mean diameters -! dgnum_amode, dgnumlo_amode, dgnumhi_amode are used as, -! and are compared to, number-distribution geometric-mean diameters -! volume_mixing_ratio/(number_mixing_ratio*pi/6) -! = volume_mean_diameter**3 -! = (number_geometric_mean_diameter*tmpa)**3 - - tmpa = exp( 1.5_r8 * log(sigmag_amode(n))**2 ) - dcen_sect(1, n) = dgnum_amode(n)*tmpa - dlo_sect( 1, n) = dgnumlo_amode(n)*tmpa - dhi_sect( 1, n) = dgnumhi_amode(n)*tmpa - - volumlo_sect(1, n) = pi/6 * (dgnumlo_amode(n)*tmpa)**3 - volumhi_sect(1, n) = pi/6 * (dgnumhi_amode(n)*tmpa)**3 - end do - - afrac_cut = aw_draft_cut/w_draft_max - afrac_cut_bb = afrac_cut*0.5_r8 - afrac_cut_0p5 = afrac_cut*0.5_r8 - afrac_cut_0p2 = afrac_cut*0.2_r8 - afrac_cut_0p1 = afrac_cut*0.1_r8 - -! set flags - activat_onoff_ecpp = 1 ! droplet activation; 1 turns on activation - cldchem_onoff_ecpp = 1 ! cloud chemistry - rename_onoff_ecpp = 1 ! renaming (modal merging) - - wetscav_onoff_ecpp = 400 ! wet removable 400 turn on wet scaving - -! set convection lifetime - draft_lifetime = 7200 ! seconds, 2 hours lifetime for the momement - -! set flag for a/c partition - iflag_ecpp_startup_acw_partition = 1 ! 1 to turn on a/c parition - -! set flag for whether update changs from host codes - iflag_ecpp_startup_host_chemtend = 0 - -! set other flags - iflag_ecpp_test_bypass_1 = 0 - iflag_ecpp_test_fixed_fcloud = 0 - - parampollu_opt = 2223 ! method flag for parameterized-pollutants module - -! -! set pp options (should this be done from driver?) -! - call parampollu_1clm_set_opts( & - ppopt_updn_prof_aa_wfull, & - ppopt_quiescn_mf_byppmx1, & - ppopt_quiescn_sosi_x1, & - ppopt_chemtend_wq_wfullx1, & - ppopt_chemtend_dtsub_x1, & - ppopt_chemtend_updnfreq_x1 ) - -! -! some other initialization -! - call set_of_aerosol_stuff(is_aerosol, & - iphase_of_aerosol, isize_of_aerosol, itype_of_aerosol, & - inmw_of_aerosol, laicwpair_of_aerosol ) - -! add fields into history file - do ichem=param_first_ecpp, pcnst - if ((cnst_species_class(ichem) == cnst_spec_class_aerosol) .or. & - (cnst_species_class(ichem) == cnst_spec_class_gas )) then - if(trim(cnst_name(ichem))//'EP' == 'EP') then - write(0, *) ichem, trim(cnst_name(ichem))//'EP' - call endrun('ecpp init1') - end if - call addfld(trim(cnst_name(ichem))//'EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name(ichem))//' tendency from ECPP' ) - call addfld(trim(cnst_name(ichem))//'ACHEM_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name(ichem))//' tendency from aqueous chemistry in ECPP' ) - call addfld(trim(cnst_name(ichem))//'RENM_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name(ichem))//' tendency from renaming in ECPP' ) - call addfld(trim(cnst_name(ichem))//'ACT_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name(ichem))//' tendency from activation/resuspension in ECPP' ) - call addfld(trim(cnst_name(ichem))//'WET_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name(ichem))//' tendency from wet removable in ECPP' ) - call addfld(trim(cnst_name(ichem))//'WRESU_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name(ichem))//' tendency from resuspension in wet removable in ECPP') - call addfld(trim(cnst_name(ichem))//'CONV_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name(ichem))//' tendency from convective tansport in ECPP') - - call addfld(trim(cnst_name(ichem))//'SFEP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from ECPP' ) - call addfld(trim(cnst_name(ichem))//'SFACHEM_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from aqueus chemistry in ECPP' ) - call addfld(trim(cnst_name(ichem))//'SFRENM_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from renaming in ECPP' ) - call addfld(trim(cnst_name(ichem))//'SFACT_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from activation/resuspension ECPP' ) - call addfld(trim(cnst_name(ichem))//'SFWET_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from wet removable in ECPP' ) - call addfld(trim(cnst_name(ichem))//'SFWRESU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from resupspension in wet removable in ECPP' ) - call addfld(trim(cnst_name(ichem))//'SFCONV_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from convective transport in ECPP' ) - -! Quiescent class - call addfld(trim(cnst_name(ichem))//'SFACHQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from aqueus chemistry in ECPP (quiescent)' ) - call addfld(trim(cnst_name(ichem))//'SFREMQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from renaming in ECPP (quiescent)' ) - call addfld(trim(cnst_name(ichem))//'SFACTQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from activation/resuspension ECPP (quiescent)' ) - call addfld(trim(cnst_name(ichem))//'SFWETQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from wet removable in ECPP (quiescent)' ) - call addfld(trim(cnst_name(ichem))//'SFRESQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from resupspension in wet removable in ECPP (quiescent)' ) - call addfld(trim(cnst_name(ichem))//'SFCONQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from convective transport in ECPP (quiescent)' ) - -! Updraft class - call addfld(trim(cnst_name(ichem))//'SFACHUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from aqueus chemistry in ECPP (updraft)' ) - call addfld(trim(cnst_name(ichem))//'SFREMUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from renaming in ECPP (updraft)' ) - call addfld(trim(cnst_name(ichem))//'SFACTUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from activation/resuspension ECPP (updraft)' ) - call addfld(trim(cnst_name(ichem))//'SFWETUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from wet removable in ECPP (updraft)' ) - call addfld(trim(cnst_name(ichem))//'SFRESUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from resupspension in wet removable in ECPP (updraft)') - call addfld(trim(cnst_name(ichem))//'SFCONUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from convective transport in ECPP (updraft)' ) - -! Downdraft class - call addfld(trim(cnst_name(ichem))//'SFACHDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from aqueus chemistry in ECPP (downdraft)' ) - call addfld(trim(cnst_name(ichem))//'SFREMDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from renaming in ECPP (downdraft)' ) - call addfld(trim(cnst_name(ichem))//'SFACTDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from activation/resuspension ECPP (downdraft)' ) - call addfld(trim(cnst_name(ichem))//'SFWETDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from wet removable in ECPP (downdraft)' ) - call addfld(trim(cnst_name(ichem))//'SFRESDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from resupspension in wet removable in ECPP (downdraft)' ) - call addfld(trim(cnst_name(ichem))//'SFCONDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name(ichem))//' column-integrated tendency from convective transport in ECPP (downdraft)' ) - endif - - end do - do ichem=param_first_ecpp, pcnst - if(.not. (cnst_name_cw(ichem) == ' ')) then - call addfld(trim(cnst_name_cw(ichem))//'EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name_cw(ichem))//' tendency from ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'ACHEM_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name_cw(ichem))//' tendency from aqueous chemistry in ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'RENM_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name_cw(ichem))//' tendency from renaming in ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'ACT_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name_cw(ichem))//' tendency from activation/resuspension in ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'WET_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name_cw(ichem))//' tendency from wet removable in ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'WRESU_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name_cw(ichem))//' tendency from resuspension in wet removable in ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'CONV_EP', (/ 'lev' /), 'A', 'kg/kg/s', & - trim(cnst_name_cw(ichem))//' tendency from convective tansport in ECPP' ) - - call addfld(trim(cnst_name_cw(ichem))//'SFEP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'SFACHEM_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from aqueus chemistry in ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'SFRENM_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from renaming chemistry in ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'SFACT_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from activation/resuspension ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'SFWET_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from wet removable in ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'SFWRESU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from resuspension in wet removable in ECPP' ) - call addfld(trim(cnst_name_cw(ichem))//'SFCONV_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from convective transport in ECPP' ) - -! Quiescent class - call addfld(trim(cnst_name_cw(ichem))//'SFACHQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from aqueus chemistry in ECPP (quiescent)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFREMQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from renaming in ECPP (quiescent)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFACTQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from activation/resuspension ECPP (quiescent)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFWETQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from wet removable in ECPP (quiescent)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFRESQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from resupspension in wet removable in ECPP (quiescent)') - call addfld(trim(cnst_name_cw(ichem))//'SFCONQU_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from convective transport in ECPP (quiescent)' ) - -! Updraft class - call addfld(trim(cnst_name_cw(ichem))//'SFACHUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from aqueus chemistry in ECPP (updraft)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFREMUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from renaming in ECPP (updraft)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFACTUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from activation/resuspension ECPP (updraft)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFWETUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from wet removable in ECPP (updraft)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFRESUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from resupspension in wet removable in ECPP (updraft)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFCONUP_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from convective transport in ECPP (updraft)' ) - -! Downdraft class - call addfld(trim(cnst_name_cw(ichem))//'SFACHDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from aqueus chemistry in ECPP (downdraft)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFREMDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from renaming in ECPP (downdraft)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFACTDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from activation/resuspension ECPP (downdraft)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFWETDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from wet removable in ECPP (downdraft)' ) - call addfld(trim(cnst_name_cw(ichem))//'SFRESDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from resupspension in wet removable in ECPP (downdraft)') - call addfld(trim(cnst_name_cw(ichem))//'SFCONDN_EP', horiz_only, 'A', 'kg/m2/s', & - trim(cnst_name_cw(ichem))//' column-integrated tendency from convective transport in ECPP (downdraft)' ) - - end if - end do - - call addfld('AQSO4_H2O2_EP', horiz_only, 'A', 'kg/m2/s', 'SO4 aqueous phase chemistry due to H2O2 (kg/m2/s) in ECPP' ) - call addfld('AQSO4_O3_EP', horiz_only, 'A', 'kg/m2/s', 'SO4 aqueous phase chemistry due to O3 (kg/m2/s) in ECPP' ) - call addfld('XPH_LWC_EP', (/ 'lev' /), 'A', ' ', 'pH value multiplied by lwc in ECPP') - - if(history_aerosol) then - call add_default('AQSO4_H2O2_EP', 1, ' ') - call add_default('AQSO4_O3_EP', 1, ' ') - call add_default('XPH_LWC_EP', 1, ' ') - end if - - if(history_aerosol) then - do ichem=param_first_ecpp, pcnst - if(.not. (cnst_name_cw(ichem) == ' ')) then - call add_default(trim(cnst_name_cw(ichem))//'SFEP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFACHEM_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFRENM_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFACT_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFWET_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFWRESU_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFCONV_EP', 1, ' ') - - call add_default(trim(cnst_name_cw(ichem))//'SFACHQU_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFREMQU_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFACTQU_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFWETQU_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFRESQU_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFCONQU_EP', 1, ' ') - - call add_default(trim(cnst_name_cw(ichem))//'SFACHUP_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFREMUP_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFACTUP_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFWETUP_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFRESUP_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFCONUP_EP', 1, ' ') - - call add_default(trim(cnst_name_cw(ichem))//'SFACHDN_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFREMDN_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFACTDN_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFWETDN_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFRESDN_EP', 1, ' ') - call add_default(trim(cnst_name_cw(ichem))//'SFCONDN_EP', 1, ' ') - end if - - if ((cnst_species_class(ichem) == cnst_spec_class_aerosol) .or. & - (cnst_species_class(ichem) == cnst_spec_class_gas )) then - call add_default(trim(cnst_name(ichem))//'SFEP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFACHEM_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFRENM_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFACT_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFWET_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFWRESU_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFCONV_EP', 1, ' ') - - call add_default(trim(cnst_name(ichem))//'SFACHQU_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFREMQU_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFACTQU_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFWETQU_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFRESQU_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFCONQU_EP', 1, ' ') - - call add_default(trim(cnst_name(ichem))//'SFACHUP_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFREMUP_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFACTUP_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFWETUP_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFRESUP_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFCONUP_EP', 1, ' ') - - call add_default(trim(cnst_name(ichem))//'SFACHDN_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFREMDN_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFACTDN_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFWETDN_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFRESDN_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'SFCONDN_EP', 1, ' ') - end if - - end do - -! for test purpose, additional 3D tendency - do ichem=param_first_ecpp, pcnst - if(trim(cnst_name(ichem)) == 'DMS' .or. trim(cnst_name(ichem)) == 'SO2' .or. & - trim(cnst_name(ichem)) == 'so4_a1') then - call add_default(trim(cnst_name(ichem))//'EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'ACHEM_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'RENM_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'ACT_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'WET_EP', 1, ' ') - call add_default(trim(cnst_name(ichem))//'CONV_EP', 1, ' ') - end if - end do - end if ! end history_aerosol - - end subroutine papampollu_init -!================================================================================================== - -!-------------------------------------------------------------------------------------------------- - subroutine parampollu_driver2( aero_props, & - state, ptend, pbuf, & - dtstep_in, dtstep_pp_in, & - acen_3d, abnd_3d, & - acen_tf_3d, abnd_tf_3d, & - massflxbnd_3d, & - rhcen_3d, qcloudcen_3d, qlsinkcen_3d, & - precrcen_3d, precsolidcen_3d, & - acldy_cen_tbeg_3d & - ) - -! modules from CAM - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc, pbuf_old_tim_idx, pbuf_get_index, pbuf_get_field - use physconst, only: gravit - use time_manager, only: get_nstep, is_first_step - use constituents, only: cnst_name - use cam_history, only: outfld -#ifdef MODAL_AERO - use modal_aero_data, only: ntot_amode, cnst_name_cw, qqcw_get_field -#endif - -! modules from ECPP - use module_ecpp_td2clm, only: parampollu_td240clm - - implicit none - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_driver2 is the interface between wrf-chem and the -! parameterized pollutants "1 column" routine -! -! main inputs are -! aerosol and trace gas mixing ratios for a subset of the -! host-code domain -! ecpp (sub-grid) cloud statistics for the same subset of domain -! main outputs are -! updated aerosol and trace gas mixing ratios, with changes due -! to sub-grid vertical transport, activation/resuspension, -! cloud chemistry, and wet removal -! -!----------------------------------------------------------------------- - -! subr arguments - - type(modal_aerosol_properties), intent(in) :: aero_props - real(r8), intent(in) :: dtstep_in, dtstep_pp_in -! dtstep_in - main model time step (s) -! dtstep_pp_in - time step (s) for "parameterized pollutants" calculations - - type(physics_state), intent(in) :: state ! Physics state variables - type(physics_ptend), intent(inout) :: ptend ! individual parameterization - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - - real(r8), intent(in), dimension( pcols, pverp, 1:ncc_in, 1:ncls_ecpp_in, 1:nprcp_in ) :: & - abnd_3d, abnd_tf_3d, massflxbnd_3d - real(r8), intent(in), dimension( pcols, pver, 1:ncc_in, 1:ncls_ecpp_in, 1:nprcp_in ) :: & - acen_3d, acen_tf_3d, rhcen_3d, & - qcloudcen_3d, qlsinkcen_3d, precrcen_3d, precsolidcen_3d -! *** note - these are not "3d" now but probably will be in the mmf code -! abnd_3d and abnd_tf_3d - sub-class fractional area (--) at layer bottom boundary -! abnd_3d is average for full time period (=dtstep_pp_in) -! abnd_tf_3d is average for end-portion of time period -! acen_3d and acen_tf_3d - sub-class fractional area (--) at layer center -! acen_3d is average for full time period (=dtstep_pp_in) -! acen_tf_3d is average for end-portion of time period -! massflxbnd_3d - sub-class vertical mass flux (kg/m2/s) at layer bottom boundary. -! *** note - These are calculated using wfull, not wprime. -! rhcen_3d - relative humidity (0-1) at layer center -! qcloudcen_3d - cloud water mixing ratio (kg/kg) at layer center -! qlsinkcen_3d - cloud-water first-order loss rate to precipitation (/s) at layer center -! precrcen_3d - liquid (rain) precipitation rate (kg/m2/s) at layer center -! precsolidcen_3d - solid (snow,graupel,...) precipitation rate (kg/m2/s) at layer center - - real(r8), intent(inout), dimension( pcols, pver) :: acldy_cen_tbeg_3d -! acldy_cen_tbeg_3d = total (all sub-classes) cloudy fractional area -! on input, = value from end of the previous time step -! on output, = value from end of the current time step - -!----------------------------------------------------------------------- -! local variables - integer :: ncol, lchnk - integer :: mbuf - integer :: id - integer :: i, icc, ipass, ipp, itmpa, it, ichem, ichem2 - integer :: j, jclrcld, jcls, jclsaa, jclsbb, jt - integer :: nstep, nstep_pp - integer :: k, ka, kb, lk - integer :: l, ll, levdbg_err, levdbg_info - integer :: lun, lun60, lun61, lun131, lun132, lun133, lun134, lun135 - integer :: n, ncls_ecpp, nupdraft, ndndraft - integer :: itmpcnt(pver+1,4) - integer :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) - - integer, dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_ecpp, kdraft_top_ecpp, & - mtype_updnenv_ecpp - - real(r8) :: dtstep, dtstep_pp - real(r8) :: tmpa, tmpb, tmpc, tmpd - real(r8) :: za, zb, zc - - integer, dimension( 1:nupdraft_in ) :: & - kupdraftbase, kupdrafttop - integer, dimension( 1:ndndraft_in ) :: & - kdndraftbase, kdndrafttop -! kupdraftbase, kupdrafttop - lower-most and upper-most level for each updraft class -! *** note1- these refer to layer centers, not layer boundaries. Thus -! acen > 0 for kupdraftbase:kupdrafttop and = 0 at other k -! abnd > 0 for kupdraftbase+1:kupdrafttop and = 0 at other k -! massflxbnd > 0 for kupdraftbase+1:kupdrafttop and = 0 at other k -! kdndraftbase, kdndrafttop - lower-most and upper-most level for each downdraft class -! *** note2- these get checked/adjusted later, so simply setting k--draftbase = kts -! and k--drafttop = ktecen is OK - - real(r8) :: tcen_bar (pver) ! temperature at layer centers (K) - real(r8) :: pcen_bar (pver) ! pressure at layer centers (K) - real(r8) :: rhocen_bar (pver) ! air density at layer centers (kg/m3) - real(r8) :: dzcen (pver) ! layer depth (m) - real(r8) :: wcen_bar (pver) ! vertical velocity at layer centers (m/s) - real(r8) :: rhobnd_bar (pverp) ! air density at layer boundaries (kg/m3) - real(r8) :: zbnd (pverp) ! elevation at layer boundaries (m) ???elevation or height???? - real(r8) :: wbnd_bar (pverp) ! vertical velocity at layer boundaries (m/s) - - real(r8) :: chem_bar (pver, 1:num_chem_ecpp) ! mixing ratios of trace gase (ppm) and aerosol species - ! (ug/kg for mass species, #/kg for number species) -#ifdef MODAL_AERO -! real(r8), pointer, dimension(:, :, :) :: qqcw ! cloud-borne aerosol - type(ptr2d_t) :: qqcw(pcnst) -! real(r8) :: qqcwold(pcols, pver, pcnst) -#endif - real(r8), dimension( pverp, 0:2, 0:maxcls_ecpp ) :: & - abnd_tavg, abnd_tfin, mfbnd - real(r8), dimension( pver, 0:2, 0:maxcls_ecpp ) :: & - acen_tavg, acen_tfin, acen_tbeg, acen_prec - real(r8), dimension( pver, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - rh_sub2, qcloud_sub2, qlsink_sub2, precr_sub2, precs_sub2 - real(r8), dimension(pver, 1:2, 1:maxcls_ecpp, 1:2, 1:num_chem_ecpp ) :: & - del_cldchem, & ! tendency of chem_sub from aqueous chemistry - del_rename, & ! tendency of chem_sub from renaming. - del_wetscav, & ! tendency of chem_sub from wet deposition - del_wetresu - - real(r8), dimension(pver, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - del_activate, & ! tendency of chem_sub from activation/resuspension - del_conv ! tendency of chem_sub from convective transport - - real(r8), dimension(pcols, pver, 1:2, 1:maxcls_ecpp, 1:2, 1:num_chem_ecpp ) :: & - del_cldchem3d, & ! tendency of chem_sub from aqueous chemistry - del_rename3d, & ! tendency of chem_sub from renaming. - del_wetscav3d, & ! tendency of chem_sub from wet deposition - del_wetresu3d ! tendency of chem_sub from resuspension in wet deposition - - real(r8), dimension(pcols, pver, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - del_activate3d, & ! tendency of chem_sub from activation/resuspension - del_conv3d ! tendency of chem_sub from convective transport - - real(r8), dimension(pcols) :: aqso4_h2o2, & ! SO4 aqueous phase chemistry due to H2O2 (kg/m2/s) - aqso4_o3 ! SO4 aqueous phase chemistry due to O3 (kg/m2/s) - - real(r8), dimension(pver, 1:2, 1:maxcls_ecpp, 1:2) :: xphlwc ! pH value multiplied by lwc - real(r8), dimension(pcols, pver, 1:2, 1:maxcls_ecpp, 1:2) :: xphlwc3d - real(r8), dimension(pcols, pver) :: xphlwc_gcm - - - real(r8), dimension(pcols, pver, 1:num_chem_ecpp) :: & - ptend_cldchem, ptend_rename, ptend_wetscav, ptend_wetresu, ptend_activate, ptend_conv ! tendency at GCM grids - - real(r8), dimension(pcols, pver, 1:maxcls_ecpp, 1:num_chem_ecpp) :: & - ptend_activate_cls, & ! activation tendency for sub transport class - ptend_cldchem_cls, & ! aqueous chemistry - ptend_rename_cls, & ! renaming - ptend_wetscav_cls, & ! wet deposition - ptend_wetresu_cls, & ! resuspension - ptend_conv_cls ! convective transport - - real(r8), dimension(pcols, 1:maxcls_ecpp, 1:num_chem_ecpp) :: & - ptend_activate_cls_col, & ! column-integrated activation tendency for sub transport class - ptend_cldchem_cls_col, & ! aqueous chemistry - ptend_rename_cls_col, & ! renaming - ptend_wetscav_cls_col, & ! wet deposition - ptend_wetresu_cls_col, & ! resuspension - ptend_conv_cls_col ! convective transport - - - real(r8), dimension(pcols, 1:num_chem_ecpp) :: & - ptend_cldchem_col, ptend_rename_col, ptend_wetscav_col, ptend_wetresu_col, ptend_activate_col, ptend_conv_col, & - ptendq_col ! column-integrated tendency - - real(r8), dimension(pcols, pver, 1:pcnst) :: ptend_qqcw ! tendency for cloud-borne aerosols - - real(r8), dimension(pcols, 1:num_chem_ecpp) :: del_chem_col_cldchem, del_chem_col_rename, del_chem_col_wetscav ! column tendency calcuated in ECPP - - character(len=100) :: msg - logical :: lq(pcnst) - -!----------------------------------------------------------------------- -! set flags that turn diagnostic output on/off -! -! for a specific output to be "on", both the -! idiagaa_ecpp(--) and ldiagaa_ecpp(--) be positive -! the ldiagaa_ecpp(--) is the output unit number -! -! 60 - from subr parampollu_driver2 -! short messages on entry and exit -! 61 - from subr parampollu_driver2 -! "rcetestpp diagnostics" block -! 62 - from subr parampollu_td240clm -! short messages on entry and exit, and showing sub-time-step -! 63 - from subr parampollu_check_adjust_inputs -! shows some summary statistics about the check/adjust process -! 115, 116, 117 - from subr parampollu_1clm_dumpaa -! shows various statistics on transport class and subarea -! fractional areas and mass fluxes -! 116 is before call to parampollu_check_adjust_inputs -! 117 is after 1st call to parampollu_check_adjust_inputs -! 115 is after 2nd call to parampollu_check_adjust_inputs -! 118 - from subr parampollu_tdx_main_integ and parampollu_tdx_area_change -! diagnostics involving changes to species 9 in those subrs -! 119 - from subr parampollu_tdx_cleanup -! diagnostics involving changes to species 9 in that subr -! 121 - from subr parampollu_tdx_cleanup -! diagnostics involving mass conservation -! 122 - from subr parampollu_tdx_entdet_sub1 and parampollu_tdx_entdet_diag01 -! diagnostics involving entrainment/detrainment and area changes -! 123 - from subr parampollu_tdx_entdet_sub1 -! diagnostics involving entrainment/detrainment and area changes -! 124 - from subr parampollu_tdx_main_integ -! diagnostics involving sub-time-step for "main integration", -! related to stability and courant number -! 125 - from subr parampollu_tdx_activate_intface -! diagnostics involving aerosol activation and associated vertical velocities -! 131-135 - from subr parampollu_driver2 -! shows various statistics on transport class and subarea -! fractional areas and mass fluxes -! 141-143 - from subr parampollu_tdx_wetscav_2 -! diagnostics for the "new" wetscav code designed for the mmf-with-ecpp -! 155 - from subr parampollu_check_adjust_inputs -! shows "history" of acen_tavg_use thru the check/adjust process -! 161, 162, 164 - from subr parampollu_tdx_startup & parampollu_tdx_partition_acw -! involves partitioning of cloudborne/interstitial aerosol between clear -! and cloudy subareas - -! - idiagaa_ecpp(:) = -1 - - do i = 1, 199 - ldiagaa_ecpp(i) = i - end do - ldiagaa_ecpp(60:69) = 6 - ldiagaa_ecpp(62) = 62 - -!----------------------------------------------------------------------- - - lun60 = -1 - if (idiagaa_ecpp(60) > 0) lun60 = ldiagaa_ecpp(60) - lun61 = -1 - if (idiagaa_ecpp(61) > 0) lun61 = ldiagaa_ecpp(61) - lun131 = -1 - if (idiagaa_ecpp(131) > 0) lun131 = ldiagaa_ecpp(131) - lun132 = -1 - if (idiagaa_ecpp(132) > 0) lun132 = ldiagaa_ecpp(132) - lun133 = -1 - if (idiagaa_ecpp(133) > 0) lun133 = ldiagaa_ecpp(133) - lun134 = -1 - if (idiagaa_ecpp(134) > 0) lun134 = ldiagaa_ecpp(134) - lun135 = -1 - if (idiagaa_ecpp(135) > 0) lun135 = ldiagaa_ecpp(135) - - - ncol = state%ncol - lchnk = state%lchnk - - lq(:) = .false. - do ichem=param_first_ecpp, pcnst - if ((cnst_species_class(ichem) == cnst_spec_class_aerosol) .or. & - (cnst_species_class(ichem) == cnst_spec_class_gas )) then - lq(ichem)=.true. - end if - end do - call physics_ptend_init(ptend, state%psetcols,'ecpp',lq=lq) - ptend%q(:,:,:) = 0.0_r8 - - dtstep = dtstep_in - dtstep_pp = dtstep_pp_in - -!rcetestpp diagnostics -------------------------------------------------- - if (lun61 > 0) then - write(lun61,93010) ' ' - write(lun61,93010) 'rcetestpp diagnostics from parampollu_driver2' - write(lun61,93020) 'dtstep, dtstep_pp ', & - dtstep, dtstep_pp -93010 format( a, 8(1x,i6) ) -93020 format( a, 8(1p,e14.6) ) - end if ! (lun61 > 0) -!rcetestpp diagnostics -------------------------------------------------- - - if (num_chem_ecpptmp < num_chem_ecpp) then - msg = '*** parampollu_driver -- bad num_chem_ecpptmp' - call endrun(msg) - end if - -! check for valid ncls_ecpptmp - nupdraft = nupdraft_in - ndndraft = ndndraft_in - ncls_ecpp = (nupdraft + ndndraft + 1) - if (ncls_ecpp > maxcls_ecpp) then - write(msg,'(a,2(1x,i6))') & - '*** parampollu_driver - ncls_ecpp > maxcls_ecpp, values =', & - ncls_ecpp, maxcls_ecpp - call endrun( msg ) - end if - if (ncls_ecpp /= ncls_ecpp_in) then - write(msg,'(a,2(1x,i8))') & - '*** parampollu_driver -- bad ncls_ecpp_in', & - ncls_ecpp_in, ncls_ecpp - call endrun( msg ) - end if - -! on very first time step, initialize acldy_cen_tbeg -! -! *** this code should probably go into parampollu_init0 (or somewhere else) - nstep = get_nstep() - nstep_pp = nstep - if (is_first_step()) then - acldy_cen_tbeg_3d(:,:) = 0.0_r8 - - do k = 1, pver - do i = 1, ncol - tmpa = 0.0_r8 ; tmpb = 0.0_r8 - do ipp = 1, nprcp_in - do jcls = 1, ncls_ecpp - tmpa = tmpa + max( 0.0_r8, acen_3d(i,k,1,jcls,ipp) ) - tmpb = tmpb + max( 0.0_r8, acen_3d(i,k,2,jcls,ipp) ) - end do - end do - - if (abs(tmpa+tmpb-1.0_r8) > 1.0e-3_r8) then - write(msg,'(a,3i5,1pe15.7)') & - '*** parampollu_driver -- bad acen_tbeg - i,j,k,acen', & - i, j, k, (tmpa+tmpb) - call endrun(msg) - end if - tmpa = tmpa/(tmpa+tmpb) - - tmpa = 1.0_r8 ! force to initially clear -- might want to change this - -! when iflag_ecpp_test_fixed_fcloud = 2/3/4/5, force acen_tbeg 100%/0%/70%/30% clear - if ((iflag_ecpp_test_fixed_fcloud >= 2) .and. & - (iflag_ecpp_test_fixed_fcloud <= 5)) then - if (iflag_ecpp_test_fixed_fcloud == 2) then - tmpa = 1.0_r8 - else if (iflag_ecpp_test_fixed_fcloud == 3) then - tmpa = 0.0_r8 - else if (iflag_ecpp_test_fixed_fcloud == 4) then - tmpa = 0.7_r8 - else - tmpa = 0.3_r8 - end if - end if - - acldy_cen_tbeg_3d(i,k) = 1.0_r8 - tmpa - end do - end do - end if - - -! set some variables to their wrf-chem "standard" values - levdbg_err = 0 - levdbg_info = 15 - -#ifdef MODAL_AERO -! mbuf = pbuf_get_fld_idx( 'QQCW' ) -! if ( associated(pbuf(mbuf)%fld_ptr) ) then -! qqcw => pbuf(mbuf)%fld_ptr( 1, 1:pcols, 1:pver, lchnk, 1:pcnst ) -! else -! call endrun( 'pbuf for QQCW not allocated in aerosol_wet_intr' ) -! end if -!+++mhwang 2012-02-22 -! qqcw_get_field is no longer used in ndrop.F90. Make sure -! it is still valid !!!! - do i=1,pcnst - qqcw(i)%fldcw => qqcw_get_field(pbuf, i,lchnk,.true.) - end do -#endif - -! loop over columns - do 2910 i = 1, ncol -! -! load column arrays -! - zbnd(1) = 0.0_r8 - wbnd_bar(1) = 0.0_r8 - do k=pver, 1, -1 - tcen_bar(pver-k+1) = state%t(i,k) - pcen_bar(pver-k+1) = state%pmid(i,k) - -! dry air density is calcualted, because tracer mixing ratios are defined with respect to dry air in CAM. - rhocen_bar(pver-k+1) = state%pmiddry(i,k)/(287.0_r8*state%t(i,k)) - - wbnd_bar(pver-k+2) = -1*state%omega(i,k)/(rhocen_bar(pver-k+1)*gravit) - -! pressure vertical velocity (Pa/s) to height vertical velocity (m/s) - dzcen(pver-k+1) = state%pdeldry(i,k)/gravit/rhocen_bar(pver-k+1) - - zbnd(pver-k+2) = zbnd(pver-k+1) + dzcen(pver-k+1) - end do - - do k = 1, pver+1 - ka = max( 1, min(pver-1, k-1 ) ) - kb = ka + 1 - za = 0.5_r8*(zbnd(ka) + zbnd(ka+1)) - zb = 0.5_r8*(zbnd(kb) + zbnd(kb+1)) - rhobnd_bar(k) = rhocen_bar(ka) & - + (rhocen_bar(kb)-rhocen_bar(ka))*(zbnd(k)-za)/(zb-za) - end do - - chem_bar(:,:) = 0.0_r8 -! Load chem - do k=pver, 1, -1 - do ichem = 1, num_chem_ecpp - if(ichem.le.pcnst) then - chem_bar(pver-k+1, ichem) = state%q(i, k, ichem) -#ifdef MODAL_AERO - else -! chem_bar(pver-k+1, ichem) = qqcw(i, k, ichem-pcnst) - if(associated(qqcw(ichem-pcnst)%fldcw)) then - chem_bar(pver-k+1, ichem) = qqcw(ichem-pcnst)%fldcw(i, k) - else - chem_bar(pver-k+1, ichem) = 0.0_r8 - end if -#endif - end if - end do - end do - -! -! load transport-class arrays -! - -! load other/quiescent - jcls = 1 - - kupdraftbase = 1 - kupdrafttop = pver - kdndraftbase = 1 - kdndrafttop = pver - - kdraft_bot_ecpp( 1:2,jcls) = 1 - kdraft_top_ecpp( 1:2,jcls) = pver - mtype_updnenv_ecpp(1:2,jcls) = mtype_quiescn_ecpp - -! load updrafts - do n = 1, nupdraft - jcls = jcls + 1 - - kdraft_bot_ecpp( 1:2,jcls) = max( kupdraftbase(n), 1 ) - kdraft_top_ecpp( 1:2,jcls) = min( kupdrafttop(n), pver ) - mtype_updnenv_ecpp(1:2,jcls) = mtype_updraft_ecpp - end do - -! load downdrafts - do n = 1, ndndraft - jcls = jcls + 1 - - kdraft_bot_ecpp( 1:2,jcls) = max( kdndraftbase(n), 1 ) - kdraft_top_ecpp( 1:2,jcls) = min( kdndrafttop(n), pver ) - mtype_updnenv_ecpp(1:2,jcls) = mtype_dndraft_ecpp - end do - -! load mfbnd and "area" arrays for all classes - mfbnd( :,:,:) = 0.0_r8 - abnd_tavg(:,:,:) = 0.0_r8 - abnd_tfin(:,:,:) = 0.0_r8 - acen_tavg(:,:,:) = 0.0_r8 - acen_tfin(:,:,:) = 0.0_r8 - - do jcls = 1, ncls_ecpp - do icc = 1, 2 - do k = 1, pver+1 - lk=pver+1-k+1 - mfbnd( lk,icc,jcls) = massflxbnd_3d(i, k,icc,jcls,1) & - + massflxbnd_3d(i, k,icc,jcls,2) - abnd_tavg(lk,icc,jcls) = abnd_3d(i, k,icc,jcls,1) & - + abnd_3d(i, k,icc,jcls,2) - abnd_tfin(lk,icc,jcls) = abnd_tf_3d(i, k,icc,jcls,1) & - + abnd_tf_3d(i, k,icc,jcls,2) - end do ! k - end do ! icc - end do ! jcls - -! load these arrays - acen_prec( :,:,: ) = 0.0_r8 - qcloud_sub2(:,:,:,:) = 0.0_r8 - qlsink_sub2(:,:,:,:) = 0.0_r8 - precr_sub2( :,:,:,:) = 0.0_r8 - precs_sub2( :,:,:,:) = 0.0_r8 - rh_sub2( :,:,:,:) = 0.0_r8 - do k=1, pver - lk=pver-k+1 - acen_tavg( lk,1:2,1:ncls_ecpp ) = acen_3d(i, k,1:2,1:ncls_ecpp,1)+ & - acen_3d(i, k,1:2,1:ncls_ecpp,2) - acen_tfin( lk,1:2,1:ncls_ecpp ) = acen_tf_3d(i, k,1:2,1:ncls_ecpp,1)+ & - acen_tf_3d(i, k,1:2,1:ncls_ecpp,2) - acen_prec( lk,1:2,1:ncls_ecpp ) = acen_3d(i, k,1:2,1:ncls_ecpp,2) - qcloud_sub2(lk,1:2,1:ncls_ecpp,1:2) = qcloudcen_3d(i, k,1:2,1:ncls_ecpp,1:2) - qlsink_sub2(lk,1:2,1:ncls_ecpp,1:2) = qlsinkcen_3d(i, k,1:2,1:ncls_ecpp,1:2) - precr_sub2( lk,1:2,1:ncls_ecpp,1:2) = precrcen_3d(i, k,1:2,1:ncls_ecpp,1:2) - precs_sub2( lk,1:2,1:ncls_ecpp,1:2) = precsolidcen_3d(i, k,1:2,1:ncls_ecpp,1:2) - rh_sub2( lk,1:2,1:ncls_ecpp,1:2) = rhcen_3d(i, k,1:2,1:ncls_ecpp,1:2) - if( sum(acen_tfin( lk,1:2,jcls_qu)).lt.0.05_r8) then - write(0, *) 'test acen_tfin < 0.40', sum(acen_tfin( lk,1:2,jcls_qu)), pcen_bar(lk), i,lk !+++mhwang - end if - end do - -! force kdraft_top > kdraft_bot -! (note: need to change the wrf3d post-processor so this is not needed) - do jcls = 1, ncls_ecpp - do jclrcld = 1, 2 - kdraft_top_ecpp(jclrcld,jcls) = max( kdraft_top_ecpp(jclrcld,jcls), & - kdraft_bot_ecpp(jclrcld,jcls)+1 ) - if (kdraft_top_ecpp(jclrcld,jcls) .gt. pver) then - kdraft_top_ecpp(jclrcld,jcls) = pver - kdraft_bot_ecpp(jclrcld,jcls) = pver-1 - end if - end do - end do - -! load acen_tbeg from 3d saved values - acen_tbeg(:,:,:) = 0.0_r8 - jcls = 1 - do k=1, pver - lk=pver-k+1 - acen_tbeg(lk,2,jcls) = acldy_cen_tbeg_3d(i,k) - acen_tbeg(lk,1,jcls) = 1.0_r8 - acen_tbeg(lk,2,jcls) - end do - -! start of temporary diagnostics ------------------------------ - do ipass = 1, 3 - - do ll = 131, 133 - lun = -1 - if (ll == 131) lun = lun131 - if (ll == 132) lun = lun132 - if (ll == 133) lun = lun133 - if (lun <= 0) cycle - - write(lun,*) - if (ipass .eq. 1) then - n = nupdraft - write(lun,'(a,3i5)') 'updrafts, nup, ktau', n, nstep, nstep_pp - else if (ipass .eq. 2) then - n = ndndraft - write(lun,'(a,3i5)') 'dndrafts, nup, ktau', n, nstep, nstep_pp - else - n = ncls_ecpp - write(lun,'(a,3i5)') 'quiescents, ncls_ecpp, ktau', n, nstep, nstep_pp - end if - end do - - do ka = (2*((pver+1)/2)-1), 1, -2 - tmpa = 0.0_r8 - tmpb = 0.0_r8 - tmpc = 0.0_r8 - tmpd = 0.0_r8 - kb = ka+1 -! kb = ka - - if (ipass .eq. 1) then - jclsaa = 1 + 1 - jclsbb = 1 + nupdraft - else if (ipass .eq. 2) then - jclsaa = 1 + nupdraft + 1 - jclsbb = 1 + nupdraft + ndndraft - else - jclsaa = 1 - jclsbb = 1 - end if - do ipp = 1, 2 - do jcls = jclsaa, jclsbb - tmpa = tmpa + abnd_3d(i,ka,1,jcls,ipp) + abnd_3d(i,kb,1,jcls,ipp) - tmpb = tmpb + abnd_3d(i,ka,2,jcls,ipp) + abnd_3d(i,kb,2,jcls,ipp) - tmpc = tmpc + massflxbnd_3d(i,ka,1,jcls,ipp) + massflxbnd_3d(i,kb,1,jcls,ipp) - tmpd = tmpd + massflxbnd_3d(i,ka,2,jcls,ipp) + massflxbnd_3d(i,kb,2,jcls,ipp) - end do - end do - - tmpa = tmpa*0.5_r8 ; tmpb = tmpb*0.5_r8 ; - tmpc = tmpc*0.5_r8 ; tmpd = tmpd*0.5_r8 - if (lun131 > 0) & - write(lun131,'(i3,2(3x,1p,3e10.2))') ka, & - tmpa, tmpb, (tmpa+tmpb), tmpc, tmpd, (tmpc+tmpd) - - tmpa = tmpa*100.0_r8 ; tmpb = tmpb*100.0_r8 - tmpc = tmpc*100.0_r8 ; tmpd = tmpd*100.0_r8 - if (lun132 > 0) & - write(lun132,'(i3,2(2x, 3f8.3))') ka, & - tmpa, tmpb, (tmpa+tmpb), tmpc, tmpd, (tmpc+tmpd) - - if (lun133 > 0) & - write(lun133,'(i3,2(2x, 3f7.2))') ka, & - tmpa, tmpb, (tmpa+tmpb), tmpc, tmpd, (tmpc+tmpd) - end do ! ka - end do ! ipass - - - if (lun134 > 0) then - do n = 1, nupdraft - write(lun134,'(/a,5i5)') 'updraft -- n, kbase, ktop, ktaus', & - n, kupdraftbase(n), kupdrafttop(n), nstep, nstep_pp - do k = pver+1, 1, -1 - jcls = 1 + n - write(lun134,'(i3,2(2x,2f10.5))') k, & - sum(abnd_3d(i,k,1,jcls,1:2))*100.0_r8, sum(abnd_3d(i,k,2,jcls,1:2))*100.0_r8, & - sum(massflxbnd_3d(i,k,1,jcls,1:2))*100.0_r8, & - sum(massflxbnd_3d(i,k,2,jcls,1:2))*100.0_r8 - end do - end do - - do n = 1, ndndraft - write(lun134,'(/a,5i5)') 'dndraft -- n, kbase, ktop, ktaus', & - n, kdndraftbase(n), kdndrafttop(n), nstep, nstep_pp - do k = pver+1, 1, -1 - jcls = 1 + nupdraft + n - write(lun134,'(i3,2(2x,2f10.5))') k, & - sum(abnd_3d(i,k,1,jcls,1:2))*100.0_r8, sum(abnd_3d(i,k,2,jcls,1:2))*100.0_r8, & - sum(massflxbnd_3d(i,k,1,jcls,1:2))*100.0_r8, & - sum(massflxbnd_3d(i,k,2,jcls,1:2))*100.0_r8 - end do - end do - end if ! (lun134 > 0) - - - if (lun135 > 0) then - itmpcnt(:,:) = 0 - do n = 1, nupdraft - write(lun135,'(/a,5i5)') 'updraft -- n, kbase, ktop, ktaus', & - n, kupdraftbase(n), kupdrafttop(n), nstep, nstep_pp - do k = pver+1, 1, -1 - jcls = 1 + n - tmpa = sum(abnd_3d(i,k,1,jcls,1:2)) - tmpb = sum(abnd_3d(i,k,2,jcls,1:2)) - tmpc = sum(massflxbnd_3d(i,k,1,jcls,1:2)) - tmpd = sum(massflxbnd_3d(i,k,2,jcls,1:2)) - write(lun135,'(i3,2(2x,1p,2e10.2))') k, tmpa, tmpb, tmpc, tmpd - if (tmpa .gt. 0.0_r8) itmpcnt(k,1) = itmpcnt(k,1) + 1 - if (tmpb .gt. 0.0_r8) itmpcnt(k,2) = itmpcnt(k,2) + 1 - if (tmpc .gt. 0.0_r8) itmpcnt(k,3) = itmpcnt(k,3) + 1 - if (tmpd .gt. 0.0_r8) itmpcnt(k,4) = itmpcnt(k,4) + 1 - end do - end do - write(lun135,'(/a,5i5)') 'updraft non-zero counts -- ktaus', & - nstep, nstep_pp - do k = pver+1, 1, -1 - write(lun135,'(i3,2(5x,2i5))') k, itmpcnt(k,1:4) - end do - - itmpcnt(:,:) = 0 - do n = 1, ndndraft - write(lun135,'(/a,5i5)') 'dndraft -- n, kbase, ktop, ktaus', & - n, kdndraftbase(n), kdndrafttop(n), nstep, nstep_pp - do k = pver+1, 1, -1 - jcls = 1 + nupdraft + n - tmpa = sum(abnd_3d(i,k,1,jcls,1:2)) - tmpb = sum(abnd_3d(i,k,2,jcls,1:2)) - tmpc = sum(massflxbnd_3d(i,k,1,jcls,1:2)) - tmpd = sum(massflxbnd_3d(i,k,2,jcls,1:2)) - write(lun135,'(i3,2(2x,1p,2e10.2))') k, tmpa, tmpb, tmpc, tmpd - if (tmpa .gt. 0.0_r8) itmpcnt(k,1) = itmpcnt(k,1) + 1 - if (tmpb .gt. 0.0_r8) itmpcnt(k,2) = itmpcnt(k,2) + 1 - if (tmpc .lt. 0.0_r8) itmpcnt(k,3) = itmpcnt(k,3) + 1 - if (tmpd .lt. 0.0_r8) itmpcnt(k,4) = itmpcnt(k,4) + 1 - end do - end do - write(lun135,'(/a,5i5)') 'dndraft non-zero counts -- ktaus', & - nstep, nstep_pp - do k = pver+1, 1, -1 - write(lun135,'(i3,2(5x,2i5))') k, itmpcnt(k,1:4) - end do - end if ! (lun135 > 0) -! end of temporary diagnostics ------------------------------ - -! -! do parameterized pollutant calculations on current column -! - itmpa = parampollu_opt - - if ((itmpa == 2220) .or. & - (itmpa == 2223)) then - if (lun60 > 0) write(lun60,93010) & - 'calling parampollu_td240clm - i=', i -! write (0, *) i, lchnk, 'before parampollu_td240clm', nstep - call parampollu_td240clm( aero_props, & - nstep, dtstep, nstep_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - kdraft_bot_ecpp, kdraft_top_ecpp, & - mtype_updnenv_ecpp, & - mfbnd, & - abnd_tavg, acen_tavg, acen_tfin, acen_tbeg, & - acen_prec, rh_sub2, & - qcloud_sub2, qlsink_sub2, precr_sub2, precs_sub2, & - del_cldchem, del_rename, & - del_wetscav, del_wetresu, & - del_activate, del_conv, & - del_chem_col_cldchem(i,:), del_chem_col_rename(i, :), del_chem_col_wetscav(i, :), & - aqso4_h2o2(i), aqso4_o3(i), xphlwc, & - i, lchnk, 1,pver+1,pver, pbuf & - ) -! write (0, *) i, lchnk, 'after parampollu_td240clm', nstep - - aqso4_h2o2(i) = aqso4_h2o2(i)/dtstep - aqso4_o3(i) = aqso4_o3(i)/dtstep - - else - end if - - -! -! put selected arrays back into 3d arrays -! - if (itmpa > 0) then - - do k = 1, pver - lk=pver-k+1 - acldy_cen_tbeg_3d(i,k) = sum( acen_tfin(lk,2,1:ncls_ecpp) ) - end do - -! Interstial species - ptend_qqcw(i,:,:) = 0.0_r8 - do k=1, pver - lk=pver-k+1 - do ichem=param_first_ecpp, pcnst - if (ptend%lq(ichem)) then - ptend%q(i,k,ichem)= (chem_bar(lk, ichem)-state%q(i,k,ichem))/dtstep - end if -! ptend_qqcw(i,k,ichem)=(chem_bar(lk, ichem+pcnst)-qqcw(i,k,ichem))/dtstep -! qqcw(i,k,ichem) = chem_bar(lk, ichem+pcnst) - if(associated(qqcw(ichem)%fldcw)) then - ptend_qqcw(i,k,ichem)=(chem_bar(lk, ichem+pcnst)-qqcw(ichem)%fldcw(i,k))/dtstep - qqcw(ichem)%fldcw(i,k) = chem_bar(lk, ichem+pcnst) - else - ptend_qqcw(i,k,ichem)= 0.0_r8 - endif - end do - del_cldchem3d(i,k,:,:,:,:) = del_cldchem(lk,:,:,:,:)/dtstep - del_rename3d(i,k,:,:,:,:) = del_rename(lk,:,:,:,:)/dtstep - del_wetscav3d(i,k,:,:,:,:) = del_wetscav(lk,:,:,:,:)/dtstep - del_wetresu3d(i,k,:,:,:,:) = del_wetresu(lk,:,:,:,:)/dtstep - del_activate3d(i,k,:,:,:) = del_activate(lk,:,:,:)/dtstep - del_conv3d(i,k,:,:,:) = del_conv(lk,:,:,:)/dtstep - xphlwc3d(i,k,:,:,:) = xphlwc(lk,:,:,:) - end do -! cloud borne species - - end if - -2910 continue - - - ptend_cldchem = 0.0_r8 - ptend_rename = 0.0_r8 - ptend_wetscav = 0.0_r8 - ptend_wetresu = 0.0_r8 - ptend_activate=0.0_r8 - ptend_conv = 0.0_r8 - xphlwc_gcm = 0.0_r8 - - ptend_cldchem_cls = 0.0_r8 - ptend_rename_cls = 0.0_r8 - ptend_wetscav_cls = 0.0_r8 - ptend_wetresu_cls = 0.0_r8 - ptend_activate_cls=0.0_r8 - ptend_conv_cls = 0.0_r8 - - ptend_cldchem_col = 0.0_r8 - ptend_rename_col = 0.0_r8 - ptend_wetscav_col = 0.0_r8 - ptend_wetresu_col = 0.0_r8 - ptend_activate_col=0.0_r8 - ptend_conv_col = 0.0_r8 - ptendq_col = 0.0_r8 - - ptend_cldchem_cls_col = 0.0_r8 - ptend_rename_cls_col = 0.0_r8 - ptend_wetscav_cls_col = 0.0_r8 - ptend_wetresu_cls_col = 0.0_r8 - ptend_activate_cls_col=0.0_r8 - ptend_conv_cls_col = 0.0_r8 - - do i=1, ncol - do k=1, pver - do jcls = 1, ncls_ecpp - do icc = 1, 2 -! tendency at GCM grids - do ipp=1, 2 - ptend_cldchem(i,k,:) = ptend_cldchem(i,k,:)+del_cldchem3d(i,k,icc,jcls,ipp,:) - ptend_rename(i,k,:) = ptend_rename(i,k,:)+del_rename3d(i,k,icc,jcls,ipp,:) - ptend_wetscav(i,k,:) = ptend_wetscav(i,k,:)+del_wetscav3d(i,k,icc,jcls,ipp,:) - ptend_wetresu(i,k,:) = ptend_wetresu(i,k,:)+del_wetresu3d(i,k,icc,jcls,ipp,:) - xphlwc_gcm(i,k) = xphlwc_gcm(i,k) + xphlwc3d(i,k,icc,jcls,ipp) -! tendency at each transport class: - ptend_cldchem_cls(i,k,jcls,:) = ptend_cldchem_cls(i,k,jcls,:)+del_cldchem3d(i,k,icc,jcls,ipp,:) - ptend_rename_cls(i,k,jcls,:) = ptend_rename_cls(i,k,jcls,:)+del_rename3d(i,k,icc,jcls,ipp,:) - ptend_wetscav_cls(i,k,jcls,:) = ptend_wetscav_cls(i,k,jcls,:)+del_wetscav3d(i,k,icc,jcls,ipp,:) - ptend_wetresu_cls(i,k,jcls,:) = ptend_wetresu_cls(i,k,jcls,:)+del_wetresu3d(i,k,icc,jcls,ipp,:) - end do - - ptend_activate(i,k,:) = ptend_activate(i,k,:)+del_activate3d(i,k,icc,jcls,:) - ptend_activate_cls(i,k,jcls, :) = ptend_activate_cls(i,k,jcls, :) + del_activate3d(i,k,icc,jcls,:) - ptend_conv(i,k,:) = ptend_conv(i,k,:)+del_conv3d(i,k,icc,jcls,:) - ptend_conv_cls(i,k,jcls,:) = ptend_conv_cls(i,k,jcls,:)+del_conv3d(i,k,icc,jcls,:) - end do ! end icc - end do ! end jcls - -! column-integrated tendency - ptend_cldchem_col(i,:) = ptend_cldchem_col(i,:)+ptend_cldchem(i,k,:)*state%pdeldry(i,k)/gravit - ptend_rename_col(i,:) = ptend_rename_col(i,:)+ptend_rename(i,k,:)*state%pdeldry(i,k)/gravit - ptend_wetscav_col(i,:) = ptend_wetscav_col(i,:)+ptend_wetscav(i,k,:)*state%pdeldry(i,k)/gravit - ptend_wetresu_col(i,:) = ptend_wetresu_col(i,:)+ptend_wetresu(i,k,:)*state%pdeldry(i,k)/gravit - ptend_activate_col(i,:) = ptend_activate_col(i,:)+ptend_activate(i,k,:)*state%pdeldry(i,k)/gravit - ptend_conv_col(i,:) = ptend_conv_col(i,:)+ptend_conv(i,k,:)*state%pdeldry(i,k)/gravit - - ptend_cldchem_cls_col(i,:,:) = ptend_cldchem_cls_col(i,:,:)+ptend_cldchem_cls(i,k,:,:)*state%pdeldry(i,k)/gravit - ptend_rename_cls_col(i,:,:) = ptend_rename_cls_col(i,:,:)+ptend_rename_cls(i,k,:,:)*state%pdeldry(i,k)/gravit - ptend_wetscav_cls_col(i,:,:) = ptend_wetscav_cls_col(i,:,:)+ptend_wetscav_cls(i,k,:,:)*state%pdeldry(i,k)/gravit - ptend_wetresu_cls_col(i,:,:) = ptend_wetresu_cls_col(i,:,:)+ptend_wetresu_cls(i,k,:,:)*state%pdeldry(i,k)/gravit - ptend_activate_cls_col(i,:,:) = ptend_activate_cls_col(i,:,:)+ptend_activate_cls(i,k,:,:)*state%pdeldry(i,k)/gravit - ptend_conv_cls_col(i,:,:) = ptend_conv_cls_col(i,:,:)+ptend_conv_cls(i,k,:,:)*state%pdeldry(i,k)/gravit - - - ptendq_col(i,param_first_ecpp:pcnst) = ptendq_col(i,param_first_ecpp:pcnst)+ & - ptend%q(i,k,param_first_ecpp:pcnst)*state%pdeldry(i,k)/gravit - ptendq_col(i,param_first_ecpp+pcnst:pcnst+pcnst) = ptendq_col(i,param_first_ecpp+pcnst:pcnst+pcnst)+ & - ptend_qqcw(i,k,param_first_ecpp:pcnst)*state%pdeldry(i,k)/gravit - end do - end do - - do ichem=param_first_ecpp, pcnst - if ((cnst_species_class(ichem) == cnst_spec_class_aerosol) .or. & - (cnst_species_class(ichem) == cnst_spec_class_gas )) then - call outfld(trim(cnst_name(ichem))//'EP', ptend%q(:,:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'ACHEM_EP', ptend_cldchem(:,:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'RENM_EP', ptend_rename(:,:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'ACT_EP', ptend_activate(:,:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'WET_EP', ptend_wetscav(:,:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'WRESU_EP', ptend_wetresu(:,:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'CONV_EP', ptend_conv(:,:,ichem), pcols, lchnk) - - call outfld(trim(cnst_name(ichem))//'SFEP', ptendq_col(:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFACHEM_EP', ptend_cldchem_col(:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFRENM_EP', ptend_rename_col(:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFACT_EP', ptend_activate_col(:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFWET_EP', ptend_wetscav_col(:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFWRESU_EP', ptend_wetresu_col(:,ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFCONV_EP', ptend_conv_col(:,ichem), pcols, lchnk) - - call outfld(trim(cnst_name(ichem))//'SFACHQU_EP', ptend_cldchem_cls_col(:,1, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFACHUP_EP', ptend_cldchem_cls_col(:,2, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFACHDN_EP', ptend_cldchem_cls_col(:,3, ichem), pcols, lchnk) - - call outfld(trim(cnst_name(ichem))//'SFREMQU_EP', ptend_rename_cls_col(:,1, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFREMUP_EP', ptend_rename_cls_col(:,2, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFREMDN_EP', ptend_rename_cls_col(:,3, ichem), pcols, lchnk) - - call outfld(trim(cnst_name(ichem))//'SFACTQU_EP', ptend_activate_cls_col(:,1, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFACTUP_EP', ptend_activate_cls_col(:,2, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFACTDN_EP', ptend_activate_cls_col(:,3, ichem), pcols, lchnk) - - call outfld(trim(cnst_name(ichem))//'SFWETQU_EP', ptend_wetscav_cls_col(:,1, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFWETUP_EP', ptend_wetscav_cls_col(:,2, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFWETDN_EP', ptend_wetscav_cls_col(:,3, ichem), pcols, lchnk) - - call outfld(trim(cnst_name(ichem))//'SFRESQU_EP', ptend_wetresu_cls_col(:,1, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFRESUP_EP', ptend_wetresu_cls_col(:,2, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFRESDN_EP', ptend_wetresu_cls_col(:,3, ichem), pcols, lchnk) - - call outfld(trim(cnst_name(ichem))//'SFCONQU_EP', ptend_conv_cls_col(:,1, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFCONUP_EP', ptend_conv_cls_col(:,2, ichem), pcols, lchnk) - call outfld(trim(cnst_name(ichem))//'SFCONDN_EP', ptend_conv_cls_col(:,3, ichem), pcols, lchnk) - end if - end do - - do ichem=param_first_ecpp, pcnst - ichem2=ichem+pcnst - if(.not. (cnst_name_cw(ichem) == ' ')) then - call outfld(trim(cnst_name_cw(ichem))//'EP', ptend_qqcw(:,:,ichem), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'ACHEM_EP', ptend_cldchem(:,:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'RENM_EP', ptend_rename(:,:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'ACT_EP', ptend_activate(:,:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'WET_EP', ptend_wetscav(:,:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'WRESU_EP', ptend_wetresu(:,:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'CONV_EP', ptend_conv(:,:,ichem2), pcols, lchnk) - - call outfld(trim(cnst_name_cw(ichem))//'SFEP', ptendq_col(:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFACHEM_EP', ptend_cldchem_col(:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFRENM_EP', ptend_rename_col(:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFACT_EP', ptend_activate_col(:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFWET_EP', ptend_wetscav_col(:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFWRESU_EP', ptend_wetresu_col(:,ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFCONV_EP', ptend_conv_col(:,ichem2), pcols, lchnk) - - call outfld(trim(cnst_name_cw(ichem))//'SFACTQU_EP', ptend_activate_cls_col(:,1, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFACTUP_EP', ptend_activate_cls_col(:,2, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFACTDN_EP', ptend_activate_cls_col(:,3, ichem2), pcols, lchnk) - - call outfld(trim(cnst_name_cw(ichem))//'SFACHQU_EP', ptend_cldchem_cls_col(:,1, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFACHUP_EP', ptend_cldchem_cls_col(:,2, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFACHDN_EP', ptend_cldchem_cls_col(:,3, ichem2), pcols, lchnk) - - call outfld(trim(cnst_name_cw(ichem))//'SFREMQU_EP', ptend_rename_cls_col(:,1, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFREMUP_EP', ptend_rename_cls_col(:,2, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFREMDN_EP', ptend_rename_cls_col(:,3, ichem2), pcols, lchnk) - - call outfld(trim(cnst_name_cw(ichem))//'SFWETQU_EP', ptend_wetscav_cls_col(:,1, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFWETUP_EP', ptend_wetscav_cls_col(:,2, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFWETDN_EP', ptend_wetscav_cls_col(:,3, ichem2), pcols, lchnk) - - call outfld(trim(cnst_name_cw(ichem))//'SFRESQU_EP', ptend_wetresu_cls_col(:,1, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFRESUP_EP', ptend_wetresu_cls_col(:,2, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFRESDN_EP', ptend_wetresu_cls_col(:,3, ichem2), pcols, lchnk) - - call outfld(trim(cnst_name_cw(ichem))//'SFCONQU_EP', ptend_conv_cls_col(:,1, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFCONUP_EP', ptend_conv_cls_col(:,2, ichem2), pcols, lchnk) - call outfld(trim(cnst_name_cw(ichem))//'SFCONDN_EP', ptend_conv_cls_col(:,3, ichem2), pcols, lchnk) - - do i=1, ncol - do k=1, pver -! if(cnst_name_cw(ichem) == 'bc_c1') then -! if(abs(ptend_wetscav(i, k, ichem2)).gt.1.0e-16 .and. qqcwold(i, k, ichem).gt. 1.0e-13) then -! if(abs(ptend_conv(i, k, ichem2)).lt.1.0e-20 .and. abs(ptend_activate(i, k, ichem2)).lt.1.0e-20) then -! write(0, *) 'nstep, ecpp wet, qqcw', nstep, qqcwold(i, k, ichem), qqcw(i,k,ichem), state%q(i, k, ichem), & -! ptend_wetscav(i, k, ichem2)*1800, ptend_wetscav(i, k, ichem2)*86400/qqcwold(i, k, ichem) -! write(0, *) 'ecpp acen', acen_3d(i, k,2,1:ncls_ecpp,1), acen_3d(i, k,2,1:ncls_ecpp,2) -! write(0, *) 'ecpp qlsink' , qlsinkcen_3d(i, k,2,1:ncls_ecpp,1)*86400, qlsinkcen_3d(i, k,2,1:ncls_ecpp,2)*86400 -! write(0, *) 'ecpp wetscav', del_wetscav3d(i,k,2,1:ncls_ecpp,1, ichem2)*1800, & -! del_wetscav3d(i,k,2,1:ncls_ecpp,2, ichem2)*1800 - -! call endrun('ptend_conv error') -! end if -! end if -! if(abs(ptend_conv_col(i, ichem2)).gt.1.0e-15) then -! write(0, *) 'ptend_conv error', ptend_wetresu_col(i,ichem2)+ptend_wetscav_col(i,ichem2), & -! ptend_cldchem_col(i,ichem2), ptend_activate_col(i,ichem2), ptend_conv_col(i,ichem2), & -! ptendq_col(i,ichem2) -! write(0, *) 'ptend_conv error2' , del_chem_col_wetscav(i, ichem2)/dtstep, del_chem_col_cldchem(i,ichem2)/dtstep -! write(0, *) 'ptend_conv error3' , ptendq_col(i,ichem2), & -! ptend_wetresu_col(i,ichem2)+ptend_wetscav_col(i,ichem2) & -! +ptend_cldchem_col(i,ichem2)+ptend_activate_col(i,ichem2), & -! del_chem_col_wetscav(i, ichem2)/dtstep+ptend_cldchem_col(i,ichem2)+ptend_activate_col(i,ichem2) -! call endrun('ptend_conv error') -! end if -! end if - end do - end do - end if - end do - - call outfld('AQSO4_H2O2_EP', aqso4_h2o2, pcols, lchnk) - call outfld('AQSO4_O3_EP', aqso4_o3, pcols, lchnk) - call outfld('XPH_LWC_EP', xphlwc_gcm, pcols, lchnk) - -! -! qqcw is updated above, and q is upated in tphysbc -! - - return - end subroutine parampollu_driver2 -!------------------------------------------------------------------------- - -!------------------------------------------------------------------------- -end module module_ecpp_ppdriver2 diff --git a/src/physics/spcam/ecpp/module_ecpp_td2clm.F90 b/src/physics/spcam/ecpp/module_ecpp_td2clm.F90 deleted file mode 100644 index e8d65d06e8..0000000000 --- a/src/physics/spcam/ecpp/module_ecpp_td2clm.F90 +++ /dev/null @@ -1,5154 +0,0 @@ - module module_ecpp_td2clm - - use ecpp_modal_aero_activate, only: parampollu_tdx_activate1 - use ecpp_modal_cloudchem, only: parampollu_tdx_cldchem - use ecpp_modal_wetscav, only: parampollu_tdx_wetscav_2 - use perf_mod - use cam_abortutils, only: endrun - use physics_buffer, only : physics_buffer_desc - use shr_kind_mod, only : r8 => shr_kind_r8 - - use modal_aerosol_properties_mod, only: modal_aerosol_properties - - implicit none - - - integer, parameter :: jgrp_up=2, jgrp_dn=3 - - - contains - -!----------------------------------------------------------------------- -! -! rce 2005-mar-10 - created -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - subroutine parampollu_td240clm( aero_props, & - ktau, dtstep, ktau_pp_in, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - kdraft_bot_ecpp, kdraft_top_ecpp, & - mtype_updnenv_ecpp, & - mfbnd_ecpp, & - abnd_tavg_ecpp, acen_tavg_ecpp, & - acen_tfin_ecpp, acen_tbeg_ecpp, acen_prec_ecpp, & - rh_sub2, qcloud_sub2, qlsink_sub2, & - precr_sub2, precs_sub2, & - del_cldchem3d, del_rename3d, & - del_wetscav3d, del_wetresu3d, & - del_activate3d, del_conv3d, & - del_chem_clm_cldchem, del_chem_clm_rename, del_chem_clm_wetscav, & - aqso4_h2o2, aqso4_o3, xphlwc3d, & - it, jt, kts,ktebnd,ktecen, pbuf ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_td240clm is a top level routine for doing -! ecpp parameterized pollutants calculations on a single column -! of the host-code grid -! -! this version uses the hybrid time-dependent up/dndraft formulation -! the up and dndrafts are time-dependent, rather than steady state, -! with a lifetime equal "draft_lifetime" -! in the hybrid formulation, the host-code column is conceptually -! divided into ntstep_hybrid == (draft_lifetime/dtstep_pp) pieces -! time integrations over dtstep_pp are done for each piece, sequentially -! the up and downdrafts start "fresh" in the first piece -! at the end of each "piece integration", the up and downdrafts are -! shifted into the next piece -! the the drafts evolve over time = draft_lifetime, but different -! pieces of the environment are affected by different aged drafts -! the hybrid approach avoids two problems of the original time-dependent -! up/dndraft formulation: -! (a) having to store draft information (specifically aerosol mixing -! ratios in the drafts sub-classes) from one host-code time-step to -! the next -! (b) having to determine when drafts should be re-initialized -! -!----------------------------------------------------------------------- - - - use module_data_mosaic_asect, only: ai_phase, cw_phase, nphase_aer - - use module_data_ecpp1 - - use module_data_mosaic_asect, only: is_aerosol, iphase_of_aerosol, isize_of_aerosol, itype_of_aerosol, & - inmw_of_aerosol, laicwpair_of_aerosol - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message, & - parampollu_1clm_set_opts - - use cam_abortutils, only: endrun - -! arguments - type(modal_aerosol_properties), intent(in) :: aero_props - integer, intent(in) :: & - ktau, ktau_pp_in, & - it, jt, kts, ktebnd, ktecen -! ktau - time step number -! ktau_pp_in - time step number for "parameterized pollutants" calculations -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) -! these control diagnostic output - - real(r8), intent(in) :: dtstep, dtstep_pp -! dtstep - main model time step (s) -! dtstep_pp - time step (s) for "parameterized pollutants" calculations - - real(r8), intent(in), dimension( kts:ktecen ) :: & - tcen_bar, pcen_bar, rhocen_bar, dzcen - real(r8), intent(in), dimension( kts:ktebnd ) :: & - rhobnd_bar, wbnd_bar, zbnd -! tcen_bar - temperature (K) at layer centers -! rhocen_bar, rhobnd_bar - dry air density (kg/m^3) at layer centers and boundaries -! pcen_bar - air pressure (Pa) at layer centers -! wbnd_bar - vertical velocity (m/s) at layer boundaries -! zbnd - elevation (m) at layer boundaries -! dzcen - layer thicknesses (m) - - real(r8), intent(inout), dimension( kts:ktecen, 1:num_chem_ecpp ) :: & - chem_bar -! chem_bar - mixing ratios of trace gase (ppm) and aerosol species -! (ug/kg for mass species, #/kg for number species) - -! NOTE - tcen_bar through chem_bar are all grid-cell averages -! (on the host-code grid) - - integer, intent(in) :: ncls_ecpp -! ncls_ecpp - number of ecpp transport classes in the grid column - - integer, intent(in), dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_ecpp, kdraft_top_ecpp, & - mtype_updnenv_ecpp -! kdraft_bot_ecpp = lowest layer in/thru which sub-area transport occurs -! = lowest layer for which massflux != 0 at layer upper boundary -! OR areafrac != 0 at layer center -! >= kts -! kdraft_top_ecpp = highest layer in/thru which sub-area transport occurs -! = highest layer for which massflux != 0 at layer lower boundary -! OR areafrac != 0 at layer center -! <= kte-1 -! mtype_updnenv_ecpp - transport-class (updraft, downdraft, or quiescent) - - real(r8), intent(in), dimension( kts:ktebnd, 0:2, 0:maxcls_ecpp ) :: & - abnd_tavg_ecpp, mfbnd_ecpp -! real(r8), intent(in), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & -! acen_tavg_ecpp, acen_tbeg_ecpp, acen_prec_ecpp - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tavg_ecpp, acen_tbeg_ecpp, acen_prec_ecpp - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tfin_ecpp -! abnd_tavg_ecpp - sub-class fractional area (--) at layer bottom boundary -! acen_tavg_ecpp, acen_tbeg_ecpp, acen_tfin_ecpp - sub-class fractional area (--) -! at layer centers -! _tavg_ is average for full time period (=dtstep_pp_in) -! _tbeg_ is average at beginning of time period -! _tfin_ is average for end-portion of time period -! acen_prec_ecpp - fractional area (---) of the portion of a sub-class that -! has precipitation -! 0 <= acen_prec_ecpp(:,:,:)/acen_tavg_ecpp(:,:,:) <= 1 -! mfbnd_ecpp - sub-class vertical mass flux (kg/m2/s) at layer bottom boundary. -! -! NOTE 1 - these 6 xxx_ecpp arrays contain statistics from the crm -! post-processor or interface. -! Each array has a xxx_use array that contains "checked and adjusted values", -! and those values are the ones that are used. -! NOTE 2 - indexing for these arrays -! the first index is vertical layer -! the second index (0:2): 1=clear, 2=cloudy, and 0=clear+cloudy combined -! the third index is transport class - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - rh_sub2, qcloud_sub2, qlsink_sub2, precr_sub2, precs_sub2 -! rh_sub2 - relative humidity (0-1) at layer center -! qcloud_sub2 - cloud water mixing ratio (kg/kg) at layer center -! qlsink_sub2 - cloud-water first-order loss rate to precipitation (kg/kg/s) at layer center -! precr_sub2 - liquid (rain) precipitation rate (kg/m2/s) at layer center -! precsolid_sub2 - solid (snow,graupel,...) precipitation rate (kg/m2/s) at layer center -! -! NOTE - indexing for these arrays -! the first index is vertical layer -! the second index (0:2) is: 1=clear, 2=cloudy -! the third index is transport class -! the fourth index (0:2) is: 1=non-precipitating, 2=precipitating - - real(r8), intent(out), dimension(kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:num_chem_ecpp ) :: & - del_cldchem3d, & ! 3D change in chem_sub from aqueous chemistry - del_rename3d, & ! 3D change in chem_sub from renaming (modal merging) - del_wetscav3d, & ! 3D change in chem_sub from wet deposition - del_wetresu3d - - real(r8), intent(out), dimension(kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - del_activate3d ! 3D change in chem_sub from activation/resuspension - - real(r8), intent(out), dimension(kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - del_conv3d ! 3D change in chem_sub from convective transport - - real(r8), intent(out) :: aqso4_h2o2, & ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - aqso4_o3 ! SO4 aqueous phase chemistry due to O3 (kg/m2) - - real(r8), intent(out), dimension(kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2) :: & - xphlwc3d ! pH value multiplied by lwc - - real(r8), intent(out), dimension( 1:num_chem_ecpp ) :: del_chem_clm_cldchem, del_chem_clm_rename, del_chem_clm_wetscav - type(physics_buffer_desc), pointer :: pbuf(:) - -! local variables - integer :: activate_onoff_use - integer :: icc, iccy, idiag, & - ipass_area_change, ipass_check_adjust_inputs, & - itstep_hybrid - integer :: jcls, jclsbb, jgrp, jgrpbb - integer :: k, ktau_pp - integer :: l, laa, lbb, ll, lun, lun62 - integer :: ncls_use, ntstep_hybrid - - integer, dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use - - real(r8) :: draft_area_fudge, draft_area_fudge_1m - real(r8) :: tmpa - real(r8) :: tmpd, tmpe, tmpf, tmpg, tmph - real(r8) :: tmpveca(100) - real(r8), save :: tmpvecsva(100), tmpvecsvb(100), tmpvecsvc(100) - - real(r8), dimension( kts:ktebnd ) :: wbnd_bar_use - - real(r8), dimension( kts:ktecen ) :: rhodz_cen - - real(r8), dimension( kts:ktebnd, 0:2, 0:maxcls_ecpp ) :: & - abnd_tavg_use, mfbnd_use, & - abnd_tavg_usex1, mfbnd_usex1, & - ar_bnd_tavg - - real(r8), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tavg_usex1, acen_tbeg_usex1, acen_tfin_usex1, & - acen_tavg_use, acen_tbeg_use, acen_tfin_use, acen_prec_use, & - ardz_cen_tbeg, ardz_cen_tfin, & - ardz_cen_tavg, & - ardz_cen_old, ardz_cen_new - - real(r8), dimension( kts:ktebnd, 0:2, 0:2 ) :: & - mfbnd_quiescn_up, mfbnd_quiescn_dn - - real(r8), dimension( kts:ktecen, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_cls - - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_new, chem_sub_beg, chem_sub_ac1sv, chem_sub_hysum - - real(r8), dimension( 1:2, num_chem_ecpp ) :: chem_bar_iccfactor - - real(r8), dimension(kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - del_activate3da ! 3D change in chem_sub from activation/resuspension - - - - character(len=120) :: msg - - - ktau_pp = 10 - - lun62 = -1 - if (idiagaa_ecpp(62) > 0) lun62 = ldiagaa_ecpp(62) - - activate_onoff_use = 0 - if ( (nphase_aer >= 2) .and. & - (ai_phase > 0) .and. (cw_phase > 0) ) & - activate_onoff_use = activat_onoff_ecpp - -! in sub-classes with area ~= 0, chem_sub is set to chem_bar -! EXCEPT for aerosol species, where activated=0 in clear, -! and activated=interstitial=0.5*chem_bar in cloudy - chem_bar_iccfactor(:,:) = 1.0_r8 - if (activate_onoff_use > 0) then - do l = param_first_ecpp, num_chem_ecpp - if ( is_aerosol(l) ) then - if (iphase_of_aerosol(l) == ai_phase) then - chem_bar_iccfactor(2,l) = 1.0_r8 - else if (iphase_of_aerosol(l) == cw_phase) then - chem_bar_iccfactor(2,l) = 1.0_r8 - chem_bar_iccfactor(1,l) = 1.0_r8 - end if - end if - end do - end if - -! -! output the original fields with same format as ppboxmakeinp01 -! - ll = 116 - lun = ldiagaa_ecpp(ll) - if ((idiagaa_ecpp(ll) > 0) .and. (lun > 0)) then - call parampollu_1clm_dumpaa( & - ktau, dtstep, ktau_pp, dtstep_pp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - kdraft_bot_ecpp, kdraft_top_ecpp, & - mtype_updnenv_ecpp, & - mfbnd_ecpp, abnd_tavg_ecpp, & - acen_tavg_ecpp, acen_tbeg_ecpp, acen_tfin_ecpp, & - it, jt, kts,ktebnd,ktecen, & - lun ) - end if - - -! -! check and adjust input information -! and do startup calcs (for this parampollu timestep) -! - do ipass_check_adjust_inputs = 1, 2 - - call parampollu_check_adjust_inputs( & - ipass_check_adjust_inputs, & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - kdraft_bot_ecpp, kdraft_top_ecpp, & - mtype_updnenv_ecpp, & - mfbnd_ecpp, abnd_tavg_ecpp, & - acen_tavg_ecpp, acen_tfin_ecpp, acen_prec_ecpp, & - wbnd_bar_use, & - ncls_use, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - mfbnd_use, mfbnd_quiescn_up, mfbnd_quiescn_dn, & - abnd_tavg_use, & - acen_tavg_use, acen_tfin_use, acen_prec_use, & - rhodz_cen, & - it, jt, kts,ktebnd,ktecen ) - -! do startup calcs (for this parampollu timestep) - if (ipass_check_adjust_inputs == 1) then - acen_tbeg_use(:,:,:) = acen_tbeg_ecpp(:,:,:) - else - call parampollu_tdx_startup( & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - rhocen_bar, dzcen, & - chem_bar, chem_cls, & - ncls_ecpp, & - acen_tbeg_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - chem_sub_beg, & - acen_tbeg_use, ardz_cen_tbeg, rhodz_cen, & - activate_onoff_use, & - iphase_of_aerosol, laicwpair_of_aerosol ) - end if - -! output the adjusted fields with same format as ppboxmakeinp01 - if (ipass_check_adjust_inputs == 1) then - acen_tavg_usex1(:,:,:) = acen_tavg_use(:,:,:) - acen_tfin_usex1(:,:,:) = acen_tfin_use(:,:,:) - abnd_tavg_usex1(:,:,:) = abnd_tavg_use(:,:,:) - mfbnd_usex1( :,:,:) = mfbnd_use( :,:,:) - ll = 117 - else - ll = 115 - end if - - lun = ldiagaa_ecpp(ll) - if ((idiagaa_ecpp(ll) > 0) .and. (lun > 0)) then - call parampollu_1clm_dumpaa( & - ktau, dtstep, ktau_pp, dtstep_pp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar_use, & - chem_bar, & - ncls_use, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - mfbnd_use, abnd_tavg_use, & - acen_tavg_use, acen_tbeg_use, acen_tfin_use, & - it, jt, kts,ktebnd,ktecen, & - lun ) - end if - - end do ! ipass_check_adjust_inputs - - - -! *** temporary exit - if (iflag_ecpp_test_bypass_1 > 0) return - - -! save values in these arrays - acen_tbeg_usex1(:,:,:) = acen_tbeg_use(:,:,:) - chem_sub_new(:,:,:,:) = chem_sub_beg(:,:,:,:) - - del_activate3d(:,:,:,:) = 0.0_r8 - -! calc "area*rho*dz" and "area*rho" arrays - ardz_cen_tavg(:,:,:) = 0.0_r8 - ardz_cen_tfin(:,:,:) = 0.0_r8 - ar_bnd_tavg(:,:,:) = 0.0_r8 - do k = kts, ktebnd - do icc = 0, 2 - ar_bnd_tavg( k,icc,0:ncls_use) = abnd_tavg_use(k,icc,0:ncls_use)*rhobnd_bar(k) - if (k > ktecen) cycle - ardz_cen_tavg(k,icc,0:ncls_use) = acen_tavg_use(k,icc,0:ncls_use)*rhodz_cen(k) - ardz_cen_tfin(k,icc,0:ncls_use) = acen_tfin_use(k,icc,0:ncls_use)*rhodz_cen(k) - end do - end do - - -! -! apply area changes (acen_tbeg_use --> ... --> acen_tfin_use) here -! parampollu_opt == 2220 -! apply area changes in one step, before 15000 loop -! parampollu_opt == 2223 -! apply area changes in two steps, before and after 15000 loop -! - ardz_cen_old(:,:,:) = ardz_cen_tbeg(:,:,:) - if (parampollu_opt == 2220) then - ardz_cen_new(:,:,:) = ardz_cen_tfin(:,:,:) - else if (parampollu_opt == 2223) then - ardz_cen_new(:,:,:) = ardz_cen_tavg(:,:,:) - else - stop - end if - -! note about parampollu_tdx_area_change and parampollu_tdx_main_integ -! initial values are taken from chem_sub_new -! final values are put into chem_sub_new - ipass_area_change = 1 - call parampollu_tdx_area_change( aero_props, & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, ipass_area_change, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - chem_sub_new, & - del_activate3d, & - mfbnd_use, ar_bnd_tavg, & - ardz_cen_old, ardz_cen_new, rhodz_cen, & - chem_bar_iccfactor, activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol ) - - - -! save current chem_sub values - chem_sub_ac1sv(:,:,:,:) = 0.0_r8 - chem_sub_ac1sv(kts:ktecen,1:2,1:ncls_use,1:num_chem_ecpp) = & - chem_sub_new(kts:ktecen,1:2,1:ncls_use,1:num_chem_ecpp) -! initialize chem_sub hybrid-sum - chem_sub_hysum(:,:,:,:) = 0.0_r8 - - ntstep_hybrid = nint( draft_lifetime / dtstep ) - ntstep_hybrid = max( 1, ntstep_hybrid ) - if (lun62 > 0) write(lun62,'(a,2i10)') & - 'parampollu_td240clm - ktau, ntstep_hybrid', & - ktau, ntstep_hybrid - - - del_chem_clm_cldchem(:) = 0.0_r8 - del_chem_clm_rename(:) = 0.0_r8 - del_cldchem3d(:,:,:,:,:) = 0.0_r8 - del_rename3d(:,:,:,:,:) = 0.0_r8 - del_chem_clm_wetscav(:) = 0.0_r8 - del_wetscav3d(:,:,:,:,:) = 0.0_r8 - del_wetresu3d(:,:,:,:,:) = 0.0_r8 - del_activate3da(:,:,:,:) = 0.0_r8 - - aqso4_h2o2 = 0.0_r8 - aqso4_o3 = 0.0_r8 - xphlwc3d(:,:,:,:) = 0.0_r8 - -itstep_hybrid_loop: & - do itstep_hybrid = 1, ntstep_hybrid - ktau_pp = itstep_hybrid + 100 - -! -! main integration -! - ardz_cen_old(:,:,:) = ardz_cen_new(:,:,:) - - call parampollu_tdx_main_integ( aero_props, & - ktau, dtstep, ktau_pp, dtstep_pp, & - itstep_hybrid, ntstep_hybrid, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - chem_sub_new, & - del_chem_clm_cldchem, del_chem_clm_rename, del_chem_clm_wetscav, & - del_cldchem3d, del_rename3d, & - del_wetscav3d, del_wetresu3d, & - del_activate3da, & - aqso4_h2o2, aqso4_o3, xphlwc3d, & - mfbnd_use, mfbnd_quiescn_up, mfbnd_quiescn_dn, & - ar_bnd_tavg, & - ardz_cen_old, ardz_cen_new, rhodz_cen, & - acen_tavg_use, acen_prec_use, & - rh_sub2, qcloud_sub2, qlsink_sub2, & - precr_sub2, precs_sub2, & - chem_bar_iccfactor, activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol, pbuf ) - - - do l = param_first_ecpp, num_chem_ecpp - do jcls = 1, ncls_use -! increment chem_sub_hysum - if ((jcls == jcls_qu) .or. (itstep_hybrid == ntstep_hybrid)) then -! for quiescent (all steps) or up/dndrafts (final step), use chem_sub_new - chem_sub_hysum(kts:ktecen,1:2,jcls,l) = & - chem_sub_hysum(kts:ktecen,1:2,jcls,l) + & - chem_sub_new(kts:ktecen,1:2,jcls,l) - else -! for up/dndrafts (all but final step), use chem_sub_ac1sv - chem_sub_hysum(kts:ktecen,1:2,jcls,l) = & - chem_sub_hysum(kts:ktecen,1:2,jcls,l) + & - chem_sub_ac1sv(kts:ktecen,1:2,jcls,l) - end if - -! on all but final step, prepare for next main_integ by -! restoring jcls_qu to chem_sub_ac1sv values - if ((jcls == jcls_qu) .and. (itstep_hybrid < ntstep_hybrid)) then - chem_sub_new( kts:ktecen,1:2,jcls,l) = & - chem_sub_ac1sv(kts:ktecen,1:2,jcls,l) - end if - -! on (after) final step, convert chem_sub_hysum to an average -! and load into chem_sub_new - if (itstep_hybrid == ntstep_hybrid) then - tmpa = 1.0_r8/ntstep_hybrid - chem_sub_new( kts:ktecen,1:2,jcls,l) = & - chem_sub_hysum(kts:ktecen,1:2,jcls,l)*tmpa - end if - - end do ! jcls - end do ! l - - - end do itstep_hybrid_loop - - tmpa = ntstep_hybrid ; tmpa = 1.0_r8/tmpa - del_chem_clm_cldchem(:) = del_chem_clm_cldchem(:)*tmpa - del_chem_clm_rename(:) = del_chem_clm_rename(:)*tmpa - del_cldchem3d(:,:,:,:,:) = del_cldchem3d(:,:,:,:,:) * tmpa - del_rename3d(:,:,:,:,:) = del_rename3d(:,:,:,:,:) * tmpa - del_chem_clm_wetscav(:) = del_chem_clm_wetscav(:)*tmpa - del_wetscav3d(:,:,:,:,:) = del_wetscav3d(:,:,:,:,:)*tmpa - del_wetresu3d(:,:,:,:,:) = del_wetresu3d(:,:,:,:,:)*tmpa - del_activate3d(:,:,:,:) = del_activate3d(:,:,:,:) + del_activate3da(:,:,:,:) * tmpa - - aqso4_h2o2 = aqso4_h2o2 * tmpa - aqso4_o3 = aqso4_o3 * tmpa - xphlwc3d(:,:,:,:) = xphlwc3d(:,:,:,:) * tmpa - - - ktau_pp = 20 - - -! when parampollu_opt == 2223, do 2nd half of area change here - if (parampollu_opt == 2223) then - ipass_area_change = 2 - ardz_cen_old(:,:,:) = ardz_cen_new(:,:,:) - ardz_cen_new(:,:,:) = ardz_cen_tfin(:,:,:) - - call parampollu_tdx_area_change( aero_props, & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, ipass_area_change, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - chem_sub_new, & - del_activate3d, & - mfbnd_use, ar_bnd_tavg, & - ardz_cen_old, ardz_cen_new, rhodz_cen, & - chem_bar_iccfactor, activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol ) - - end if - - -! do "cleanup" - call parampollu_tdx_cleanup( & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - chem_bar, chem_cls, & - ncls_ecpp, & - acen_tfin_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - chem_sub_beg, chem_sub_new, & - del_chem_clm_cldchem, del_chem_clm_wetscav, & - del_cldchem3d, del_rename3d, & - del_wetscav3d, del_wetresu3d, & - del_activate3d, del_conv3d, & - acen_tbeg_use, acen_tfin_use, rhodz_cen, & - activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol ) - - -! output precip info -! - if (ktau <= 1) then - tmpvecsva(:) = 0.0_r8 ; tmpvecsvb(:) = 0.0_r8 ; tmpvecsvc(:) = 0.0_r8 - end if - tmpveca(:) = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - tmpe = max( 0.0_r8, acen_prec_use(kts,icc,jcls) ) - tmpf = max( 0.0_r8, acen_tavg_use(kts,icc,jcls) - tmpe ) - tmpg = max( 0.0_r8, precr_sub2(kts,icc,jcls,2) ) + & - max( 0.0_r8, precs_sub2(kts,icc,jcls,2) ) - tmph = max( 0.0_r8, precr_sub2(kts,icc,jcls,1) ) + & - max( 0.0_r8, precs_sub2(kts,icc,jcls,1) ) - tmpveca(1) = tmpveca(1) + tmpg - tmpveca(2) = tmpveca(2) + tmph - tmpveca(3) = tmpveca(3) + tmpg*tmpe - tmpveca(4) = tmpveca(4) + tmph*tmpf - do k = kts, ktecen - tmpe = max( 0.0_r8, acen_prec_use(k,icc,jcls) ) - tmpf = max( 0.0_r8, acen_tavg_use(k,icc,jcls) - tmpe ) - tmpg = max( 0.0_r8, precr_sub2(k,icc,jcls,2) ) + & - max( 0.0_r8, precs_sub2(k,icc,jcls,2) ) - tmph = max( 0.0_r8, precr_sub2(k,icc,jcls,1) ) + & - max( 0.0_r8, precs_sub2(k,icc,jcls,1) ) - tmpa = tmpg*tmpe + tmph*tmpf - end do - end do - end do - - if (mod(ktau,18) == 0 .and. ktau.ge.1) then - tmpa = 3600.0_r8/ktau ! converts accumulated precip to time avg and mm/h - end if - - if (mod(ktau,18) == 0 .and. ktau.ge.1) then - do k = kts, ktecen, 5 - tmpveca(:) = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - tmpe = max( 0.0_r8, acen_prec_use(k,icc,jcls) ) - tmpf = max( 0.0_r8, acen_tavg_use(k,icc,jcls) - tmpe ) - tmpveca(1) = tmpveca(1) + & - tmpe*max( 0.0_r8, rh_sub2(k,icc,jcls,2) ) + & - tmpf*max( 0.0_r8, rh_sub2(k,icc,jcls,1) ) - tmpveca(2) = tmpveca(2) + & - tmpe*max( 0.0_r8, precr_sub2(k,icc,jcls,2) ) + & - tmpf*max( 0.0_r8, precr_sub2(k,icc,jcls,1) ) - tmpveca(3) = tmpveca(3) + & - tmpe*max( 0.0_r8, precs_sub2(k,icc,jcls,2) ) + & - tmpf*max( 0.0_r8, precs_sub2(k,icc,jcls,1) ) - tmpveca(4) = tmpveca(4) + & - tmpe*max( 0.0_r8, qcloud_sub2(k,icc,jcls,2) ) + & - tmpf*max( 0.0_r8, qcloud_sub2(k,icc,jcls,1) ) - end do - end do - tmpveca(3) = tmpveca(3) + tmpveca(2) - end do - end if - -! -! all done -! - if (lun62 > 0) write(lun62,*) '*** leaving parampollu_td240clm' - return - end subroutine parampollu_td240clm - - - -!----------------------------------------------------------------------- - subroutine parampollu_tdx_main_integ( aero_props, & - ktau, dtstep, ktau_pp, dtstep_pp, & - itstep_hybrid, ntstep_hybrid, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - chem_sub_new, & - del_chem_clm_cldchem, del_chem_clm_rename, del_chem_clm_wetscav, & - del_cldchem3d, del_rename3d, & - del_wetscav3d, del_wetresu3d, & - del_activate3d, & - aqso4_h2o2, aqso4_o3, xphlwc3d, & - mfbnd_use, mfbnd_quiescn_up, mfbnd_quiescn_dn, & - ar_bnd_tavg, & - ardz_cen_old, ardz_cen_new, rhodz_cen, & - acen_tavg_use, acen_prec_use, & - rh_sub2, qcloud_sub2, qlsink_sub2, & - precr_sub2, precs_sub2, & - chem_bar_iccfactor, activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol, pbuf ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_tdx_main_integ does the "main integration" -! of the trace-species conservation equations over time-step dtstep_pp -! -! incoming chem_sub_new holds current sub-class mixing ratios -! outgoing chem_sub_new holds updated sub-class mixing ratios -! -! treats -! sub-grid vertical transport and associated horizontal exchange -! (entrainment and detrainment) -! activation/resuspension -! cloud chemistry and wet removal -! -! does not treat -! horizontal exchange associated with sub-class area changes -! -!----------------------------------------------------------------------- - - use module_data_radm2, only: epsilc - - use module_data_mosaic_asect, only: ai_phase, cw_phase, & - massptr_aer, maxd_asize, maxd_atype, & - ncomp_aer, nphase_aer, nsize_aer, ntype_aer, numptr_aer - - use module_data_ecpp1 - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message - -! arguments - type(modal_aerosol_properties), intent(in) :: aero_props - integer, intent(in) :: & - ktau, ktau_pp, & - itstep_hybrid, ntstep_hybrid, & - it, jt, kts, ktebnd, ktecen -! ktau - time step number -! ktau_pp - time step number for "parameterized pollutants" calculations -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) - - real(r8), intent(in) :: dtstep, dtstep_pp -! dtstep - main model time step (s) -! dtstep_pp - time step (s) for "parameterized pollutants" calculations - - real(r8), intent(in), dimension( kts:ktecen ) :: & - tcen_bar, pcen_bar, rhocen_bar, dzcen - real(r8), intent(in), dimension( kts:ktebnd ) :: & - rhobnd_bar, wbnd_bar, zbnd -! tcen_bar - temperature (K) at layer centers -! rhocen_bar, rhobnd_bar - dry air density (kg/m^3) at layer centers and boundaries -! pcen_bar - air pressure (Pa) at layer centers -! wbnd_bar - vertical velocity (m/s) at layer boundaries -! zbnd - elevation (m) at layer boundaries -! dzcen - layer thicknesses (m) - - real(r8), intent(in), dimension( kts:ktecen, 1:num_chem_ecpp ) :: & - chem_bar -! chem_bar - mixing ratios of trace gase (ppm) and aerosol species -! (ug/kg for mass species, #/kg for number species) - - integer, intent(in) :: ncls_ecpp -! ncls_ecpp - number of ecpp transport classes in the grid column - - integer, intent(in) :: ncls_use - - integer, intent(in), dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use - - real(r8), intent(inout), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_new - - real(r8), intent(inout), dimension( 1:num_chem_ecpp ) :: del_chem_clm_cldchem, del_chem_clm_rename, del_chem_clm_wetscav - - real(r8), intent(inout), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:num_chem_ecpp ) :: & - del_cldchem3d, & ! 3D change from aqueous chemistry - del_rename3d, & ! 3D change from renaming (modal merging) - del_wetscav3d, & ! 3D change from wet deposition - del_wetresu3d - - real(r8), intent(inout), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - del_activate3d ! 3D change from activation/resuspension - - real(r8), intent(inout) :: aqso4_h2o2, & ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - aqso4_o3 ! SO4 aqueous phase chemistry due to O3 (kg/m2) - - real(r8), intent(inout), dimension(kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2) :: & - xphlwc3d ! pH value multiplied by lwc - - real(r8), intent(inout), dimension( kts:ktebnd, 0:2, 0:maxcls_ecpp ) :: & - mfbnd_use, ar_bnd_tavg - - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - ardz_cen_old, ardz_cen_new, acen_tavg_use, acen_prec_use - - real(r8), intent(inout), dimension( kts:ktebnd, 0:2, 0:2 ) :: & - mfbnd_quiescn_up, mfbnd_quiescn_dn - - real(r8), intent(inout), dimension( kts:ktecen ) :: rhodz_cen - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2 ) :: & - rh_sub2, qcloud_sub2, qlsink_sub2, precr_sub2, precs_sub2 - - real(r8), intent(in), dimension( 1:2, num_chem_ecpp ) :: chem_bar_iccfactor - - integer, intent(in) :: activate_onoff_use - - integer, intent(in), dimension( 1:num_chem_ecpp ) :: & - iphase_of_aerosol, isize_of_aerosol, itype_of_aerosol, & - inmw_of_aerosol, laicwpair_of_aerosol - type(physics_buffer_desc), pointer :: pbuf(:) - - - -! local variables - integer, parameter :: activate_onoff_testaa = 1 - integer :: icc, iccb, iccy, ido_actres_tmp, ifrom_where, & - itstep_sub, itmpa, iupdn - integer :: idiag118_pt1, idiag118_pt2, idiag118_pt3 - integer :: idiagbb_wetscav - integer :: jcls, jclsy - integer :: k, kb, l, la, laa, lbb, lc, lun118, lun124 - integer :: m, n, ntstep_sub - integer, save :: ntstep_sub_sum = 0 - integer :: p1st - - integer, dimension( 1:2, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp ) :: & - ido_actres_horz - - logical :: not_aicw - - real(r8) :: ardz_cut - real(r8) :: dtstep_sub - real(r8) :: tmpa, tmpb, tmpc, tmpd - real(r8) :: tmpcourout, tmpcourmax - real(r8) :: tmp_ardz, tmp_del_ardz - real(r8) :: tmp_ardzqa, tmp_del_ardzqa - real(r8) :: tmp_ardzqc, tmp_del_ardzqc - real(r8) :: tmp_del_ardzqa_act, tmp_del_ardzqc_act - real(r8) :: tmp_fmnact - real(r8) :: tmp_qyla, tmp_qylc - real(r8) :: tmp2dxa(0:2,0:maxcls_ecpp), tmp2dxb(0:2,0:maxcls_ecpp) - real(r8) :: xntstep_sub_inv - - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_old - real(r8), dimension( 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ent_airamt_tot, det_airamt_tot - real(r8), dimension( 1:2, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ent_airamt, det_airamt - real(r8), dimension( 1:maxd_asize, 1:maxd_atype, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - fmact_horz, fnact_horz - real(r8), dimension( 1:maxd_asize, 1:maxd_atype, kts:ktecen ) :: & - fmact_vert, fnact_vert - real(r8), dimension( kts:ktebnd, 0:maxcls_ecpp, 1:num_chem_ecpp ) :: & - tmpverta, tmphoriz - - real(r8) :: frc_ent_act ! the fraction of updraft entrainment that may experince activation +++mhwang - real(r8) :: frc_tmp - real(r8) :: abnd_up ! cloud fraction in the upper boundary - real(r8) :: abnd_dn ! cloud fraction in the lower boundary - - call t_startf('ecpp_mainintegr') - - p1st = param_first_ecpp - - idiag118_pt1 = 10 * mod( max(idiagaa_ecpp(118),0)/1, 10 ) - idiag118_pt2 = 10 * mod( max(idiagaa_ecpp(118),0)/10, 10 ) - idiag118_pt3 = 10 * mod( max(idiagaa_ecpp(118),0)/100, 10 ) - - lun124 = -1 - if (idiagaa_ecpp(124) > 0) lun124 = ldiagaa_ecpp(124) - - idiagbb_wetscav = 0 - -! -! calc entrain/detrain amounts -! -! first calc net (entrainment-detrainment) amount = area change - ent_airamt_tot(:,:,:) = 0.0_r8 - det_airamt_tot(:,:,:) = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - do k = kts, ktecen - ardz_cut = afrac_cut*rhodz_cen(k)*0.3_r8 - tmpa = max( ardz_cen_new(k,icc,jcls), ardz_cen_old(k,icc,jcls) ) - if (tmpa < ardz_cut) cycle ! k loop - - if (jcls /= jcls_qu) then -! this is for area change -! tmpb = ardz_cen_new(k,icc,jcls) - ardz_cen_old(k,icc,jcls) -! this is for vertical mass flux divergence/convergence - tmpb = (mfbnd_use(k+1,icc,jcls) - mfbnd_use(k,icc,jcls))*dtstep_pp - if (tmpb > 0.0_r8) then - ent_airamt_tot(icc,jcls,k) = tmpb - else if (tmpb < 0.0_r8) then - det_airamt_tot(icc,jcls,k) = -tmpb - end if - - else - ! +mfbnd_quiescn_up(k+1,icc,0 ) is upwards outflow from sub-class - ! at top of layer (and is >= 0) - ! +mfbnd_quiescn_dn(k+1,0 ,icc) is dnwards inflow to sub-class - ! at top of layer (and is <= 0) - ! -mfbnd_quiescn_up(k ,0, ,icc) is upwards inflow to sub-class - ! at bottom of layer (and is <= 0) - ! -mfbnd_quiescn_dn(k ,icc,0 ) is dnwards outflow from sub-class - ! at bottom of layer (and is >= 0) - ! tmpb = net vertical in/outflows - ! (positive if net outflow, negative if net inflow) - tmpb = ( mfbnd_quiescn_up(k+1,icc,0 ) & - + mfbnd_quiescn_dn(k+1,0 ,icc) & - - mfbnd_quiescn_up(k ,0 ,icc) & - - mfbnd_quiescn_dn(k ,icc,0 ) )*dtstep_pp - if (tmpb > 0.0_r8) then - ent_airamt_tot(icc,jcls,k) = tmpb - else if (tmpb < 0.0_r8) then - det_airamt_tot(icc,jcls,k) = -tmpb - end if - - end if - end do - end do - end do - -! next calc detailed ent/det amounts - call t_startf('ecpp_entdet') - ifrom_where = 10 - call parampollu_tdx_entdet_sub1( & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, ifrom_where, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - ardz_cen_old, ardz_cen_new, rhodz_cen, & - ent_airamt_tot, det_airamt_tot, & - ent_airamt, det_airamt ) - call t_stopf('ecpp_entdet') - - -! -! calc activation/resuspension fractions associated with ent/det -! and vertical transport -! - if (activate_onoff_use > 0) then - call t_startf('ecpp_activate') - ifrom_where = 10 - call parampollu_tdx_activate1( aero_props, & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, wbnd_bar, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, ifrom_where, activate_onoff_use, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - chem_sub_new, & - mfbnd_use, & - ar_bnd_tavg, & - ent_airamt, & - ido_actres_horz, fmact_horz, fnact_horz, & - fmact_vert, fnact_vert, mfbnd_quiescn_up ) - call t_stopf('ecpp_activate') - end if - - -! -! determine number of integration sub-steps -! calc "outflow" courant number for each sub-class -! = (sum of outflow air-mass fluxes) * dt / ardz_cen -! calc tmpcourmax = maximum outflow courant number -! for all layers and sub-classes -! select ntstep_sub (number of integration sub-steps) so that -! (tmpcourmax/ntstep_sub) <= 1.0 -! - if (lun124 > 0) & - write( lun124, '(/a,2i5/a)' ) 'new courout stuff -- ktau, ktau_pp', ktau, ktau_pp, & - 'k, tmpcouroutc(qu), tmpcouroutb(up), tmpcouroutb(dn)' - tmp2dxb(:,:) = -1.0_r8 - tmpcourmax = 0.0_r8 - do k = ktecen, kts, -1 - ardz_cut = afrac_cut*rhodz_cen(k)*0.3_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - -! tmpa = (air-mass leaving sub-class over dtstep_pp by vertical mass flux) - if (jcls == jcls_qu) then - tmpa = mfbnd_quiescn_up(k+1,icc,0) - mfbnd_quiescn_dn(k,icc,0) - else - tmpa = max(0.0_r8,mfbnd_use(k+1,icc,jcls)) + max(0.0_r8,-mfbnd_use(k,icc,jcls)) - end if - tmpa = tmpa*dtstep_pp -! tmpb = tmpa + (air-mass leaving sub-class over dtstep_pp by horizontal detrainment) - tmpb = tmpa + max(0.0_r8,det_airamt_tot(icc,jcls,k)) - -! (area*rho*dz) is fixed at ardz_cen_new during the integration loop - tmp_ardz = ardz_cen_new(k,icc,jcls) - - if (tmp_ardz < ardz_cut) then - tmpcourout = 0.0_r8 - else if (tmpb > 1.0e3_r8*tmp_ardz) then - tmpcourout = 1.0e3_r8 - else - tmpcourout = tmpb/tmp_ardz - end if - - tmpcourmax = max( tmpcourmax, tmpcourout ) - tmp2dxa(icc,jcls) = tmpcourout - tmp2dxb(icc,jcls) = max( tmp2dxb(icc,jcls), tmpcourout ) - end do ! icc - end do ! jcls - if (lun124 > 0) & - write( lun124, '(i3,1p,3e12.4,2x,3e12.4)' ) k, (tmp2dxa(iccy,1:3), iccy=1,2) - end do ! k - if (lun124 > 0) & - write( lun124, '( a,1p,3e12.4,2x,3e12.4)' ) 'max', (tmp2dxb(iccy,1:3), iccy=1,2) - - if (tmpcourmax > 1.0_r8) then - tmpa = max( 0.0_r8, tmpcourmax-1.0e-7_r8 ) - ntstep_sub = 1 + int( tmpa ) - else - ntstep_sub = 1 - end if - ntstep_sub_sum = ntstep_sub_sum + ntstep_sub - dtstep_sub = dtstep_pp/ntstep_sub - xntstep_sub_inv = 1.0_r8/ntstep_sub - - lun118 = -1 - if (idiag118_pt2 > 0) lun118 = ldiagaa_ecpp(118) - if (lun118 > 0) then - write(lun118,'(a,1p,2e12.4,2i12)') & - ' tmpcourmax, dtstep_sub, nstep_sub =', tmpcourmax, dtstep_sub, & - ntstep_sub, ntstep_sub_sum - end if - if (lun124 > 0) & - write( lun124, '(a,1p,2e12.4,2i12)' ) & - ' tmpcourmax, dtstep_sub, nstep_sub =', tmpcourmax, dtstep_sub, & - ntstep_sub, ntstep_sub_sum - - - -! -! do multiple integration sub-steps -! apply vertical transport and balancing entrainment/detrainment -! -! area change is done elsewhere, so area is fixed at ardz_cen_new -! during the integration loop -! -main_itstep_sub_loop: & - do itstep_sub = 1, ntstep_sub - - call t_startf('ecpp_vertical') - -! copy "current" chem_sub values to chem_sub_old - chem_sub_old(:,:,:,:) = chem_sub_new(:,:,:,:) - - - tmpverta(:,:,:) = 0.0_r8 - tmphoriz( :,:,:) = 0.0_r8 - -! calculate "transport" changes to chem_sub over one time sub-step -! (vertical transport and horizontal exchange, including activation/resuspension) -main_trans_jcls_loop: & - do jcls = 1, ncls_use -main_trans_icc_loop: & - do icc = 1, 2 -main_trans_k_loop: & - do k = kts, ktecen - - -! if area ~= 0, then just set chem_sub_new to chem_bar - ardz_cut = afrac_cut*rhodz_cen(k)*0.3_r8 - if (ardz_cen_new(k,icc,jcls) < ardz_cut) then - do l = param_first_ecpp, num_chem_ecpp - chem_sub_new(k,icc,jcls,l) = & - chem_bar(k,l)*chem_bar_iccfactor(icc,l) - end do - cycle main_trans_k_loop - end if - - -! la loop goes over all species -! for la = non-aerosol species, loop is executed with lc=0 -! for la = interstitial aerosol species, loop is excecuted with -! lc=activated counterpart -! for la = activated aerosol species, loop is skipped -main_trans_la_loop: & - do la = p1st, num_chem_ecpp - - tmp_del_ardzqa_act = 0.0_r8 - tmp_del_ardzqc_act = 0.0_r8 - - lc = 0 - l = -999888777 - not_aicw = .true. -! if (activate_onoff_use > 999888777) then - if (activate_onoff_use > 0) then - if (iphase_of_aerosol(la) == ai_phase) then - lc = laicwpair_of_aerosol(la) - not_aicw = .false. - else if (iphase_of_aerosol(la) == cw_phase) then - cycle main_trans_la_loop - end if - end if - if ((lc < p1st) .or. (lc > num_chem_ecpp)) lc = -999888777 - m = isize_of_aerosol(la) ; if (m <= 0) m = -999888777 - n = itype_of_aerosol(la) ; if (n <= 0) n = -999888777 - - tmp_ardz = ardz_cen_old(k,icc,jcls) - tmp_ardzqa = chem_sub_old(k,icc,jcls,la)*tmp_ardz - tmp_ardzqc = 0.0_r8 - if (lc > 0) & - tmp_ardzqc = chem_sub_old(k,icc,jcls,lc)*tmp_ardz - -! subtract detrainment loss (no activation/resuspension here) - tmp_del_ardz = -det_airamt_tot(icc,jcls,k)*xntstep_sub_inv - if (tmp_del_ardz < 0.0_r8) then - tmp_ardz = tmp_ardz + tmp_del_ardz - tmp_ardzqa = tmp_ardzqa + chem_sub_old(k,icc,jcls,la)*tmp_del_ardz - tmphoriz(k,jcls,la) = tmphoriz(k,jcls,la) & - + chem_sub_old(k,icc,jcls,la)*tmp_del_ardz - if (lc > 0) then - tmp_ardzqc = tmp_ardzqc + chem_sub_old(k,icc,jcls,lc)*tmp_del_ardz - tmphoriz(k,jcls,lc) = tmphoriz(k,jcls,lc) & - + chem_sub_old(k,icc,jcls,lc)*tmp_del_ardz - end if - end if - -! add entrainment contributions (need activation/resuspension here) -! -!+++mhwang -! Calculate the fraction of entrainment that may expericence activations. -! (we assume only the new cloudy updraft may experience activation, and -! old updraft do not experience activation -! Minghuai Wang, 2010-05 - frc_ent_act = 1.0_r8 - if(mtype_updnenv_use(icc, jcls) == mtype_updraft_ecpp) then - abnd_up = 0.0_r8 - abnd_dn = 0.0_r8 - if(rhobnd_bar(k+1).gt.1.0e-10_r8) then - abnd_up = ar_bnd_tavg(k+1, icc, jcls)/rhobnd_bar(k+1) - end if - if(rhobnd_bar(k).gt.1.0e-10_r8) then - abnd_dn = ar_bnd_tavg(k, icc, jcls)/rhobnd_bar(k) - end if - if(k.eq.kts) then - frc_ent_act = 1.0_r8 - else if(abnd_up.gt.1.0e-5_r8) then - frc_ent_act = 1.0_r8 - min(1.0_r8, abnd_dn/abnd_up) - - if(mfbnd_use(k+1, icc, jcls).gt.1.0e-20_r8) then - frc_tmp = max(1.0e-5_r8, 1.0_r8-mfbnd_use(k, icc, jcls)/mfbnd_use(k+1, icc, jcls)) - frc_ent_act = min(1.0_r8, frc_ent_act / frc_tmp) - endif - end if - end if ! end mtype_updnenv_use -!---mhwang - - -entrain_jclsy_loop: & - do jclsy = 1, ncls_use -entrain_iccy_loop: & - do iccy = 1, 2 - tmp_del_ardz = ent_airamt(icc,jcls,iccy,jclsy,k)*xntstep_sub_inv - if (tmp_del_ardz <= 0.0_r8) cycle entrain_iccy_loop - - if ( not_aicw ) then - ido_actres_tmp = 0 - else - ido_actres_tmp = ido_actres_horz(icc,jcls,iccy,jclsy) - end if - - tmp_qyla = chem_sub_old(k,iccy,jclsy,la) - if (lc > 0) then - tmp_qylc = chem_sub_old(k,iccy,jclsy,lc) - else - tmp_qylc = 0.0_r8 - end if - tmp_ardz = tmp_ardz + tmp_del_ardz - - if (activate_onoff_testaa <= 0) ido_actres_tmp = 0 ! for testing -!+++mhwangtest -! turn activation in entrainment off -! ido_actres_tmp = 0 ! +++mhwangtest - - if (ido_actres_tmp == 0) then - ! non aicw-aerosol species OR no activation or resuspension - tmp_del_ardzqa = tmp_qyla*tmp_del_ardz - tmp_del_ardzqc = tmp_qylc*tmp_del_ardz - - else if (ido_actres_tmp > 0) then - ! activation of (la+lc) - if (inmw_of_aerosol(la) == 1) then -! tmp_fmnact = fnact_horz(m,n,jcls,iccy,jclsy,k) - tmp_fmnact = fnact_horz(m,n,jcls,iccy,jclsy,k) * frc_ent_act !+++mhwang - else -! tmp_fmnact = fmact_horz(m,n,jcls,iccy,jclsy,k) - tmp_fmnact = fmact_horz(m,n,jcls,iccy,jclsy,k) * frc_ent_act ! +++mhwang - end if - if (ido_actres_tmp == 2) then - tmp_del_ardzqa = (tmp_qyla+tmp_qylc)*(1.0_r8-tmp_fmnact)*tmp_del_ardz - tmp_del_ardzqc = (tmp_qyla+tmp_qylc)*(tmp_fmnact )*tmp_del_ardz - else - tmp_del_ardzqa = (tmp_qyla*(1.0_r8-tmp_fmnact) )*tmp_del_ardz - tmp_del_ardzqc = (tmp_qyla*tmp_fmnact + tmp_qylc)*tmp_del_ardz - end if - - else - ! resuspension of lc - tmp_del_ardzqa = (tmp_qyla+tmp_qylc)*tmp_del_ardz - tmp_del_ardzqc = 0.0_r8 - - end if - - tmp_ardzqa = tmp_ardzqa + tmp_del_ardzqa - tmp_ardzqc = tmp_ardzqc + tmp_del_ardzqc - tmphoriz(k,jcls,la) = tmphoriz(k,jcls,la) + tmp_del_ardzqa - if (lc > 0) & - tmphoriz(k,jcls,lc) = tmphoriz(k,jcls,lc) + tmp_del_ardzqc - -! change from activation/resuspension - tmp_del_ardzqa_act = tmp_del_ardzqa_act + (tmp_del_ardzqa - tmp_qyla*tmp_del_ardz) - if (lc > 0) & - tmp_del_ardzqc_act = tmp_del_ardzqc_act + (tmp_del_ardzqc - tmp_qylc*tmp_del_ardz) - - end do entrain_iccy_loop - end do entrain_jclsy_loop - - - if (jcls == jcls_qu) then -! quiescent class -- calc change to layer k mixrat due to vertical transport at lower boundary -! mfbnd_quiescn_up(k,icc1,icc2) is upwards mass flux from icc1 to icc2 -! at bottom of layer k -! mfbnd_quiescn_dn(k,icc1,icc2) is downwards ... -! activation/resuspension calcs -! k-1,clear to k,cloudy - do activation -! k-1,cloudy to k,clear - do resuspension -! k,either to k-1,either - are just calculating loss to k here, so no act/res needed -vert_botqu_iupdn_loop: & - do iupdn = 1, 2 - if (k <= kts) cycle vert_botqu_iupdn_loop ! skip k=kts -vert_botqu_iccy_loop: & - do iccy = 1, 2 - ! kb & iccy refer to the layer and sub-class from which - ! air and tracer mass are leaving - ido_actres_tmp = 0 - if (iupdn == 1) then - ! air is going from kb=k-1,iccb=iccy=1:2 to k,icc - tmp_del_ardz = mfbnd_quiescn_up(k,iccy,icc)*dtstep_sub - kb = k - 1 - iccb = iccy - if (not_aicw .eqv. .false.) then - if ((iccy == 1) .and. (icc == 2)) then - ido_actres_tmp = 1 - else if ((iccy == 2) .and. (icc == 1)) then - ido_actres_tmp = -1 - end if - end if - else - ! air is going from kb=k,iccb=icc to k-1,iccy=1:2 - ! since this is a loss from k, we can calc iccy=1&2 - ! together using mfbnd_quiescn_dn(k,icc,0) - if (iccy > 1) cycle vert_botqu_iccy_loop - tmp_del_ardz = mfbnd_quiescn_dn(k,icc,0)*dtstep_sub - kb = k - iccb = icc - end if - - if (tmp_del_ardz == 0.0_r8) cycle vert_botqu_iccy_loop - - tmp_qyla = chem_sub_old(kb,iccb,jcls,la) - if (lc > 0) then - tmp_qylc = chem_sub_old(kb,iccb,jcls,lc) - else - tmp_qylc = 0.0_r8 - end if - - tmp_ardz = tmp_ardz + tmp_del_ardz - - if (activate_onoff_testaa <= 0) ido_actres_tmp = 0 ! for testing -!+++mhwangtest -! turn activation in entrainment off -! ido_actres_tmp = 0 ! +++mhwangtest - if (ido_actres_tmp == 0) then - ! non aicw-aerosol species OR no activation or resuspension - tmp_del_ardzqa = tmp_qyla*tmp_del_ardz - tmp_del_ardzqc = tmp_qylc*tmp_del_ardz - - else if (ido_actres_tmp > 0) then - ! activation of (la+lc) - if (inmw_of_aerosol(la) == 1) then - tmp_fmnact = fnact_vert(m,n,k) - else - tmp_fmnact = fmact_vert(m,n,k) - end if - tmp_del_ardzqa = (tmp_qyla*(1.0_r8-tmp_fmnact) )*tmp_del_ardz - tmp_del_ardzqc = (tmp_qyla*tmp_fmnact + tmp_qylc)*tmp_del_ardz - - else - ! resuspension of lc - tmp_del_ardzqa = (tmp_qyla+tmp_qylc)*tmp_del_ardz - tmp_del_ardzqc = 0.0_r8 - - end if - - tmp_ardzqa = tmp_ardzqa + tmp_del_ardzqa - tmp_ardzqc = tmp_ardzqc + tmp_del_ardzqc - if (icc == 1) then - tmpverta(k,jcls,la) = tmpverta(k,jcls,la) + tmp_del_ardzqa - if (lc > 0) & - tmpverta(k,jcls,lc) = tmpverta(k,jcls,lc) + tmp_del_ardzqc - end if - -! change from activation/resuspension - tmp_del_ardzqa_act = tmp_del_ardzqa_act + (tmp_del_ardzqa - tmp_qyla*tmp_del_ardz) - if (lc > 0) & - tmp_del_ardzqc_act = tmp_del_ardzqc_act + (tmp_del_ardzqc - tmp_qylc*tmp_del_ardz) - - ! with "pgf90 -O2", code seg-faulted until following statement - ! was added. (note that it is do-nothing, since la>0 always) - if (la < 0) write(*,*) & - 'vert_botqu gggg - icc,iupdn,ido', iccy, iupdn, ido_actres_tmp - end do vert_botqu_iccy_loop - end do vert_botqu_iupdn_loop - -! quiescent class -- calc change to layer k mixrat due to vertical transport at upper boundary -! mfbnd_quiescn_up(k+1,icc1,icc2) is upwards mass flux from icc1 to icc2 -! at top of layer k -! mfbnd_quiescn_dn(k+1,icc1,icc2) is downwards ... -! activation/resuspension calcs -! k+1,clear to k,cloudy - downwards motion so skip activation ??? -! k+1,cloudy to k,clear - do resuspension -! k,either to k+1,either - are just calculating loss to k here, so no act/res needed -vert_topqu_iupdn_loop: & - do iupdn = 1, 2 - if (k >= ktebnd-1) cycle vert_topqu_iupdn_loop ! skip k=ktebnd-1,ktebnd -vert_topqu_iccy_loop: & - do iccy = 1, 2 - ido_actres_tmp = 0 - if (iupdn == 1) then - ! air is going from kb=k,iccb=icc to k+1,iccy=1:2 - ! since this is a loss from k, we can calc iccy=1&2 - ! together using mfbnd_quiescn_up(k+1,icc,0) - if (iccy > 1) cycle vert_topqu_iccy_loop - tmp_del_ardz = -mfbnd_quiescn_up(k+1,icc,0)*dtstep_sub - kb = k - iccb = icc - else - ! air is going from kb=k+1,iccb=iccy=1:2 to k,icc - tmp_del_ardz = -mfbnd_quiescn_dn(k+1,iccy,icc)*dtstep_sub - kb = k+1 - iccb = iccy - if (not_aicw .eqv. .false.) then - if ((iccy == 2) .and. (icc == 1)) then - ido_actres_tmp = -1 - end if - end if - end if - - if (tmp_del_ardz == 0.0_r8) cycle vert_topqu_iccy_loop - - tmp_qyla = chem_sub_old(kb,iccb,jcls,la) - if (lc > 0) then - tmp_qylc = chem_sub_old(kb,iccb,jcls,lc) - else - tmp_qylc = 0.0_r8 - end if - - tmp_ardz = tmp_ardz + tmp_del_ardz - - if (activate_onoff_testaa <= 0) ido_actres_tmp = 0 ! for testing -!+++mhwangtest -! turn activation in entrainment off -! ido_actres_tmp = 0 ! +++mhwangtest - if (ido_actres_tmp == 0) then - ! non aicw-aerosol species OR no activation or resuspension - tmp_del_ardzqa = tmp_qyla*tmp_del_ardz - tmp_del_ardzqc = tmp_qylc*tmp_del_ardz - - else if (ido_actres_tmp > 0) then - ! activation of (la+lc) - if (inmw_of_aerosol(la) == 1) then - tmp_fmnact = fnact_vert(m,n,k) - else - tmp_fmnact = fmact_vert(m,n,k) - end if - tmp_del_ardzqa = (tmp_qyla*(1.0_r8-tmp_fmnact) )*tmp_del_ardz - tmp_del_ardzqc = (tmp_qyla*tmp_fmnact + tmp_qylc)*tmp_del_ardz - - else - ! resuspension of lc - tmp_del_ardzqa = (tmp_qyla+tmp_qylc)*tmp_del_ardz - tmp_del_ardzqc = 0.0_r8 - - end if - - tmp_ardzqa = tmp_ardzqa + tmp_del_ardzqa - tmp_ardzqc = tmp_ardzqc + tmp_del_ardzqc - -! change from activation/resuspension - tmp_del_ardzqa_act = tmp_del_ardzqa_act + (tmp_del_ardzqa - tmp_qyla*tmp_del_ardz) - if (lc > 0) & - tmp_del_ardzqc_act = tmp_del_ardzqc_act + (tmp_del_ardzqc - tmp_qylc*tmp_del_ardz) - - ! with "pgf90 -O2", code seg-faulted until following statement - ! was added. (note that it is do-nothing, since la>0 always) - if (la < 0) write(*,*) & - 'vert_topqu gggg - icc,iupdn,ido', iccy, iupdn, ido_actres_tmp - end do vert_topqu_iccy_loop - end do vert_topqu_iupdn_loop - - - else -! up/dndraft class -- add/subtract vertical transport at lower boundary -! no activation/resuspension here as the vertical transport within up/dndrafts -! is clear-->clear or cloudy-->cloudy. (The within up/dndraft -! clear<-->cloudy is done by ent/detrainment.) - if (k > kts) then - tmp_del_ardz = mfbnd_use(k,icc,jcls)*dtstep_sub - if (abs(tmp_del_ardz) > 0.0_r8) then - if (tmp_del_ardz > 0.0_r8) then - kb = k - 1 - else - kb = k - end if - tmp_ardz = tmp_ardz + tmp_del_ardz - tmp_ardzqa = tmp_ardzqa + chem_sub_old(kb,icc,jcls,la)*tmp_del_ardz - if (lc > 0) & - tmp_ardzqc = tmp_ardzqc + chem_sub_old(kb,icc,jcls,lc)*tmp_del_ardz - if (icc == 1) then - tmpverta(k,jcls,la) = chem_sub_old(kb,icc,jcls,la)*tmp_del_ardz - if (lc > 0) & - tmpverta(k,jcls,lc) = chem_sub_old(kb,icc,jcls,lc)*tmp_del_ardz - end if - end if - end if ! (k > kts) -! up/dndraft class -- add/subtract vertical transport at upper boundary - if (k < ktebnd-1) then - tmp_del_ardz = -mfbnd_use(k+1,icc,jcls)*dtstep_sub - if (abs(tmp_del_ardz) > 0.0_r8) then - if (tmp_del_ardz > 0.0_r8) then - kb = k + 1 - else - kb = k - end if - tmp_ardz = tmp_ardz + tmp_del_ardz - tmp_ardzqa = tmp_ardzqa + chem_sub_old(kb,icc,jcls,la)*tmp_del_ardz - if (lc > 0) & - tmp_ardzqc = tmp_ardzqc + chem_sub_old(kb,icc,jcls,lc)*tmp_del_ardz - end if - end if ! (k < ktebnd-1) - - end if ! (jcls == jcls_qu) - - -! new mixing ratio - chem_sub_new(k,icc,jcls,la) = tmp_ardzqa/ardz_cen_new(k,icc,jcls) - if (lc > 0) & - chem_sub_new(k,icc,jcls,lc) = tmp_ardzqc/ardz_cen_new(k,icc,jcls) - -! change in mixing ratio (*fraction) from activation/resuspension - del_activate3d(k,icc,jcls,la) = del_activate3d(k,icc,jcls,la)+tmp_del_ardzqa_act/rhodz_cen(k) - if (lc > 0) & - del_activate3d(k,icc,jcls,lc) = del_activate3d(k,icc,jcls,lc)+tmp_del_ardzqc_act/rhodz_cen(k) - - end do main_trans_la_loop - - end do main_trans_k_loop - end do main_trans_icc_loop - end do main_trans_jcls_loop - - -! fort.118 diagnostics - lun118 = -1 - if (idiag118_pt3 > 0) then - if (idiag118_pt3 >= 10) lun118 = ldiagaa_ecpp(118) - if (itstep_sub == ntstep_sub) lun118 = ldiagaa_ecpp(118) - end if - if (lun118 > 0) then - do l = param_first_ecpp, num_chem_ecpp - if ((l == 9) .or. (l == 9)) then - - write(lun118,'(/a,3i5)') 'new_main_integ pt3 ktau_pp, istep_sub, l =', ktau_pp, itstep_sub, l - write(lun118,'(2a)') & - '(chem_sub_old(k,icc,jcls,l), chem_sub_new(k,icc,jcls,l), jcls=2,1,-1); ', & - 'updr ardz_cen_new and w; dumverta/b, dumhoriz for updr then env' - - icc = 1 - tmpc = 1.0_r8/dtstep_sub - do k = ktecen, kts, -1 - tmpa = 0.0_r8 - if (ar_bnd_tavg(k,icc,jgrp_up) > 0.0_r8) & - tmpa = mfbnd_use(k,icc,jgrp_up)/ar_bnd_tavg(k,icc,jgrp_up) - write(lun118,'(i3,1p,3(1x,2e10.3),2(1x,3e10.3))') k, & - ( chem_sub_old(k,icc,jcls,l), chem_sub_new(k,icc,jcls,l), jcls=2,1,-1 ), & - ardz_cen_new(k,icc,jgrp_up), tmpa, & - ( tmpverta(k,jcls,l)*tmpc, & - (tmpverta(k,jcls,l)-tmpverta(k+1,jcls,l))*tmpc, & - tmphoriz(k,jcls,l)*tmpc, jcls=2,1,-1 ) - end do ! k - - end if ! (l == ...) - end do ! l - end if ! (lun118 > 0) - - call t_stopf('ecpp_vertical') - - end do main_itstep_sub_loop - -! -! +++mhwang -! move cloud chemistry and wetscavenging outside of istep_sub_loop -! inside of the itstep_sub_loop is too expanseive -! Minghuai Wang, 2010-04-28 -! - itstep_sub = 1 - dtstep_sub = dtstep_pp - -! calculate cloud chemistry changes to chem_sub over one time sub-step -! call t_startf('ecpp_cldchem') -! call parampollu_tdx_cldchem( & -! ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & -! itstep_hybrid, & -! idiagaa_ecpp, ldiagaa_ecpp, & -! tcen_bar, pcen_bar, rhocen_bar, dzcen, & -! rhobnd_bar, zbnd, wbnd_bar, & -! chem_bar, & -! ncls_ecpp, & -! it, jt, kts,ktebnd,ktecen, & -! ncls_use, & -! kdraft_bot_use, kdraft_top_use, & -! mtype_updnenv_use, & -! chem_sub_new, & -! del_chem_clm_cldchem, del_chem_clm_rename, del_cldchem3d, del_rename3d, & -! aqso4_h2o2, aqso4_o3, xphlwc3d, & -! ardz_cen_old, ardz_cen_new, rhodz_cen, & -! acen_tavg_use, acen_prec_use, & -! rh_sub2, qcloud_sub2, qlsink_sub2, & -! precr_sub2, precs_sub2, & -! chem_bar_iccfactor, activate_onoff_use, & -! iphase_of_aerosol, isize_of_aerosol, & -! itype_of_aerosol, inmw_of_aerosol, & -! laicwpair_of_aerosol ) -! call t_stopf('ecpp_cldchem') - - -! calculate wet removal changes to chem_sub over one time sub-step - - if (wetscav_onoff_ecpp >= 100) then - call t_startf('ecpp_wetscav') -! write(*,'(a,3i8)') 'main integ calling wetscav_2', ktau, ktau_pp, itstep_sub - call parampollu_tdx_wetscav_2( & - ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & - itstep_hybrid, & - idiagaa_ecpp, ldiagaa_ecpp, idiagbb_wetscav, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & -! rhobnd_bar, zbnd, wbnd_bar, & not needed ? -! chem_bar, & not needed ? -! ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & -! kdraft_bot_use, kdraft_top_use, & not needed ? -! mtype_updnenv_use, & not needed ? - chem_sub_new, & - del_chem_clm_wetscav, & - del_wetscav3d, del_wetresu3d, & -! ardz_cen_old, ardz_cen_new, & not needed ? - rhodz_cen, & - acen_tavg_use, acen_prec_use, & - rh_sub2, qcloud_sub2, qlsink_sub2, & - precr_sub2, precs_sub2, & -! chem_bar_iccfactor, & not needed ? - activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol ) -! write(*,'(a,3i8)') 'main integ backfrm wetscav_2', ktau, ktau_pp, itstep_sub - call t_stopf('ecpp_wetscav') - end if ! (wetscav_onoff_ecpp >= 100) - -! calculate cloud chemistry changes to chem_sub over one time sub-step - call t_startf('ecpp_cldchem') - call parampollu_tdx_cldchem( & - ktau, dtstep, ktau_pp, itstep_sub, dtstep_sub, & - itstep_hybrid, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - chem_sub_new, & - del_chem_clm_cldchem, del_chem_clm_rename, del_cldchem3d, del_rename3d, & - aqso4_h2o2, aqso4_o3, xphlwc3d, & - ardz_cen_old, ardz_cen_new, rhodz_cen, & - acen_tavg_use, acen_prec_use, & - rh_sub2, qcloud_sub2, qlsink_sub2, & - precr_sub2, precs_sub2, & - chem_bar_iccfactor, activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol, pbuf ) - call t_stopf('ecpp_cldchem') - -! end do main_itstep_sub_loop - - call t_stopf('ecpp_mainintegr') - - - return - end subroutine parampollu_tdx_main_integ - - -!----------------------------------------------------------------------- - subroutine parampollu_tdx_area_change( aero_props, & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, ipass_area_change, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - chem_sub_new, & - del_activate3d, & - mfbnd_use, ar_bnd_tavg, & - ardz_cen_old, ardz_cen_new, rhodz_cen, & - chem_bar_iccfactor, activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_tdx_area_change does -! horizontal exchange associated with sub-class area changes -! -! incoming chem_sub_new holds current sub-class mixing ratios -! outgoing chem_sub_new holds updated sub-class mixing ratios -! -!----------------------------------------------------------------------- - - use module_data_radm2, only: epsilc - - use module_data_mosaic_asect, only: ai_phase, cw_phase, & - maxd_asize, maxd_atype - - use module_data_ecpp1 - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message - -! arguments - integer, intent(in) :: & - ktau, ktau_pp, & - it, jt, kts, ktebnd, ktecen -! ktau - time step number -! ktau_pp - time step number for "parameterized pollutants" calculations -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - type(modal_aerosol_properties), intent(in) :: aero_props - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) - - real(r8), intent(in) :: dtstep, dtstep_pp -! dtstep - main model time step (s) -! dtstep_pp - time step (s) for "parameterized pollutants" calculations - - real(r8), intent(in), dimension( kts:ktecen ) :: & - tcen_bar, pcen_bar, rhocen_bar, dzcen - real(r8), intent(in), dimension( kts:ktebnd ) :: & - rhobnd_bar, wbnd_bar -! tcen_bar - temperature (K) at layer centers -! rhocen_bar, rhobnd_bar - dry air density (kg/m^3) at layer centers and boundaries -! pcen_bar - air pressure (Pa) at layer centers -! wbnd_bar - vertical velocity (m/s) at layer boundaries -! dzcen - layer thicknesses (m) - - real(r8), intent(in), dimension( kts:ktecen, 1:num_chem_ecpp ) :: & - chem_bar -! chem_bar - mixing ratios of trace gase (ppm) and aerosol species -! (ug/kg for mass species, #/kg for number species) - - integer, intent(in) :: ncls_ecpp -! ncls_ecpp - number of ecpp transport classes in the grid column - - integer, intent(inout) :: ipass_area_change - integer, intent(in) :: ncls_use - - integer, intent(in), dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use - - real(r8), intent(inout), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_new - - real(r8), intent(inout), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - del_activate3d - - real(r8), intent(inout), dimension( kts:ktebnd, 0:2, 0:maxcls_ecpp ) :: & - mfbnd_use, ar_bnd_tavg - - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - ardz_cen_old, ardz_cen_new - - real(r8), intent(inout), dimension( kts:ktecen ) :: rhodz_cen - - real(r8), intent(in), dimension( 1:2, num_chem_ecpp ) :: chem_bar_iccfactor - - integer, intent(in) :: activate_onoff_use - - integer, intent(in), dimension( 1:num_chem_ecpp ) :: & - iphase_of_aerosol, isize_of_aerosol, itype_of_aerosol, & - inmw_of_aerosol, laicwpair_of_aerosol - - -! local variables - integer :: icc, iccy, ido_actres_tmp, ifrom_where, itmpa - integer :: idiag118_pt3 - integer :: jcls, jclsy - integer :: k - integer :: l, la, laa, lbb, lc, lun118 - integer :: m, n - integer :: p1st - - integer, dimension( 1:2, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp ) :: & - ido_actres_horz - - logical :: not_aicw - - real(r8) :: ardz_cut - real(r8) :: tmpa, tmpb, tmpc, tmpd - real(r8) :: tmp_fmnact, tmp_qyla, tmp_qylc - real(r8) :: tmpvecd(0:maxcls_ecpp), tmpvece(0:maxcls_ecpp) - real(r8) :: tmp_del_ardzqa, tmp_del_ardzqc - real(r8) :: tmp_del_ardzqa_act, tmp_del_ardzqc_act - - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_old - real(r8), dimension( 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ent_airamt_tot, det_airamt_tot - real(r8), dimension( 1:2, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ent_airamt, det_airamt - real(r8), dimension( 1:maxd_asize, 1:maxd_atype, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - fmact_horz, fnact_horz - - - - p1st = param_first_ecpp - idiag118_pt3 = 10 * mod( max(idiagaa_ecpp(118),0)/100, 10 ) - -! -! calc entrain/detrain amounts -! -! first calc net (entrainment-detrainment) amount = area change - ent_airamt_tot(:,:,:) = 0.0_r8 - det_airamt_tot(:,:,:) = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - do k = kts, ktecen - ardz_cut = afrac_cut*rhodz_cen(k)*0.3_r8 - tmpa = max( ardz_cen_new(k,icc,jcls), ardz_cen_old(k,icc,jcls) ) - if (tmpa >= ardz_cut) then - tmpb = ardz_cen_new(k,icc,jcls) - ardz_cen_old(k,icc,jcls) - if (tmpb > 0.0_r8) then - ent_airamt_tot(icc,jcls,k) = tmpb - else if (tmpb < 0.0_r8) then - det_airamt_tot(icc,jcls,k) = -tmpb - end if - end if - end do - end do - end do - -! next calc detailed ent/det amounts - ifrom_where = ipass_area_change - call parampollu_tdx_entdet_sub1( & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, ifrom_where, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - ardz_cen_old, ardz_cen_new, rhodz_cen, & - ent_airamt_tot, det_airamt_tot, & - ent_airamt, det_airamt ) - - -! -! calc activation/resuspension fractions associated with ent/det -! - if (activate_onoff_use > 0) then - ifrom_where = ipass_area_change - call parampollu_tdx_activate1( aero_props, & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, wbnd_bar, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, ifrom_where, activate_onoff_use, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - chem_sub_new, & - mfbnd_use, & - ar_bnd_tavg, & - ent_airamt, & - ido_actres_horz, fmact_horz, fnact_horz ) - end if - - -! copy chem_sub_new (= incoming current chem_sub values) into chem_sub_old - chem_sub_old(:,:,:,:) = chem_sub_new(:,:,:,:) - -! calculate new chem_sub -main_jcls_loop: & - do jcls = 1, ncls_use -main_icc_loop: & - do icc = 1, 2 -main_k_loop: & - do k = kts, ktecen - -! if entrainment and detrainment) both ~= 0, then no change - if ( (ent_airamt_tot(icc,jcls,k) < 1.0e-30_r8) .and. & - (det_airamt_tot(icc,jcls,k) < 1.0e-30_r8) ) cycle - -! if new area ~= 0, then just set chem_sub_new to chem_bar - ardz_cut = afrac_cut*rhodz_cen(k)*0.3_r8 - if (ardz_cen_new(k,icc,jcls) < ardz_cut) then - do l = p1st, num_chem_ecpp - chem_sub_new(k,icc,jcls,l) = & - chem_bar(k,l)*chem_bar_iccfactor(icc,l) - end do - cycle main_k_loop - end if - -! la loop goes over all species -! for la = non-aerosol species, loop is executed with lc=0 -! for la = interstitial aerosol species, loop is excecuted with -! lc=activated counterpart -! for la = activated aerosol species, loop is skipped -main_la_loop: & - do la = p1st, num_chem_ecpp - - tmp_del_ardzqa_act = 0.0_r8 - tmp_del_ardzqc_act = 0.0_r8 - - lc = 0 - not_aicw = .true. - if (activate_onoff_use > 0) then - if (iphase_of_aerosol(la) == ai_phase) then - lc = laicwpair_of_aerosol(la) - not_aicw = .false. - else if (iphase_of_aerosol(la) == cw_phase) then - cycle main_la_loop - end if - end if - if ((lc < p1st) .or. (lc > num_chem_ecpp)) lc = -999888777 - -! tmpd = (original area) - (detrainment to all others) - tmpd = ardz_cen_old(k,icc,jcls) - det_airamt_tot(icc,jcls,k) - tmpd = max( tmpd, 0.0_r8 ) - -! tmpa holds sum_of( mix_ratio * area ) for interstitial -! tmpc holds sum_of( mix_ratio * area ) for activated - tmpa = chem_sub_old(k,icc,jcls,la)*tmpd - if (lc > 0) & - tmpc = chem_sub_old(k,icc,jcls,lc)*tmpd - -! add entrainment contributions - do jclsy = 1, ncls_use - do iccy = 1, 2 - tmpd = ent_airamt(icc,jcls,iccy,jclsy,k) - if (tmpd <= 0.0_r8) cycle - - if ( not_aicw ) then - ido_actres_tmp = 0 - else - ido_actres_tmp = ido_actres_horz(icc,jcls,iccy,jclsy) - end if - - tmp_qyla = chem_sub_old(k,iccy,jclsy,la) - if (lc > 0) then - tmp_qylc = chem_sub_old(k,iccy,jclsy,lc) - else - tmp_qylc = 0.0_r8 - end if - - if (ido_actres_tmp == 0) then - ! non aicw-aerosol species OR no activation or resuspension -! tmpa = tmpa + tmp_qyla*tmpd -! tmpc = tmpc + tmp_qylc*tmpd - tmp_del_ardzqa = tmp_qyla*tmpd - tmp_del_ardzqc = tmp_qylc*tmpd - - else if (ido_actres_tmp > 0) then - ! activation of (la+lc) - m = isize_of_aerosol(la) - n = itype_of_aerosol(la) - if (inmw_of_aerosol(la) == 1) then - tmp_fmnact = fnact_horz(m,n,jcls,iccy,jclsy,k) - else - tmp_fmnact = fmact_horz(m,n,jcls,iccy,jclsy,k) - end if - if (ido_actres_tmp == 2) then -! tmpa = tmpa + (tmp_qyla+tmp_qylc)*(1.0_r8-tmp_fmnact)*tmpd -! tmpc = tmpc + (tmp_qyla+tmp_qylc)*(tmp_fmnact )*tmpd - tmp_del_ardzqa = (tmp_qyla+tmp_qylc)*(1.0_r8-tmp_fmnact)*tmpd - tmp_del_ardzqc = (tmp_qyla+tmp_qylc)*(tmp_fmnact )*tmpd - else -! tmpa = tmpa + (tmp_qyla*(1.0_r8-tmp_fmnact) )*tmpd -! tmpc = tmpc + (tmp_qyla*tmp_fmnact + tmp_qylc)*tmpd - tmp_del_ardzqa = (tmp_qyla*(1.0_r8-tmp_fmnact) )*tmpd - tmp_del_ardzqc = (tmp_qyla*tmp_fmnact + tmp_qylc)*tmpd - end if - - else - ! resuspension of lc -! tmpa = tmpa + (tmp_qyla+tmp_qylc)*tmpd - tmp_del_ardzqa = (tmp_qyla+tmp_qylc)*tmpd - tmp_del_ardzqc = 0.0_r8 - - end if - tmpa = tmpa + tmp_del_ardzqa - if (lc > 0) & - tmpc = tmpc + tmp_del_ardzqc - -! change from activation/resuspension - tmp_del_ardzqa_act = tmp_del_ardzqa_act + (tmp_del_ardzqa - tmp_qyla*tmpd) - if (lc > 0) & - tmp_del_ardzqc_act = tmp_del_ardzqc_act + (tmp_del_ardzqc - tmp_qylc*tmpd) - end do ! iccy - end do ! jclsy - chem_sub_new(k,icc,jcls,la) = tmpa/ardz_cen_new(k,icc,jcls) - if (lc > 0) & - chem_sub_new(k,icc,jcls,lc) = tmpc/ardz_cen_new(k,icc,jcls) - -! change in mixing ratio (*fraction) from activation/resuspension - del_activate3d(k,icc,jcls,la) = del_activate3d(k,icc,jcls,la)+tmp_del_ardzqa_act/rhodz_cen(k) - if (lc > 0) & - del_activate3d(k,icc,jcls,lc) = del_activate3d(k,icc,jcls,lc)+tmp_del_ardzqc_act/rhodz_cen(k) - - end do main_la_loop - - end do main_k_loop - end do main_icc_loop - end do main_jcls_loop - - -! diagnostics - lun118 = -1 - if (idiag118_pt3 >= 10) lun118 = ldiagaa_ecpp(118) - if (lun118 > 0) then - l = 9 - icc = 1 - write(lun118,'(/a,2i5,a,3i5)') 'pt3 ppopt, ipass', parampollu_opt, & - ipass_area_change, ' ktau_pp, istep_sub, l =', ktau_pp, -1, l - write(lun118,'(2a)') '(chem_sub_old(k,icc,jcls,l), ', & - 'chem_sub_new(k,icc,jcls,l), jcls=1,3); up,dn,env a_cen_tmpa/tmpb' - do k = ktecen, kts, -1 - write(lun118,'(i3,1p,7(1x,2e10.3))') k, & - (chem_sub_old(k,icc,jcls,l), chem_sub_new(k,icc,jcls,l), jcls=1,3), & - (ardz_cen_old(k,icc,jcls)/rhodz_cen(k), ardz_cen_new(k,icc,jcls)/rhodz_cen(k), jcls=1,3) - end do - end if ! (lun118 > 0) - - - - return - end subroutine parampollu_tdx_area_change - - - -!----------------------------------------------------------------------- - subroutine parampollu_tdx_entdet_sub1( & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - ncls_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, ifrom_where, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - ardz_cen_old, ardz_cen_new, rhodz_cen, & - ent_airamt_tot, det_airamt_tot, & - ent_airamt, det_airamt ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_tdx_entdet_sub1 calculates -! the "horizontal exchange coefficients" associated with -! area changes or vertical mass fluxes -! -! the net (entrainment-detrainment) for each sub-class is -! obtained trivially -! determining where the entrainment comes from, and where -! the detrainment goes to, is much more involved -! -!----------------------------------------------------------------------- - - use module_data_radm2, only: epsilc - - use module_data_ecpp1 - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message - -! arguments - integer, intent(in) :: & - ktau, ktau_pp, & - it, jt, kts, ktebnd, ktecen - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) - - real(r8), intent(in) :: dtstep, dtstep_pp -! dtstep - main model time step (s) -! dtstep_pp - time step (s) for "parameterized pollutants" calculations - - integer, intent(in) :: ncls_ecpp -! ncls_ecpp - number of ecpp transport classes in the grid column - - integer, intent(in) :: ifrom_where - integer, intent(in) :: ncls_use - - integer, intent(in), dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use - - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - ardz_cen_old, ardz_cen_new - - real(r8), intent(inout), dimension( kts:ktecen ) :: rhodz_cen - - real(r8), intent(inout), dimension( 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ent_airamt_tot, det_airamt_tot -! ent_airamt_tot(icc,jcls,k) is the total detrainment into layer k, -! sub-class icc, class jcls from all other sub-classes -! det_airamt_tot(icc,jcls,k) is the total detrainment from layer k, -! sub-class icc, class jcls to all other sub-classes -! units are (kg/m2) -! -! define entdet_net == ent_airamt_tot - det_airamt_tot -! for "area-change" ent/det, entdet_net = rho*dz*d(area) where -! d(area) is the fractional area change over the time-step -! for "vertical-transport" ent/det, entdet_net = d(mfbnd)*dtstep where -! d(mfbnd) is the change in vertical mass flux across a layer -! (mfbnd at layer top minus mfbnd at layer bottom) -! -! up and dndrafts -! in the current formulation, each draft either entrains or detrains -! at a given level, but not both simultaneously -! for incoming ent/det_airamt_tot, one will be >= 0 and the other will be =0 -! the outgoing ent/det_airamt_tot will be unchanged -! quiescent class -! the quiescent class can entrain and detrain simultaneously at a given level -! for incoming ent/det_airamt_tot, one will be >= 0 and will hold the -! net (entrainment-detrainment) -! the outgoing ent/det_airamt_tot can both be >0 -! - - real(r8), intent(out), & - dimension( 1:2, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ent_airamt, det_airamt -! ent_airamt(iccaa,jclsaa,iccbb,jclsbb,k) is (positive) the entrainment amount -! into sub-class (iccaa,jclsaa,k) from sub-class (iccbb,jclsbb,k) -! det_airamt(iccaa,jclsaa,iccbb,jclsbb,k) is (positive) the detrainment amount -! from sub-class (iccaa,jclsaa,k) into sub-class (iccbb,jclsbb,k) -! units for both are (kg/m2) - - -! local variables - integer :: icc, iccy, itmpa - integer :: jcls, jclsy - integer :: jgrp, jgrpy, jgrp_of_jcls(1:maxcls_ecpp) - integer :: k - integer :: l, laa, lbb, lunaa, lunbb - integer :: m - - logical, dimension( 1:2, 1:maxcls_ecpp ) :: & - empty_old, empty_new, empty_oldnew - - real(r8) :: tmpa4, tmpb4 - - real(r8), dimension( 1:2, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ent_airamt_sv1, det_airamt_sv1 - real(r8), dimension( 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ent_airamt_tot_sv0, det_airamt_tot_sv0, & - ent_airamt_tot_sv1, det_airamt_tot_sv1 - real(r8), dimension( 1:2, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp ) :: & - ecls_aa, dcls_aa - real(r8), dimension( 1:2, 1:maxcls_ecpp ) :: & - ecls_aaunasi, dcls_aaunasi - real(r8), dimension( 1:2, 1:maxcls_ecpp ) :: & - dcls_aalimit - real(r8), dimension( 1:2, 1:3, 1:2, 1:3 ) :: & - egrp_aa, dgrp_aa - real(r8), dimension( 1:2, 1:3 ) :: & - egrp_aaunasi, dgrp_aaunasi - - real(r8), dimension( 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ecls_aaunasi_sv2, dcls_aaunasi_sv2 - real(r8), dimension( 1:2, 1:3, kts:ktecen ) :: & - egrp_aaunasi_sv2, dgrp_aaunasi_sv2 - - integer, dimension(3), save :: & - ecls_aaunasi_worst_i=0, dcls_aaunasi_worst_i=0, & - ecls_aaunasi_worst_j=0, dcls_aaunasi_worst_j=0, & - ecls_aaunasi_worst_k=0, dcls_aaunasi_worst_k=0, & - ecls_aaunasi_worst_ktau=0, dcls_aaunasi_worst_ktau=0, & - egrp_aaunasi_worst_i=0, dgrp_aaunasi_worst_i=0, & - egrp_aaunasi_worst_j=0, dgrp_aaunasi_worst_j=0, & - egrp_aaunasi_worst_k=0, dgrp_aaunasi_worst_k=0, & - egrp_aaunasi_worst_ktau=0, dgrp_aaunasi_worst_ktau=0 - real(r8), dimension(3), save :: & - ecls_aaunasi_worst=0.0_r8, dcls_aaunasi_worst=0.0_r8, & - egrp_aaunasi_worst=0.0_r8, dgrp_aaunasi_worst=0.0_r8 - - real(r8) :: ardz_cut - real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf - real(r8) :: tmpmatbb(0:2,0:2) - real(r8) :: tmpmatff(1:2,1:2) - real(r8) :: tmpvecbb(0:maxcls_ecpp), tmpvecgg(0:maxcls_ecpp) - - -! diagnostics to fort.122 at selected timesteps - lunaa = -1 -! if ( (ktau <= 10) .or. & -! (ktau == 581) .or. & -! (ktau == 818) ) lunaa = 122 - if ( (ktau <= 10) .or. & - (ktau == 210) .or. & - (ktau == 682) ) lunaa = ldiagaa_ecpp(122) - if (idiagaa_ecpp(122) <= 0) lunaa = -1 - -! save the incoming values of ent/det_airamt_tot - ent_airamt_tot_sv0(:,:,:) = ent_airamt_tot(:,:,:) - det_airamt_tot_sv0(:,:,:) = det_airamt_tot(:,:,:) - -! -! do a very simple calculation that mimics previous code -! up and dndrafts entrain-from and detrain-too -! the quiescent class with the same icc -! (currently the simple calculation results are only used for diagnostic -! purposes, but turning them off would mess up the diagnostics.) -! - ent_airamt(:,:,:,:,:) = 0.0_r8 - det_airamt(:,:,:,:,:) = 0.0_r8 - -entdet_main_kloop_bb: & - do k = kts, ktecen - - do jcls = 1, ncls_use - do icc = 1, 2 - if (jcls == jcls_qu) cycle ! skip quiescent - - tmpa4 = ent_airamt_tot(icc,jcls,k) - if (tmpa4 > 0.0_r8) then - ent_airamt( icc,jcls, icc,jcls_qu, k) = tmpa4 - det_airamt( icc,jcls_qu, icc,jcls, k) = tmpa4 - end if - - tmpa4 = det_airamt_tot(icc,jcls,k) - if (tmpa4 > 0.0_r8) then - det_airamt( icc,jcls, icc,jcls_qu, k) = tmpa4 - ent_airamt( icc,jcls_qu, icc,jcls, k) = tmpa4 - end if - - end do ! icc - end do ! jcls - - end do entdet_main_kloop_bb - - - do k = kts, ktecen - - do jcls = 1, ncls_use - do icc = 1, 2 - tmpa4 = 0.0_r8 - tmpb4 = 0.0_r8 - if (k < ktebnd) then - do jclsy = 1, ncls_use - do iccy = 1, 2 - tmpa4 = tmpa4 + ent_airamt( icc,jcls, iccy,jclsy, k) - tmpb4 = tmpb4 + det_airamt( icc,jcls, iccy,jclsy, k) - end do - end do - end if - ent_airamt_tot(icc,jcls,k) = tmpa4 - det_airamt_tot(icc,jcls,k) = tmpb4 - end do ! icc - end do ! jcls - - end do ! k - - ent_airamt_sv1(:,:,:,:,:) = ent_airamt(:,:,:,:,:) - det_airamt_sv1(:,:,:,:,:) = det_airamt(:,:,:,:,:) - ent_airamt_tot_sv1(:,:,:) = ent_airamt_tot(:,:,:) - det_airamt_tot_sv1(:,:,:) = det_airamt_tot(:,:,:) -! end of simple calculation - - - -! -! -! do the full calculation of horizontal exchanges -! -! - -! reload the incoming values of ent/det_airamt_tot - ent_airamt_tot(:,:,:) = ent_airamt_tot_sv0(:,:,:) - det_airamt_tot(:,:,:) = det_airamt_tot_sv0(:,:,:) - -! calc the jgrp_of_jcls array - icc = 1 - do jcls = 1, ncls_use - if (mtype_updnenv_use(icc,jcls) == mtype_quiescn_ecpp) then - jgrp_of_jcls(jcls) = 1 - else if (mtype_updnenv_use(icc,jcls) == mtype_updraft_ecpp) then - jgrp_of_jcls(jcls) = 2 - else - jgrp_of_jcls(jcls) = 3 - end if - end do - if (lunaa > 0) write(lunaa,'(a,10(2x,2i3))') & - 'jcls and jgrp_of_cls', (jcls, jgrp_of_jcls(jcls), jcls=1,ncls_use) - - ent_airamt(:,:,:,:,:) = 0.0_r8 - det_airamt(:,:,:,:,:) = 0.0_r8 - - ecls_aaunasi_sv2(:,:,:) = 0.0_r8 - egrp_aaunasi_sv2(:,:,:) = 0.0_r8 - dcls_aaunasi_sv2(:,:,:) = 0.0_r8 - dgrp_aaunasi_sv2(:,:,:) = 0.0_r8 - - -entdet_main_kloop_aa: & - do k = kts, ktecen - - ardz_cut = afrac_cut*rhodz_cen(k)*0.3_r8 - - empty_old(:,:) = .false. - empty_new(:,:) = .false. - empty_oldnew(:,:) = .false. - if (lunaa > 0) write(lunaa,'(/a)') 'k, jcls, emptyold/new/oldnew for icc=1 then icc=2' - do jcls = 1, ncls_use - do icc = 1, 2 - if (ardz_cen_old(k,icc,jcls) < ardz_cut) empty_old(icc,jcls) = .true. - if (ardz_cen_new(k,icc,jcls) < ardz_cut) empty_new(icc,jcls) = .true. - empty_oldnew(icc,jcls) = empty_old(icc,jcls) .and. empty_new(icc,jcls) - end do - if (lunaa > 0) write(lunaa,'(2i3,2(3x,3l3))') k, jcls, & - (empty_old(icc,jcls), empty_new(icc,jcls), empty_oldnew(icc,jcls), icc=1,2) - end do - - if (lunaa > 0) then - write(lunaa,'(/a,1p,10e16.8)') 'ardz_cut,rdz', ardz_cut, rhodz_cen(k) - write(lunaa,'( a,1p,10e16.8)') 'ardz_cen_old', ardz_cen_old(k,0,0), ardz_cen_old(k,1:2,1:3) - write(lunaa,'( a,1p,10e16.8)') 'ardz_cen_new', ardz_cen_new(k,0,0), ardz_cen_new(k,1:2,1:3) - write(lunaa,'( a,1p,10e16.8)') 'new-old ', (ardz_cen_new(k,0,0)-ardz_cen_new(k,0,0)), & - (ardz_cen_new(k,1:2,1:3)-ardz_cen_old(k,1:2,1:3)) - tmpa = 1.0_r8/rhodz_cen(k) - tmpb = sum( ardz_cen_old(k,1:2,1:3) ) - tmpc = sum( ardz_cen_new(k,1:2,1:3) ) - write(lunaa,'( a,1p,10e16.8)') 'area_cen_old', tmpa*tmpb, tmpa*ardz_cen_old(k,1:2,1:3) - write(lunaa,'( a,1p,10e16.8)') 'area_cen_new', tmpa*tmpc, tmpa*ardz_cen_new(k,1:2,1:3) - write(lunaa,'( a,1p,10e16.8)') 'new-old ', tmpa*(tmpc-tmpb), & - tmpa*(ardz_cen_new(k,1:2,1:3)-ardz_cen_old(k,1:2,1:3)) - write(lunaa,'( a/1p,4(1x,3e11.3))') 'ardz_cen_old(0:2,0:3)', ardz_cen_old(k,0:2,0:3) - write(lunaa,'( a/1p,4(1x,3e11.3))') 'ardz_cen_new(0:2,0:3)', ardz_cen_new(k,0:2,0:3) - end if - - -! step 1 -! initialize class and group "assigned" ent/det arrays to zero -! initialize class "unassigned" ent/det arrays to ent/det_airamt_tot -! calc group "unassigned" arrays by summing over classes -! -! *************************************************************** -! should check here that total ent = total det (with very small error allowed) -! then adjust them to be even closer -! *************************************************************** - ecls_aa(:,:,:,:) = 0.0_r8 - dcls_aa(:,:,:,:) = 0.0_r8 - egrp_aa(:,:,:,:) = 0.0_r8 - dgrp_aa(:,:,:,:) = 0.0_r8 - egrp_aaunasi( :,:) = 0.0_r8 - dgrp_aaunasi( :,:) = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - ecls_aaunasi(icc,jcls) = ent_airamt_tot(icc,jcls,k) - dcls_aaunasi(icc,jcls) = det_airamt_tot(icc,jcls,k) - jgrp = jgrp_of_jcls(jcls) - egrp_aaunasi(icc,jgrp) = egrp_aaunasi(icc,jgrp) + ecls_aaunasi(icc,jcls) - dgrp_aaunasi(icc,jgrp) = dgrp_aaunasi(icc,jgrp) + dcls_aaunasi(icc,jcls) - if (ifrom_where < 10) then - ! for area-change, detrainment is limited to initial subarea mass - dcls_aalimit(icc,jcls) = ardz_cen_old(k,icc,jcls) - else - dcls_aalimit(icc,jcls) = 1.0e30_r8 - end if - end do - end do - call parampollu_tdx_entdet_diag01( & - 1, lunaa, & - ifrom_where, ktau, k, kts, ktebnd, ktecen, ncls_use, & - ent_airamt_tot_sv1, ecls_aa, ecls_aaunasi, egrp_aa, egrp_aaunasi, & - det_airamt_tot_sv1, dcls_aa, dcls_aaunasi, dgrp_aa, dgrp_aaunasi, & - dcls_aalimit ) - - -! step 2 -! for up and dndrafts, if cloudy is entraining and clear is detraining -! (or vice-versa), then assign as much as possible of the ent/det -! as "clear up/dndraft" <--> "cloudy up/dndraft" - do jcls = 1, ncls_use - if (jcls == jcls_qu) cycle - jgrp = jgrp_of_jcls(jcls) - jclsy = jcls - jgrpy = jgrp_of_jcls(jclsy) - do icc = 1, 2 - iccy = 3 - icc - if ( empty_old(icc ,jcls ) ) cycle - if ( empty_new(iccy,jclsy) ) cycle - tmpa = min( dcls_aaunasi(icc,jcls), ecls_aaunasi(iccy,jcls) ) - if (tmpa > 0.0_r8) then - dcls_aaunasi(icc ,jcls ) = dcls_aaunasi(icc ,jcls ) - tmpa - ecls_aaunasi(iccy,jclsy) = ecls_aaunasi(iccy,jclsy) - tmpa - dcls_aalimit(icc ,jcls ) = dcls_aalimit(icc ,jcls ) - tmpa - dcls_aa(icc ,jcls ,iccy,jclsy) = dcls_aa(icc ,jcls ,iccy,jclsy) + tmpa - ecls_aa(iccy,jclsy,icc ,jcls ) = ecls_aa(iccy,jclsy,icc ,jcls ) + tmpa - - dgrp_aaunasi(icc ,jgrp ) = dgrp_aaunasi(icc ,jgrp ) - tmpa - egrp_aaunasi(iccy,jgrpy) = egrp_aaunasi(iccy,jgrpy) - tmpa - dgrp_aa(icc ,jgrp ,iccy,jgrpy) = dgrp_aa(icc ,jgrp ,iccy,jgrpy) + tmpa - egrp_aa(iccy,jgrpy,icc ,jgrp ) = egrp_aa(iccy,jgrpy,icc ,jgrp ) + tmpa - end if - end do ! icc - end do ! jcls - call parampollu_tdx_entdet_diag01( & - 2, lunaa, & - ifrom_where, ktau, k, kts, ktebnd, ktecen, ncls_use, & - ent_airamt_tot_sv1, ecls_aa, ecls_aaunasi, egrp_aa, egrp_aaunasi, & - det_airamt_tot_sv1, dcls_aa, dcls_aaunasi, dgrp_aa, dgrp_aaunasi, & - dcls_aalimit ) - - -! step 3 -! for up and dndraft detrainment, assign as much as possible of the det -! as "clear up/dndraft" <--> "clear quiescent" -! and "cloudy up/dndraft" <--> "cloudy quiescent" - do icc = 1, 2 - iccy = icc - jclsy = jcls_qu - jgrpy = jgrp_of_jcls(jclsy) - - ! tmpb = unassigned detrain from all up/dndraft - tmpb = dgrp_aaunasi(icc,2) + dgrp_aaunasi(icc,3) - ! tmpc = portion of tmpb that will be assigned in this step - tmpc = min( tmpb, egrp_aaunasi(icc,1) ) - if (tmpc <= 0.0_r8) cycle - - do jcls = 1, ncls_use - if (jcls == jcls_qu) cycle - if ( empty_old(icc ,jcls ) ) cycle - if ( empty_new(iccy,jclsy) ) cycle - jgrp = jgrp_of_jcls(jcls ) - - ! tmpf is fraction of total-unassigned-draft detrainment due to this jcls - tmpf = min( dcls_aaunasi(icc,jcls), tmpb ) / max( 1.0e-30_r8, tmpb ) - ! tmpa is portion of tmpc applied to this jcls - tmpa = tmpf*tmpc - tmpa = min( tmpa, dcls_aaunasi(icc ,jcls ), ecls_aaunasi(iccy,jclsy) ) - if (tmpa > 0.0_r8) then - dcls_aaunasi(icc ,jcls ) = dcls_aaunasi(icc ,jcls ) - tmpa - ecls_aaunasi(iccy,jclsy) = ecls_aaunasi(iccy,jclsy) - tmpa - dcls_aalimit(icc ,jcls ) = dcls_aalimit(icc ,jcls ) - tmpa - dcls_aa(icc ,jcls ,iccy,jclsy) = dcls_aa(icc ,jcls ,iccy,jclsy) + tmpa - ecls_aa(iccy,jclsy,icc ,jcls ) = ecls_aa(iccy,jclsy,icc ,jcls ) + tmpa - - dgrp_aaunasi(icc ,jgrp ) = dgrp_aaunasi(icc ,jgrp ) - tmpa - egrp_aaunasi(iccy,jgrpy) = egrp_aaunasi(iccy,jgrpy) - tmpa - dgrp_aa(icc ,jgrp ,iccy,jgrpy) = dgrp_aa(icc ,jgrp ,iccy,jgrpy) + tmpa - egrp_aa(iccy,jgrpy,icc ,jgrp ) = egrp_aa(iccy,jgrpy,icc ,jgrp ) + tmpa - end if - end do ! icc - end do ! jcls - call parampollu_tdx_entdet_diag01( & - 3, lunaa, & - ifrom_where, ktau, k, kts, ktebnd, ktecen, ncls_use, & - ent_airamt_tot_sv1, ecls_aa, ecls_aaunasi, egrp_aa, egrp_aaunasi, & - det_airamt_tot_sv1, dcls_aa, dcls_aaunasi, dgrp_aa, dgrp_aaunasi, & - dcls_aalimit ) - - -! step 4 -! for up and dndraft detrainment, assign any remaining detrainment to -! quiescent based on the clear/cloudy quiescent areas - - ! tmpvecgg(1) = fraction of quiescent class that is clear (using new areas) - tmpvecgg(1) = ardz_cen_new(k,1,jcls_qu)/ardz_cen_new(k,0,jcls_qu) - tmpvecgg(1) = max( 0.0_r8, min( 1.0_r8, tmpvecgg(1) ) ) - ! tmpvecgg(2) = fraction of quiescent class that is cloudy (using new areas) - tmpvecgg(2) = 1.0_r8 - tmpvecgg(1) - tmpvecgg(2) = max( 0.0_r8, min( 1.0_r8, tmpvecgg(2) ) ) - - ! tmpmatbb(0,0) = unassigned detrain from all up/dndraft - ! tmpmatbb(1,0) = portion of tmpmatbb(0,0) from clear draft to all quiescent - tmpmatbb(1,0) = sum( dgrp_aaunasi(1,2:3) ) - ! tmpmatbb(2,0) = portion of tmpmatbb(0,0) from cloudy draft to all quiescent - tmpmatbb(2,0) = sum( dgrp_aaunasi(2,2:3) ) - tmpmatbb(0,0) = tmpmatbb(1,0) + tmpmatbb(2,0) - - if (tmpmatbb(0,0) > 1.0e-30_r8) then - - ! tmpmatbb(0,1) = portion of tmpmatbb(0,0) from all draft to clear quiescent - ! tmpmatbb(0,2) = portion of tmpmatbb(0,0) from all draft to cloudy quiescent - tmpmatbb(0,1:2) = tmpmatbb(0,0)*tmpvecgg(1:2) - - ! this step can drive the ecls_aaunasi of a quiescent negative, - ! and the negative entrainment gets converted to positive detrainment - ! (from one quiescent subarea to the other) - ! when doing area-change, check that this will not make - ! dcls_aaunasi exceed dcls_aalimit - if (ifrom_where < 10) then - tmpvecbb(1:2) = tmpmatbb(0,1:2) - jclsy = jcls_qu - do iccy = 2, 1, -1 - if (tmpvecbb(iccy) > ecls_aaunasi(iccy,jclsy)) then - tmpd = dcls_aaunasi(iccy,jclsy) & - + (tmpvecbb(iccy) - ecls_aaunasi(iccy,jclsy)) - if (tmpd > dcls_aalimit(iccy,jclsy)) then - tmpvecbb(iccy) = tmpvecbb(iccy) & - - (tmpd - dcls_aalimit(iccy,jclsy)) - tmpvecbb(iccy) = max( 0.0_r8, tmpvecbb(iccy) ) - tmpvecbb(3-iccy) = tmpmatbb(0,0) - tmpvecbb(iccy) - end if - end if - end do - tmpmatbb(0,1:2) = tmpvecbb(1:2) - end if - - ! tmpmatbb(1,1) = portion of tmpmatbb(0,0) from clear draft to clear quiescent - tmpmatbb(1,1) = min( tmpmatbb(0,1), tmpmatbb(1,0) ) - ! tmpmatbb(1,2) = portion of tmpmatbb(0,0) from clear draft to cloudy quiescent - tmpmatbb(1,2) = max( 0.0_r8, (tmpmatbb(1,0) - tmpmatbb(1,1)) ) - - ! tmpmatbb(2,2) = portion of tmpmatbb(0,0) from cloudy draft to cloudy quiescent - tmpmatbb(2,2) = min( tmpmatbb(0,2), tmpmatbb(2,0) ) - ! tmpmatbb(2,1) = portion of tmpmatbb(0,0) from cloudy draft to clear quiescent - tmpmatbb(2,1) = max( 0.0_r8, (tmpmatbb(2,0) - tmpmatbb(2,2)) ) - - tmpmatff(1,2) = tmpmatbb(1,2) / max( 1.0e-37_r8, tmpmatbb(1,0) ) - tmpmatff(1,2) = max( 0.0_r8, min( 1.0_r8, tmpmatff(1,2) ) ) - tmpmatff(1,1) = 1.0_r8 - tmpmatff(1,2) - tmpmatff(1,1) = max( 0.0_r8, min( 1.0_r8, tmpmatff(1,1) ) ) - - tmpmatff(2,2) = tmpmatbb(2,2) / max( 1.0e-37_r8, tmpmatbb(2,0) ) - tmpmatff(2,2) = max( 0.0_r8, min( 1.0_r8, tmpmatff(2,2) ) ) - tmpmatff(2,1) = 1.0_r8 - tmpmatff(2,2) - tmpmatff(2,1) = max( 0.0_r8, min( 1.0_r8, tmpmatff(2,1) ) ) - -! *** now need to apply these *** - do jcls = 1, ncls_use - if (jcls == jcls_qu) cycle ! do jcls - jgrp = jgrp_of_jcls(jcls) - jclsy = jcls_qu - jgrpy = jgrp_of_jcls(jclsy) - do icc = 1, 2 - tmpc = dcls_aaunasi(icc,jcls) - if (tmpc <= 0.0_r8) cycle ! do icc - - do iccy = 1, 2 - if ( empty_old(icc,jcls) ) cycle ! do iccy - if ( empty_new(iccy,jclsy) ) cycle ! do iccy - - tmpa = tmpmatff(icc,iccy) * tmpc - if (tmpa <= 0.0_r8) cycle ! do iccy - - dcls_aaunasi(icc ,jcls ) = dcls_aaunasi(icc ,jcls ) - tmpa - ecls_aaunasi(iccy,jclsy) = ecls_aaunasi(iccy,jclsy) - tmpa - dcls_aalimit(icc ,jcls ) = dcls_aalimit(icc ,jcls ) - tmpa - dcls_aa(icc ,jcls ,iccy,jclsy) = dcls_aa(icc ,jcls ,iccy,jclsy) + tmpa - ecls_aa(iccy,jclsy,icc ,jcls ) = ecls_aa(iccy,jclsy,icc ,jcls ) + tmpa - - dgrp_aaunasi(icc ,jgrp ) = dgrp_aaunasi(icc ,jgrp ) - tmpa - egrp_aaunasi(iccy,jgrpy) = egrp_aaunasi(iccy,jgrpy) - tmpa - dgrp_aa(icc ,jgrp ,iccy,jgrpy) = dgrp_aa(icc ,jgrp ,iccy,jgrpy) + tmpa - egrp_aa(iccy,jgrpy,icc ,jgrp ) = egrp_aa(iccy,jgrpy,icc ,jgrp ) + tmpa - - ! if unassigned entrainment from quiescent goes negative, - ! convert this to positive unassigned detrainment - if (ecls_aaunasi(iccy,jclsy) < 0.0_r8) then - dcls_aaunasi(iccy,jclsy) = dcls_aaunasi(iccy,jclsy) - ecls_aaunasi(iccy,jclsy) - ecls_aaunasi(iccy,jclsy) = 0.0_r8 - end if - if (egrp_aaunasi(iccy,jgrpy) < 0.0_r8) then - dgrp_aaunasi(iccy,jgrpy) = dgrp_aaunasi(iccy,jgrpy) - egrp_aaunasi(iccy,jgrpy) - egrp_aaunasi(iccy,jgrpy) = 0.0_r8 - end if - end do ! iccy - end do ! icc - end do ! jcls - - end if ! (tmpmatbb(0,0) > 1.0e-30_r8) - call parampollu_tdx_entdet_diag01( & - 4, lunaa, & - ifrom_where, ktau, k, kts, ktebnd, ktecen, ncls_use, & - ent_airamt_tot_sv1, ecls_aa, ecls_aaunasi, egrp_aa, egrp_aaunasi, & - det_airamt_tot_sv1, dcls_aa, dcls_aaunasi, dgrp_aa, dgrp_aaunasi, & - dcls_aalimit ) - - -! step 5 -! up and dndraft entrainment -! do this in a much simpler manner -! all up and dndraft entrainment comes from quiescent -! contributions from clear and cloudy quiescent are proportional to -! their fractional areas (tmpvecgg(1) & tmpvecgg(2)) - ! tmpvecgg(1) = fraction of quiescent class that is clear (using old areas) - tmpvecgg(1) = ardz_cen_old(k,1,jcls_qu)/ardz_cen_old(k,0,jcls_qu) - tmpvecgg(1) = max( 0.0_r8, min( 1.0_r8, tmpvecgg(1) ) ) - ! tmpvecgg(2) = fraction of quiescent class that is cloudy (using old areas) - tmpvecgg(2) = 1.0_r8 - tmpvecgg(1) - tmpvecgg(2) = max( 0.0_r8, min( 1.0_r8, tmpvecgg(2) ) ) - - jclsy = jcls_qu - jgrpy = jgrp_of_jcls(jclsy) - - ! when doing area-change, check that this will not make - ! dcls_aalimit negative for either quiescent subarea - if (ifrom_where < 10) then - ! total unassigned entrainment to up/dndrafts - tmpa = sum( egrp_aaunasi(1:2,2:3) ) - ! amount of detrainment that will come from quiescent iccy=1,2 - tmpvecbb(1:2) = tmpa*tmpvecgg(1:2) - jclsy = jcls_qu - do iccy = 2, 1, -1 - if (tmpvecbb(iccy) > dcls_aalimit(iccy,jclsy)) then - tmpvecbb(iccy) = dcls_aalimit(iccy,jclsy) - tmpvecbb(3-iccy) = tmpa - tmpvecbb(iccy) - end if - end do - tmpvecgg(2) = tmpvecbb(2)/max( 1.0e-37_r8, tmpa ) - tmpvecgg(2) = max( 0.0_r8, min( 1.0_r8, tmpvecgg(2) ) ) - tmpvecgg(1) = 1.0_r8 - tmpvecgg(2) - tmpvecgg(1) = max( 0.0_r8, min( 1.0_r8, tmpvecgg(1) ) ) - end if - - do jcls = 1, ncls_use - do icc = 1, 2 - iccy = 0 - if (jcls == jcls_qu) cycle - if ( empty_new(icc ,jcls ) ) cycle - jgrp = jgrp_of_jcls(jcls ) - - ! tmpa is unassigned-draft entrainment due to this icc,jcls - tmpa = ecls_aaunasi(icc,jcls) - if (tmpa > 0.0_r8) then - do iccy = 1, 2 - if ( empty_old(iccy,jclsy) ) cycle - if (tmpvecgg(iccy) <= 0.0_r8) cycle - ! tmpb is portion of tmpa coming from iccy,jclsy - tmpb = tmpa*tmpvecgg(iccy) - - ecls_aaunasi(icc ,jcls ) = ecls_aaunasi(icc ,jcls ) - tmpb - dcls_aaunasi(iccy,jclsy) = dcls_aaunasi(iccy,jclsy) - tmpb - dcls_aalimit(iccy,jclsy) = dcls_aalimit(iccy,jclsy) - tmpb - ecls_aa(icc ,jcls ,iccy,jclsy) = ecls_aa(icc ,jcls ,iccy,jclsy) + tmpb - dcls_aa(iccy,jclsy,icc ,jcls ) = dcls_aa(iccy,jclsy,icc ,jcls ) + tmpb - - egrp_aaunasi(icc ,jgrp ) = egrp_aaunasi(icc ,jgrp ) - tmpb - dgrp_aaunasi(iccy,jgrpy) = dgrp_aaunasi(iccy,jgrpy) - tmpb - egrp_aa(icc ,jgrp ,iccy,jgrpy) = egrp_aa(icc ,jgrp ,iccy,jgrpy) + tmpb - dgrp_aa(iccy,jgrpy,icc ,jgrp ) = dgrp_aa(iccy,jgrpy,icc ,jgrp ) + tmpb - - ! if unassigned detrainment from quiescent goes negative, - ! convert this to positive unassigned entrainment - if (dcls_aaunasi(iccy,jclsy) < 0.0_r8) then - ecls_aaunasi(iccy,jclsy) = ecls_aaunasi(iccy,jclsy) - dcls_aaunasi(iccy,jclsy) - dcls_aaunasi(iccy,jclsy) = 0.0_r8 - end if - if (dgrp_aaunasi(iccy,jgrpy) < 0.0_r8) then - egrp_aaunasi(iccy,jgrpy) = egrp_aaunasi(iccy,jgrpy) - dgrp_aaunasi(iccy,jgrpy) - dgrp_aaunasi(iccy,jgrpy) = 0.0_r8 - end if - end do ! iccy - end if ! (tmpa > 0.0) - end do ! icc - end do ! jcls - call parampollu_tdx_entdet_diag01( & - 5, lunaa, & - ifrom_where, ktau, k, kts, ktebnd, ktecen, ncls_use, & - ent_airamt_tot_sv1, ecls_aa, ecls_aaunasi, egrp_aa, egrp_aaunasi, & - det_airamt_tot_sv1, dcls_aa, dcls_aaunasi, dgrp_aa, dgrp_aaunasi, & - dcls_aalimit ) - - -! step 6 -! quiescent clear <--> quiescent cloudy exchanges -! if clear is detraining and cloudy is entraining, then assign as much as -! possible of the det/ent as "clear quiescent" --> "cloudy quiescent" -! if cloudy is detraining and clear is entraining, then assign as much as -! possible of the det/ent as "cloudy quiescent" --> "clear quiescent" - do jcls = 1, ncls_use - if (jcls /= jcls_qu) cycle - jgrp = jgrp_of_jcls(jcls) - jclsy = jcls - jgrpy = jgrp_of_jcls(jclsy) - do icc = 1, 2 - iccy = 3 - icc - if ( empty_old(icc ,jcls ) ) cycle - if ( empty_new(iccy,jclsy) ) cycle - tmpa = min( dcls_aaunasi(icc,jcls), ecls_aaunasi(iccy,jcls) ) - if (tmpa > 0.0_r8) then - dcls_aaunasi(icc ,jcls ) = dcls_aaunasi(icc ,jcls ) - tmpa - ecls_aaunasi(iccy,jclsy) = ecls_aaunasi(iccy,jclsy) - tmpa - dcls_aa(icc ,jcls ,iccy,jclsy) = dcls_aa(icc ,jcls ,iccy,jclsy) + tmpa - ecls_aa(iccy,jclsy,icc ,jcls ) = ecls_aa(iccy,jclsy,icc ,jcls ) + tmpa - - dgrp_aaunasi(icc ,jgrp ) = dgrp_aaunasi(icc ,jgrp ) - tmpa - egrp_aaunasi(iccy,jgrpy) = egrp_aaunasi(iccy,jgrpy) - tmpa - dgrp_aa(icc ,jgrp ,iccy,jgrpy) = dgrp_aa(icc ,jgrp ,iccy,jgrpy) + tmpa - egrp_aa(iccy,jgrpy,icc ,jgrp ) = egrp_aa(iccy,jgrpy,icc ,jgrp ) + tmpa - end if - end do ! icc - end do ! jcls - call parampollu_tdx_entdet_diag01( & - 6, lunaa, & - ifrom_where, ktau, k, kts, ktebnd, ktecen, ncls_use, & - ent_airamt_tot_sv1, ecls_aa, ecls_aaunasi, egrp_aa, egrp_aaunasi, & - det_airamt_tot_sv1, dcls_aa, dcls_aaunasi, dgrp_aa, dgrp_aaunasi, & - dcls_aalimit ) - - - -! load the current-k ent/det values for each class into ent/det_airamt - ent_airamt(:,:,:,:,k) = ecls_aa(:,:,:,:) - det_airamt(:,:,:,:,k) = dcls_aa(:,:,:,:) - - ecls_aaunasi_sv2(:,:,k) = ecls_aaunasi(:,:) - egrp_aaunasi_sv2(:,:,k) = egrp_aaunasi(:,:) - dcls_aaunasi_sv2(:,:,k) = dcls_aaunasi(:,:) - dgrp_aaunasi_sv2(:,:,k) = dgrp_aaunasi(:,:) - - -! calc largest unassigned ent/det - m = 1 - if (ifrom_where == 10) m = 2 - if (ifrom_where == 2) m = 3 - do jcls = 1, ncls_use - do icc = 1, 2 - if (abs(ecls_aaunasi(icc,jcls)) > abs(ecls_aaunasi_worst(m))) then - ecls_aaunasi_worst(m) = ecls_aaunasi(icc,jcls) - ecls_aaunasi_worst_i(m) = icc - ecls_aaunasi_worst_j(m) = jcls - ecls_aaunasi_worst_k(m) = k - ecls_aaunasi_worst_ktau(m) = ktau - end if - if (abs(dcls_aaunasi(icc,jcls)) > abs(dcls_aaunasi_worst(m))) then - dcls_aaunasi_worst(m) = dcls_aaunasi(icc,jcls) - dcls_aaunasi_worst_i(m) = icc - dcls_aaunasi_worst_j(m) = jcls - dcls_aaunasi_worst_k(m) = k - dcls_aaunasi_worst_ktau(m) = ktau - end if - jgrp = jcls - if (jgrp > 3) cycle - if (abs(egrp_aaunasi(icc,jgrp)) > abs(egrp_aaunasi_worst(m))) then - egrp_aaunasi_worst(m) = egrp_aaunasi(icc,jgrp) - egrp_aaunasi_worst_i(m) = icc - egrp_aaunasi_worst_j(m) = jgrp - egrp_aaunasi_worst_k(m) = k - egrp_aaunasi_worst_ktau(m) = ktau - end if - if (abs(dgrp_aaunasi(icc,jgrp)) > abs(dgrp_aaunasi_worst(m))) then - dgrp_aaunasi_worst(m) = dgrp_aaunasi(icc,jgrp) - dgrp_aaunasi_worst_i(m) = icc - dgrp_aaunasi_worst_j(m) = jgrp - dgrp_aaunasi_worst_k(m) = k - dgrp_aaunasi_worst_ktau(m) = ktau - end if - end do - end do - - - - end do entdet_main_kloop_aa - - -! now calc ent/det_airamt_tot - do k = kts, ktecen - - do jcls = 1, ncls_use - do icc = 1, 2 - tmpa = 0.0_r8 - tmpb = 0.0_r8 - if (k < ktebnd) then - do jclsy = 1, ncls_use - do iccy = 1, 2 - tmpa = tmpa + ent_airamt( icc,jcls, iccy,jclsy, k) - tmpb = tmpb + det_airamt( icc,jcls, iccy,jclsy, k) - end do - end do - end if - ent_airamt_tot(icc,jcls,k) = tmpa - det_airamt_tot(icc,jcls,k) = tmpb - end do ! icc - end do ! jcls - - end do ! k - - -! diagnostic output - if (lunaa > 0) then - do k = kts, ktecen - - write(lunaa,'(/a,3i5)') 'bb parampollu_tdx_entdet_sub1 - ktau, ifrom_where, k', ktau, ifrom_where, k - - write(lunaa,'(a)') 'ent_airamt_tot simple/full' - write(lunaa,'(1p,10e11.3)') ent_airamt_tot_sv1(1:2,1:ncls_use,k) - write(lunaa,'(1p,10e11.3)') ent_airamt_tot( 1:2,1:ncls_use,k) - do jcls = 1, ncls_use - write(lunaa,'(a,i3,a,i3)') 'ent_airamt simple/full for icc,jcls= 1', jcls, ' and 2', jcls - write(lunaa,'(1p,6e11.3,4x,6e11.3)') (ent_airamt_sv1(icc,jcls,1:2,1:ncls_use,k), icc=1,2) - write(lunaa,'(1p,6e11.3,4x,6e11.3)') (ent_airamt( icc,jcls,1:2,1:ncls_use,k), icc=1,2) - end do - - write(lunaa,'(a)') 'det_airamt_tot simple/full' - write(lunaa,'(1p,10e11.3)') det_airamt_tot_sv1(1:2,1:ncls_use,k) - write(lunaa,'(1p,10e11.3)') det_airamt_tot( 1:2,1:ncls_use,k) - do jcls = 1, ncls_use - write(lunaa,'(a,i3,a,i3)') 'det_airamt simple/full for icc,jcls= 1', jcls, ' and 2', jcls - write(lunaa,'(1p,6e11.3,4x,6e11.3)') (det_airamt_sv1(icc,jcls,1:2,1:ncls_use,k), icc=1,2) - write(lunaa,'(1p,6e11.3,4x,6e11.3)') (det_airamt( icc,jcls,1:2,1:ncls_use,k), icc=1,2) - end do - - write(lunaa,'(a)') 'final ecls_aaunasi & egrp_aaunasi // final dcls_aaunasi & dgrp_aaunasi' - write(lunaa,'(1p,6e11.3,4x,6e11.3)') ecls_aaunasi_sv2(1:2,1:ncls_use,k), egrp_aaunasi_sv2(1:2,1:3,k) - write(lunaa,'(1p,6e11.3,4x,6e11.3)') dcls_aaunasi_sv2(1:2,1:ncls_use,k), dgrp_aaunasi_sv2(1:2,1:3,k) - - end do ! k = kts, kte - end if ! (lunaa > 0) - - - lunbb = -1 - if ((parampollu_opt == 2223) .and. (ifrom_where == 2)) lunbb = ldiagaa_ecpp(123) - if ((parampollu_opt == 2220) .and. (ifrom_where == 10)) lunbb = ldiagaa_ecpp(123) - lunbb = ldiagaa_ecpp(123) - if (idiagaa_ecpp(123) <= 0) lunbb = -1 - - if (lunbb > 0) then - write(lunbb,'(/a,3i5)') 'parampollu_tdx_entdet_sub1 - ktau, ifrom_where', ktau, ifrom_where - - do m = 1, 3 - write(lunbb,'(a,i3)') 'm =', m - write(lunbb,'(a,2(3x,3i3,i5,1p,e11.3))') & - 'ecls_aaunasi_worst i/j/k/ktau/val & dcls', & - ecls_aaunasi_worst_i(m), ecls_aaunasi_worst_j(m), ecls_aaunasi_worst_k(m), & - ecls_aaunasi_worst_ktau(m), ecls_aaunasi_worst(m), & - dcls_aaunasi_worst_i(m), dcls_aaunasi_worst_j(m), dcls_aaunasi_worst_k(m), & - dcls_aaunasi_worst_ktau(m), dcls_aaunasi_worst(m) - write(lunbb,'(a,2(3x,3i3,i5,1p,e11.3))') & - 'egrp_aaunasi_worst i/j/k/ktau/val & dgrp', & - egrp_aaunasi_worst_i(m), egrp_aaunasi_worst_j(m), egrp_aaunasi_worst_k(m), & - egrp_aaunasi_worst_ktau(m), egrp_aaunasi_worst(m), & - dgrp_aaunasi_worst_i(m), dgrp_aaunasi_worst_j(m), dgrp_aaunasi_worst_k(m), & - dgrp_aaunasi_worst_ktau(m), dgrp_aaunasi_worst(m) - end do - - end if ! (lunbb > 0) - - -! restore saved values -! ent_airamt(:,:,:,:,:) = ent_airamt_sv1(:,:,:,:,:) -! det_airamt(:,:,:,:,:) = det_airamt_sv1(:,:,:,:,:) -! ent_airamt_tot(:,:,:) = ent_airamt_tot_sv1(:,:,:) -! det_airamt_tot(:,:,:) = det_airamt_tot_sv1(:,:,:) - - - return - end subroutine parampollu_tdx_entdet_sub1 - - - -!----------------------------------------------------------------------- - subroutine parampollu_tdx_entdet_diag01( & - istep, lun, & - ifrom_where, ktau, k, kts, ktebnd, ktecen, ncls_use, & - ent_airamt_tot_sv1, ecls_aa, ecls_aaunasi, egrp_aa, egrp_aaunasi, & - det_airamt_tot_sv1, dcls_aa, dcls_aaunasi, dgrp_aa, dgrp_aaunasi, & - dcls_aalimit ) - - use module_data_ecpp1 - - integer :: istep, lun, ifrom_where, ktau, k, kts, ktebnd, ktecen, ncls_use - real(r8), dimension( 1:2, 1:maxcls_ecpp, kts:ktecen ) :: & - ent_airamt_tot_sv1, det_airamt_tot_sv1 - real(r8), dimension( 1:2, 1:maxcls_ecpp, 1:2, 1:maxcls_ecpp ) :: & - ecls_aa, dcls_aa - real(r8), dimension( 1:2, 1:maxcls_ecpp ) :: & - ecls_aaunasi, dcls_aaunasi, dcls_aalimit - real(r8), dimension( 1:2, 1:3, 1:2, 1:3 ) :: & - egrp_aa, dgrp_aa - real(r8), dimension( 1:2, 1:3 ) :: & - egrp_aaunasi, dgrp_aaunasi - - integer :: icc, jcls - - if (lun <= 0) return - - write(lun,'(/a,i1,a,3i5)') 'aa', istep, ' parampollu_tdx_entdet_sub1 - ktau, ifrom_where, k', ktau, ifrom_where, k - - write(lun,'(/i3,a)') istep, '=istep - ent_airamt_tot_sv1' - write(lun,'(1p,10e16.8)') ent_airamt_tot_sv1(1:2,1:ncls_use,k) - write(lun,'(i3,a)') istep, '=istep - ecls_aaunasi after' - write(lun,'(1p,10e16.8)') ecls_aaunasi(1:2,1:ncls_use) - write(lun,'(i3,a)') istep, '=istep - egrp_aaunasi after' - write(lun,'(1p,10e16.8)') egrp_aaunasi(1:2,1:3) - do jcls = 1, ncls_use - write(lun,'(i3,a,i3,a,i3)') istep, '=istep - ecls_aa after for icc,jcls= 1', jcls, ' and 2', jcls - write(lun,'(1p,6e16.8)') (ecls_aa(icc,jcls,1:2,1:ncls_use), icc=1,2) - if (jcls > 3) cycle - write(lun,'(i3,a,i3,a,i3)') istep, '=istep - egrp_aa after for icc,jcls= 1', jcls, ' and 2', jcls - write(lun,'(1p,6e16.8)') (egrp_aa(icc,jcls,1:2,1:3), icc=1,2) - end do - - write(lun,'(/i3,a)') istep, '=istep - det_airamt_tot_sv1' - write(lun,'(1p,10e16.8)') det_airamt_tot_sv1(1:2,1:ncls_use,k) - write(lun,'(i3,a)') istep, '=istep - dcls_aalimit after' - write(lun,'(1p,10e16.8)') dcls_aalimit(1:2,1:ncls_use) - write(lun,'(i3,a)') istep, '=istep - dcls_aaunasi after' - write(lun,'(1p,10e16.8)') dcls_aaunasi(1:2,1:ncls_use) - write(lun,'(i3,a)') istep, '=istep - dgrp_aaunasi after' - write(lun,'(1p,10e16.8)') dgrp_aaunasi(1:2,1:3) - do jcls = 1, ncls_use - write(lun,'(i3,a,i3,a,i3)') istep, '=istep - dcls_aa after for icc,jcls= 1', jcls, ' and 2', jcls - write(lun,'(1p,6e16.8)') (dcls_aa(icc,jcls,1:2,1:ncls_use), icc=1,2) - if (jcls > 3) cycle - write(lun,'(i3,a,i3,a,i3)') istep, '=istep - dgrp_aa after for icc,jcls= 1', jcls, ' and 2', jcls - write(lun,'(1p,6e16.8)') (dgrp_aa(icc,jcls,1:2,1:3), icc=1,2) - end do - - return - end subroutine parampollu_tdx_entdet_diag01 - -!----------------------------------------------------------------------- - subroutine set_of_aerosol_stuff(is_aerosol, & - iphase_of_aerosol, isize_of_aerosol, itype_of_aerosol, & - inmw_of_aerosol, laicwpair_of_aerosol ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! sets following arrays -! -! is_aerosol : logical variable, whether it is an aeroosl speices or not -! -! iphase_of_aerosol(l) = 0 for non-aerosol species -! = ai/cw/..._phase for aerosol species -! isize_of_aerosol(l) = 0 for non-aerosol species -! = size/bin index for aerosol species -! itype_of_aerosol(l) = 0 for non-aerosol species -! = type index for aerosol species -! inmw_of_aerosol(l) = 0 for non-aerosol species -! = 1/2/3 for aerosol number/mass/water species -! laicwpair_of_aerosol(l) = -999888777 for non-aerosol species -! = species index of corresponding ai/cw species -! -!----------------------------------------------------------------------- - -! use module_configure, only: chem_dname_table - - use module_data_ecpp1, only: num_chem_ecpp, param_first_ecpp - - use module_data_mosaic_asect, only: ai_phase, cw_phase, & - massptr_aer, & - ncomp_aer, nphase_aer, nsize_aer, ntype_aer, numptr_aer - -! arguments - integer, intent(out), dimension( 1:num_chem_ecpp ) :: & - iphase_of_aerosol, isize_of_aerosol, itype_of_aerosol, & - inmw_of_aerosol, laicwpair_of_aerosol - logical, intent(out) :: is_aerosol(1:num_chem_ecpp) - -! local variables - integer :: j, j2, l, l2, ll, m, n - integer, save :: ientry = 0 - character(len=16) :: tmpname - - is_aerosol (:) = .false. - iphase_of_aerosol(:) = 0 - isize_of_aerosol(:) = 0 - itype_of_aerosol(:) = 0 - laicwpair_of_aerosol(:) = -999888777 - inmw_of_aerosol(:) = 0 - - do j = 1, nphase_aer - do n = 1, ntype_aer - do m = 1, nsize_aer(n) - do ll = 0, ncomp_aer(n) - - l = -999888777 - if (ll == 0) then - l = numptr_aer(m,n,j) - else if (ll <= ncomp_aer(n)) then - l = massptr_aer(ll,m,n,j) - end if - if ((l >= param_first_ecpp) .and. (l <= num_chem_ecpp)) then - is_aerosol(l) = .true. - iphase_of_aerosol(l) = j - isize_of_aerosol(l) = m - itype_of_aerosol(l) = n - if (ll == 0) then - inmw_of_aerosol(l) = 1 - else if (ll <= ncomp_aer(n)) then - inmw_of_aerosol(l) = 2 - else - inmw_of_aerosol(l) = 3 - end if - end if - - if ( (nphase_aer >= 2) .and. & - (ai_phase > 0) .and. (cw_phase > 0) ) then - if (j == ai_phase) then - j2 = cw_phase - else if (j == cw_phase) then - j2 = ai_phase - else - cycle - end if - end if - if (ll == 0) then - l2 = numptr_aer(m,n,j2) - else if (ll <= ncomp_aer(n)) then - l2 = massptr_aer(ll,m,n,j2) - else - cycle - end if - if ((l >= param_first_ecpp) .and. (l <= num_chem_ecpp) .and. & - (l2 >= param_first_ecpp) .and. (l2 <= num_chem_ecpp)) & - laicwpair_of_aerosol(l) = l2 - - end do - end do - end do - end do - - if (ientry == 0) then - do l = param_first_ecpp, num_chem_ecpp -! tmpname = chem_dname_table(1,l) -! write(*,'(2a,6i5)') 'iphase, isize, itype, inmw, l, laicw_pairptr ', tmpname, & - write(*,'(a,l2,7i5)') 'iphase, isize, itype, inmw, l, laicw_pairptr ', & - is_aerosol(l), iphase_of_aerosol(l), isize_of_aerosol(l), itype_of_aerosol(l), & - inmw_of_aerosol(l), l, max(-999,laicwpair_of_aerosol(l)) - end do - end if - ientry = 1 - - return - end subroutine set_of_aerosol_stuff - -!----------------------------------------------------------------------- - subroutine parampollu_tdx_startup( & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - rhocen_bar, dzcen, & - chem_bar, chem_cls, & - ncls_ecpp, & - acen_tbeg, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - chem_sub_beg, & - acen_tbeg_use, ardz_cen_tbeg, rhodz_cen, & - activate_onoff_use, & - iphase_of_aerosol, laicwpair_of_aerosol ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_tdx_startup does some "startup" calculations -! -! re-initializes the acen_tbeg to all-quiescent and the -! chem_cls to chem_bar at the re-init time (if this is turned on) -! -! calculates chem_sub from chem_cls (which involves some assumptions -! for the interstial and activated aerosols) -! -!----------------------------------------------------------------------- - -! use module_state_descption, only: & -! p_num_a01, p_num_cw01, p_oin_a01, p_oin_cw01, & -! p_num_a03, p_num_cw03, p_oin_a03, p_oin_cw03 -! use module_data_ecpp1, only: & -! p_num_a01, p_num_cw01, p_oin_a01, p_oin_cw01, & -! p_num_a03, p_num_cw03, p_oin_a03, p_oin_cw03 - - use module_data_radm2, only: epsilc - - use module_data_mosaic_asect, only: ai_phase, cw_phase - - use module_data_ecpp1 - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message - -! arguments - integer, intent(in) :: & - ktau, ktau_pp, & - it, jt, kts, ktebnd, ktecen -! ktau - time step number -! ktau_pp - time step number for "parameterized pollutants" calculations -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) - - real(r8), intent(in) :: dtstep, dtstep_pp -! dtstep - main model time step (s) -! dtstep_pp - time step (s) for "parameterized pollutants" calculations - - real(r8), intent(in), dimension( kts:ktecen ) :: & - rhocen_bar, dzcen -! rhocen_bar, rhobnd_bar - dry air density (kg/m^3) at layer centers and boundaries -! dzcen - layer thicknesses (m) -! - real(r8), intent(in), dimension( kts:ktecen, 1:num_chem_ecpp ) :: & - chem_bar -! chem_bar - mixing ratios of trace gase (ppm) and aerosol species -! (ug/kg for mass species, #/kg for number species) - - real(r8), intent(inout), dimension( kts:ktecen, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_cls - - integer, intent(in) :: ncls_ecpp -! ncls_ecpp - number of ecpp transport classes in the grid column - - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tbeg - - integer, intent(in) :: ncls_use - - real(r8), intent(inout), & - dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_beg - - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tbeg_use, ardz_cen_tbeg - - real(r8), intent(inout), dimension( kts:ktecen ) :: rhodz_cen - - integer, intent(in) :: activate_onoff_use - - integer, intent(in), dimension( 1:num_chem_ecpp ) :: & - iphase_of_aerosol, laicwpair_of_aerosol - - -! local variables - integer :: icc, itmpa, jcls, jclsbb - integer :: k, l, la, laa, lbb, lc - integer :: lun161, lun162, lun164 - integer :: p1st - - real(r8) :: tmpa, tmpb, tmpqbarold - real(r8), dimension( 0:2 ) :: tmp_acen - real(r8), dimension( 1:num_chem_ecpp ) :: tmp_chem_cls - real(r8), dimension( 1:2, 1:num_chem_ecpp ) :: tmp_chem_sub - - - - p1st = param_first_ecpp - lun161 = -1 - if (idiagaa_ecpp(161) > 0) lun161 = ldiagaa_ecpp(161) - lun162 = -1 - if (idiagaa_ecpp(162) > 0) lun162 = ldiagaa_ecpp(162) - lun164 = -1 - if (idiagaa_ecpp(164) > 0) lun164 = ldiagaa_ecpp(164) - -! do sums of fractional areas over clear/cloudy and classes - do k = kts, ktecen - do jcls = 1, ncls_use - acen_tbeg(k,0,jcls) = sum( acen_tbeg(k,1:2,jcls) ) - end do - do icc = 0, 2 - tmpa = 0.0_r8 - do jclsbb = 2, ncls_use+1 - ! sum order is [2,3,...,ncls,1] instead of [1,2,...,ncls] - jcls = mod(jclsbb-1,ncls_use) + 1 - tmpa = tmpa + acen_tbeg(k,icc,jcls) - end do - acen_tbeg(k,icc,0) = tmpa - end do - end do - - -! -! with hybrid-time-dependent drafts, always do reinit calcs -! -! set all chem_cls = chem_bar for all species and levels - chem_cls(:,:,:) = 0.0_r8 - do l = 1, num_chem_ecpp - do jcls = 1, ncls_use - do k = kts, ktecen - chem_cls(k,jcls,l) = chem_bar(k,l) - end do - end do - end do - -! set up/dndraft areas to zero -! set quiescent areas to overall clear/cloudy fractions - do k = kts, ktecen - tmpa = acen_tbeg(k,1,0) ! this is total clear area (all classes) - tmpa = max( 0.0_r8, min( 1.0_r8, tmpa ) ) - -! force 100%/0%/70%/30% clear when iflag_ecpp_test_fixed_fcloud = 2/3/4/5 - if ((iflag_ecpp_test_fixed_fcloud >= 2) .and. & - (iflag_ecpp_test_fixed_fcloud <= 5)) then - if (iflag_ecpp_test_fixed_fcloud == 2) then - tmpa = 1.0_r8 - else if (iflag_ecpp_test_fixed_fcloud == 3) then - tmpa = 0.0_r8 - else if (iflag_ecpp_test_fixed_fcloud == 4) then - tmpa = 0.7_r8 - else - tmpa = 0.3_r8 - end if - end if - - acen_tbeg(k,:,:) = 0.0_r8 - acen_tbeg(k,0,jcls_qu) = 1.0_r8 - acen_tbeg(k,1,jcls_qu) = tmpa - acen_tbeg(k,2,jcls_qu) = 1.0_r8-tmpa - acen_tbeg(k,0:2,0) = acen_tbeg(k,0:2,jcls_qu) - end do - - -! -! update the chem_cls values based on "host-code" changes to chem_bar -! when iflag_ecpp_startup_host_chemtend > 0 - if (iflag_ecpp_startup_host_chemtend > 0) then - do l = p1st, num_chem_ecpp - do k = kts, ktecen - tmpa = 0.0_r8 - tmpb = 0.0_r8 - do jcls = 1, ncls_use - tmpa = tmpa + acen_tbeg(k,0,jcls)*chem_cls(k,jcls,l) - tmpb = tmpb + acen_tbeg(k,0,jcls) - end do - tmpqbarold = tmpa/max(tmpb,0.99_r8) - if (tmpqbarold < 1.01_r8*max(epsilc,1.0e-20_r8)) then - chem_cls(k,1:ncls_use,l) = chem_bar(k,l) - else if (chem_bar(k,l) > tmpqbarold) then - chem_cls(k,1:ncls_use,l) = chem_cls(k,1:ncls_use,l) + (chem_bar(k,l)-tmpqbarold) - else - chem_cls(k,1:ncls_use,l) = chem_cls(k,1:ncls_use,l) * (chem_bar(k,l)/tmpqbarold) - end if - end do - end do - end if - - -! do chem_sub_beg <-- chem_cls and acen_tbeg_use <-- acen_tbeg -! TODO - for aerosols, special treatment for "a" and "cw" in clear/cloudy sub-classes - acen_tbeg_use(:,:,:) = acen_tbeg(:,:,:) - chem_sub_beg(:,:,:,:) = 0.0_r8 - - do k = kts, ktecen - do jcls = 0, ncls_use - ardz_cen_tbeg(k,0:2,jcls) = acen_tbeg_use(k,0:2,jcls)*rhodz_cen(k) - end do - end do - - do jcls = 1, ncls_use - do k = kts, ktecen - do l = p1st, num_chem_ecpp - chem_sub_beg(k,1:2,jcls,l) = chem_cls(k,jcls,l) - end do - end do - end do - -! for aerosols, special treatment for "a" and "cw" in clear/cloudy sub-classes - if ((activate_onoff_use > 0) .and. (iflag_ecpp_startup_acw_partition > 0)) then - -acwxx1_jcls_loop: & - do jcls = 1, ncls_use -acwxx1_k_loop: & - do k = kts, ktecen - - ! clear subarea ~= 0 --> all cloudy - ! no special treatment in this case - if (acen_tbeg_use(k,1,jcls) < afrac_cut_0p5) cycle acwxx1_k_loop - - ! cloudy subarea ~= 0 and clear subarea > 0 - ! resuspend any cloudborne material - if (acen_tbeg_use(k,2,jcls) < afrac_cut_0p5) then - do la = p1st, num_chem_ecpp - if (iphase_of_aerosol(la) /= ai_phase) cycle - lc = laicwpair_of_aerosol(la) - if (lc < p1st) cycle - if (iphase_of_aerosol(lc) /= cw_phase) cycle - - tmpa = chem_cls(k,jcls,la) + chem_cls(k,jcls,lc) - chem_sub_beg(k,1:2,jcls,la) = tmpa - chem_sub_beg(k,1:2,jcls,lc) = 0.0_r8 - chem_cls(k,jcls,la) = tmpa - chem_cls(k,jcls,lc) = 0.0_r8 - end do ! la - cycle acwxx1_k_loop - end if - - ! at this point, clear and cloudy subareas > 0 - tmp_acen(0:2) = acen_tbeg_use(k,0:2,jcls) - tmp_chem_cls(p1st:num_chem_ecpp) = chem_cls(k,jcls,p1st:num_chem_ecpp) - tmp_chem_sub(1:2,p1st:num_chem_ecpp) = chem_sub_beg(k,1:2,jcls,p1st:num_chem_ecpp) - - if (lun164 > 0) & - write(lun164,'(/a,8i5)') 'aa ktau,jcls,k ', ktau,jcls,k - call parampollu_tdx_partition_acw( & - tmp_acen, tmp_chem_cls, tmp_chem_sub, & - ktau, it, jt, k, jcls, lun164 ) - - chem_sub_beg(k,1:2,jcls,p1st:num_chem_ecpp) = tmp_chem_sub(1:2,p1st:num_chem_ecpp) - - end do acwxx1_k_loop - end do acwxx1_jcls_loop - - end if ! ((activate_onoff_use > 0) .and. (iflag_ecpp_startup_acw_partition > 0)) - - if ((lun161 > 0) .and. (kts > -1)) then -! la = p_num_a03 ; lc = p_num_cw03 -! write(lun161,'(/a,4i6)') 'startup - ktau, l_num_ac03', ktau, la, lc, laicwpair_of_aerosol(la) -! la = p_oin_a03 ; lc = p_oin_cw03 -! if (lun162 > 0) & -! write(lun162,'(/a,4i6)') 'startup - ktau, l_oin_ac03', ktau, la, lc, laicwpair_of_aerosol(la) -! do k = min(10,ktecen), kts, -1 - -! write(lun161,'(i2,2(1x,2l1),2(2x, 2x,2(2x,2f11.8)))') k, & -! (( (acen_tbeg_use(k,icc,jcls)>afrac_cut_0p5), icc=1,2 ), jcls=1,2 ), & -! (( acen_tbeg_use(k,icc,jcls), icc=1,2 ), jcls=1,2 ) - -! la = p_num_a01 ; lc = p_num_cw01 ; tmpa = 1.0e-9 -! la = p_num_a03 ; lc = p_num_cw03 ; tmpa = 1.0e-6 -! write(lun161,'(i2, 1x,a5, 2(3x,f6.3,2(1x,3f6.3)))') k, 'num_3', & -! ( tmpa*chem_bar(k,l), & -! ( tmpa*chem_cls(k,jcls,l), tmpa*chem_sub_beg(k,1:2,jcls,l), jcls=1,2 ), & -! l=la,lc,lc-la ) -! la = p_oin_a01 ; lc = p_oin_cw01 ; tmpa = 1.0 -! la = p_oin_a03 ; lc = p_oin_cw03 ; tmpa = 1.0 -! write(lun161,'(i2, 1x,a5, 2(3x,f6.3,2(1x,3f6.3)))') k, 'oin_3', & -! ( tmpa*chem_bar(k,l), & -! ( tmpa*chem_cls(k,jcls,l), tmpa*chem_sub_beg(k,1:2,jcls,l), jcls=1,2 ), & -! l=la,lc,lc-la ) - -! end do - end if ! ((lun161 > 0) .and. (kts > -1)) - - - return - end subroutine parampollu_tdx_startup - - -!----------------------------------------------------------------------- - subroutine parampollu_tdx_partition_acw( & - acen, chem_cls, chem_sub, & - ktau, i, j, k, jcls, lun164 ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_tdx_partition_acw paritions interstitial ("a") and -! activate/cloudborne ("cw") aerosol species to the clear and cloudy -! fractions of a grid cell (or grid cell transport-class) -! -!----------------------------------------------------------------------- - - use module_data_mosaic_asect, only: ai_phase, cw_phase, & - ncomp_aer, nsize_aer, ntype_aer, & - massptr_aer, numptr_aer, & !waterptr_aer, & - dens_aer, volumlo_sect, volumhi_sect - - use module_data_ecpp1 - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message, & - parampollu_1clm_set_opts - -! arguments - integer, intent(in) :: & - ktau, i, j, k, jcls, lun164 -! ktau - time step number -! [i, k, j] - spatial (x,z,y) indices for grid cell - - real(r8), intent(in), dimension( 0:2 ) :: acen - - real(r8), intent(in), dimension( 1:num_chem_ecpp ) :: chem_cls - - real(r8), intent(inout), dimension( 1:2, 1:num_chem_ecpp ) :: chem_sub - - -! local variables - integer :: iphase, isize, itmpa, itype - integer :: la, lc, ll - - real(r8) :: fx, fy - real(r8) :: q_a_x, q_a_y, q_a_bar, & - q_c_x, q_c_y, q_c_bar, & - q_ac_x, q_ac_y, q_ac_bar, & - qn_a_x, qn_a_y, qn_a_bar, & - qn_a_x_sv, qn_a_y_sv, & - qv_a_x, qv_a_y, qv_a_bar - real(r8) :: tmpa - - character(len=120) :: msg - - - - if (min(acen(1),acen(2)) < afrac_cut_0p5) then - write(msg,'(a,i10,3i5,1p,2e12.4)') & - '*** parampollu_tdx_partition_acw - bad acen(1:2)', & - ktau, i, j, k, acen(1:2) - call ecpp_message( lunout, msg ) - call ecpp_error_fatal( lunout, msg ) - return - end if - fy = acen(2)/(acen(1)+acen(2)) - fx = 1.0_r8 - fy - -! main loops over aerosol types and sizes - do itype = 1, ntype_aer - do isize = 1, nsize_aer(itype) - -! first partition number and dry-mass species -! in a manner that attempts to get the "a+cw" mixing ratios -! in clear and cloudy subareas to be equal the -! cell/class average (clear+cloudy) "a+cw" mixing ratios - qv_a_x = 0.0_r8 ; qv_a_y = 0.0_r8 - do ll = 0, ncomp_aer(itype) - if (ll == 0) then - la = numptr_aer(isize,itype,ai_phase) - lc = numptr_aer(isize,itype,cw_phase) - else - la = massptr_aer(ll,isize,itype,ai_phase) - lc = massptr_aer(ll,isize,itype,cw_phase) - end if - -! nomenclature for q_... -! a = interstitial; c = cloudborne; ac = a+c -! x = in clear subarea; y = in cloudy subarea; -! bar = average over both subareas -! -! following always hold -! q_ac_any == q_a_any + q_c_any -! q_any_bar == q_any_x*fx + q_any_y*fy -! - q_a_bar = max( 0.0_r8, chem_cls(la) ) - q_c_bar = max( 0.0_r8, chem_cls(lc) ) - q_ac_bar = q_a_bar + q_c_bar - q_c_y = q_c_bar/fy - q_c_x = 0.0_r8 - q_a_y = max( 0.0_r8, (q_ac_bar - q_c_y) ) - q_a_x = max( 0.0_r8, (q_a_bar - q_a_y*fy)/fx ) - -! if ((k <= 5) .and. (isize == 1) .and. (ll == 3)) then - if ((k <= 5) .and. (isize == 3) .and. (ll==3 .or. ll==0)) then - if (lun164 > 0) then - write(lun164,'(/a,8i5)') 'bb ktau,jcls,k,isize,ll', ktau,jcls,k,isize,ll - write(lun164,'(a,1p,8e12.4)') 'acen1/2, fx/y', acen(1:2), fx, fy - write(lun164,'(a,1p,8e12.4)') 'chem_cls ', chem_cls(la), chem_cls(lc) - write(lun164,'(a,1p,8e12.4)') 'chem_sub old ', chem_sub(1:2,la), chem_sub(1:2,lc) - end if - end if - chem_sub(1,la) = q_a_x - chem_sub(2,la) = q_a_y - chem_sub(1,lc) = q_c_x - chem_sub(2,lc) = q_c_y -! if ((k <= 5) .and. (isize == 1) .and. (ll == 3)) then - if ((k <= 5) .and. (isize == 3) .and. (ll==3 .or. ll==0)) then - if (lun164 > 0) & - write(lun164,'(a,1p,8e12.4)') 'chem_sub new ', chem_sub(1:2,la), chem_sub(1:2,lc) - end if - - if (ll == 0) then - qn_a_x = q_a_x - qn_a_y = q_a_y - else - qv_a_x = qv_a_x + q_a_x/dens_aer(ll,itype) - qv_a_y = qv_a_y + q_a_y/dens_aer(ll,itype) - end if - end do - qv_a_x = qv_a_x*1.0e-6_r8 ! because mass mixratios are ug/kg, - qv_a_y = qv_a_y*1.0e-6_r8 ! and want volume mixratio in cm3-aerosol/kg - -! now check that the partitioning has not produced an out-of-bounds size -! (size = mean 1-particle volume) for interstitial in clear or cloudy subareas -! if this has occurred, then partition the number differently - qv_a_bar = qv_a_x*fx + qv_a_y*fy - qn_a_bar = qn_a_x*fx + qn_a_y*fy - qn_a_x_sv = qn_a_x ; qn_a_y_sv = qn_a_y - if ( (qv_a_bar <= 1.0e-30_r8) .or. & - (qv_a_bar <= qn_a_bar*volumlo_sect(isize,itype)) .or. & - (qv_a_bar >= qn_a_bar*volumhi_sect(isize,itype)) ) then - ! neglible dry volume, or size already out-of-bounds - tmpa = max(qv_a_bar,1.0e-35_r8) - qn_a_x = qn_a_bar * ( max(qv_a_x,0.5e-35_r8) / tmpa ) - qn_a_y = qn_a_bar * ( max(qv_a_y,0.5e-35_r8) / tmpa ) - if (qv_a_bar <= 1.0e-30_r8) then - itmpa = 1 - else if (qv_a_bar <= qn_a_bar*volumlo_sect(isize,itype)) then - itmpa = 2 - else - itmpa = 3 - end if - - else if (qv_a_x <= qn_a_x*volumlo_sect(isize,itype)) then - ! size to small in clear subarea - qn_a_x = qv_a_x/volumlo_sect(isize,itype) - qn_a_y = max( 0.0_r8, (qn_a_bar - qn_a_x*fx)/fy ) - itmpa = 4 - else if (qv_a_y <= qn_a_y*volumlo_sect(isize,itype)) then - ! size to small in cloudy subarea - qn_a_y = qv_a_y/volumlo_sect(isize,itype) - qn_a_x = max( 0.0_r8, (qn_a_bar - qn_a_y*fy)/fx ) - itmpa = 5 - - else if (qv_a_x >= qn_a_x*volumhi_sect(isize,itype)) then - ! size to large in clear subarea - qn_a_x = qv_a_x/volumhi_sect(isize,itype) - qn_a_y = max( 0.0_r8, (qn_a_bar - qn_a_x*fx)/fy ) - itmpa = 6 - else if (qv_a_y >= qn_a_y*volumhi_sect(isize,itype)) then - ! size to large in cloudy subarea - qn_a_y = qv_a_y/volumhi_sect(isize,itype) - qn_a_x = max( 0.0_r8, (qn_a_bar - qn_a_y*fy)/fx ) - itmpa = 7 - else - itmpa = 0 - end if - la = numptr_aer(isize,itype,ai_phase) - chem_sub(1,la) = qn_a_x - chem_sub(2,la) = qn_a_y - if ((k <= 5) .and. (isize == 3)) then - if ((itmpa==5) .and. (qv_a_y>0.0_r8)) itmpa=8 - if ((itmpa==5) .and. (qn_a_y>0.0_r8)) itmpa=9 - if (lun164 > 0) then - write(lun164,'(/i1,a,1p,8e12.4)') itmpa, ' final num_a', chem_sub(1:2,la) - write(lun164,'( 13x,1p,8e12.4)') qn_a_x_sv, qn_a_y_sv, qn_a_bar, qv_a_x, qv_a_y - end if - end if - -! aerosol water - do this for now, but it should be improved -! comment out now, need to check with Dick Easter. +++mhwang -! -! la = waterptr_aer(isize,itype) -! tmpa = max(qv_a_bar,1.0e-35) -! chem_sub(1,la) = ( max(qv_a_x,0.5e-35) / tmpa ) * chem_cls(la) -! chem_sub(2,la) = ( max(qv_a_y,0.5e-35) / tmpa ) * chem_cls(la) - - end do - end do - - - - return - end subroutine parampollu_tdx_partition_acw - -!----------------------------------------------------------------------- - subroutine parampollu_tdx_cleanup( & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - chem_bar, chem_cls, & - ncls_ecpp, & - acen_tfin_ecpp, & - it, jt, kts,ktebnd,ktecen, & - ncls_use, & - chem_sub_beg, chem_sub_new, & - del_chem_clm_cldchem, del_chem_clm_wetscav, & - del_cldchem3d, del_rename3d, & - del_wetdep3d, del_wetresu3d, & - del_activate3d, del_conv3d, & - acen_tbeg_use, acen_tfin_use, rhodz_cen, & - activate_onoff_use, & - iphase_of_aerosol, isize_of_aerosol, & - itype_of_aerosol, inmw_of_aerosol, & - laicwpair_of_aerosol ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_tdx_cleanup does some final "cleanup" calculations -! -! calculates final chem_cls and chem_bar from the final chem_sub -! -! calculates beginning and final column-average mixing ratios -! and checks for mass conservation -! -!----------------------------------------------------------------------- - - use module_data_mosaic_asect, only: ai_phase, cw_phase, & - nsize_aer, massptr_aer, numptr_aer - - use module_data_radm2, only: epsilc - - use module_data_ecpp1 - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message - -! arguments - integer, intent(in) :: & - ktau, ktau_pp, & - it, jt, kts, ktebnd, ktecen -! ktau - time step number -! ktau_pp - time step number for "parameterized pollutants" calculations -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) - - real(r8), intent(in) :: dtstep, dtstep_pp -! dtstep - main model time step (s) -! dtstep_pp - time step (s) for "parameterized pollutants" calculations - - real(r8), intent(inout), dimension( kts:ktecen, 1:num_chem_ecpp ) :: & - chem_bar -! chem_bar - mixing ratios of trace gase (ppm) and aerosol species -! (ug/kg for mass species, #/kg for number species) - - real(r8), intent(inout), dimension( kts:ktecen, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_cls - - integer, intent(in) :: ncls_ecpp -! ncls_ecpp - number of ecpp transport classes in the grid column - - - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tfin_ecpp - - integer, intent(in) :: ncls_use - - real(r8), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - chem_sub_beg, chem_sub_new - - real(r8), intent(inout), dimension( 1:num_chem_ecpp ) :: & - del_chem_clm_cldchem, del_chem_clm_wetscav - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:2, 1:num_chem_ecpp ) :: & - del_cldchem3d, del_rename3d, del_wetdep3d, del_wetresu3d - - real(r8), intent(in), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - del_activate3d - - real(r8), intent(out), dimension( kts:ktecen, 1:2, 1:maxcls_ecpp, 1:num_chem_ecpp ) :: & - del_conv3d - - real(r8), intent(in), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tbeg_use, acen_tfin_use - - real(r8), intent(in), dimension( kts:ktecen ) :: rhodz_cen - - integer, intent(in) :: activate_onoff_use - - integer, intent(in), dimension( 1:num_chem_ecpp ) :: & - iphase_of_aerosol, isize_of_aerosol, itype_of_aerosol, & - inmw_of_aerosol, laicwpair_of_aerosol - - - -! local variables - integer :: ia, ib, icc - integer :: jcls, jclsbb - integer :: k - integer :: l, la, laa, lbb, lc, lewa, lewc, lun119, lun121 - integer :: laicwpair_flagaa - integer, save :: ktaueww = 0 - - real(r8) :: air_clmmass - real(r8) :: chem_cutoff_aa - real(r8) :: tmpa, tmpb, tmpe, tmpew, tmpx, tmpy, tmpz - real(r8) :: tmpa_clmavg(1:6), tmpw_clmavg(1:6) - real(r8) :: tmpveca( kts:ktecen ), tmpvecb( kts:ktecen ) - real(r8) :: tmpvece(1:6) - real(r8), save :: tmpeww = 0.0_r8 - - real(r8), dimension( 1:6, 1:num_chem_ecpp ) :: chem_clmavg - real(r8), dimension( kts:ktecen, 1:num_chem_ecpp ) :: chem_bar_beg - - - - lun121 = -1 - if (idiagaa_ecpp(121) > 0) lun121 = ldiagaa_ecpp(121) - - del_conv3d = 0.0_r8 -! calculate initial clmmass and del_conv3d - air_clmmass = sum( rhodz_cen(kts:ktecen) ) - do l = param_first_ecpp, num_chem_ecpp - tmpveca(:) = 0.0_r8 ; tmpvecb(:) = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - do k = kts, ktecen - tmpveca(k) = tmpveca(k) + acen_tbeg_use(k,icc,jcls)*chem_cls( k, jcls,l) - tmpvecb(k) = tmpvecb(k) + acen_tbeg_use(k,icc,jcls)*chem_sub_beg(k,icc,jcls,l) - end do - end do - end do - chem_clmavg(1,l) = sum( rhodz_cen(kts:ktecen)*chem_bar(kts:ktecen,l) ) - chem_clmavg(2,l) = sum( rhodz_cen(kts:ktecen)*tmpveca(kts:ktecen) ) - chem_clmavg(3,l) = sum( rhodz_cen(kts:ktecen)*tmpvecb(kts:ktecen) ) - end do - if ((ktau < 0) .and. (lun121 > 0)) then - l = 17 - icc = 1 -! write(lun121,*) 'ktau, l, ncls_use', ktau, l, ncls_use -! write(lun121,*) 'k, old chem_bar, old chem_cls, chem_sub_beg, acen_tbeg_use' -! do k = ktecen, kts, -1 -! write(lun121,'(i3,1p,e12.5,3(3x,3e12.5))') k, chem_bar(k,l), & -! chem_cls(k,1:3,l), chem_sub_beg(k,icc,1:3,l), acen_tbeg_use(k,icc,1:3) -! end do - end if -! if (ktau > 1) stop - - -! do acen_tfin_ecpp <-- acen_tfin_use - acen_tfin_ecpp(:,:,:) = acen_tfin_use(:,:,:) - - -! compute new chem_cls (class-avg mix ratios) and chem_bar (grid-avg mix ratios) - chem_bar_beg(:,:) = chem_bar(:,:) - do l = param_first_ecpp, num_chem_ecpp - do k = kts, ktecen - - tmpa = 0.0_r8 ; tmpb = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - tmpa = tmpa + acen_tfin_use(k,icc,jcls)* & - max(0.0_r8,chem_sub_new(k,icc,jcls,l)) - tmpb = tmpb + acen_tfin_use(k,icc,jcls) - - del_conv3d(k,icc,jcls,l) = (acen_tfin_use(k,icc,jcls)*max(0.0_r8, chem_sub_new(k,icc,jcls,l)) & - - acen_tbeg_use(k,icc,jcls)*chem_sub_beg(k,icc,jcls,l)) & - - del_activate3d(k,icc,jcls,l) & - - del_cldchem3d(k,icc,jcls,1,l)-del_cldchem3d(k,icc,jcls,2,l) & - - del_rename3d(k,icc,jcls,1,l)-del_rename3d(k,icc,jcls,2,l) & - - del_wetdep3d(k,icc,jcls,1,l)-del_wetdep3d(k,icc,jcls,2,l) & - - del_wetresu3d(k,icc,jcls,1,l)-del_wetresu3d(k,icc,jcls,2,l) - end do - end do -! chem_bar(k,l) = max(0.0_r8,tmpa)/tmpb - chem_bar(k,l) = tmpa ! chem_bar is used to calcualte q tendency at the MMF model, - ! so keep it consistent with del_conv3d - - do jcls = 1, ncls_use - tmpa = 0.0_r8 ; tmpb = 0.0_r8 - do icc = 1, 2 - tmpa = tmpa + acen_tfin_use(k,icc,jcls)* & - max(0.0_r8,chem_sub_new(k,icc,jcls,l)) - tmpb = tmpb + acen_tfin_use(k,icc,jcls) - end do - if (tmpb >= afrac_cut_0p5) then - chem_cls(k,jcls,l) = max(0.0_r8,tmpa)/tmpb - else - chem_cls(k,jcls,l) = chem_bar(k,l) - end if - end do - - end do - end do - - -! calculate final clmmass - do l = param_first_ecpp, num_chem_ecpp - tmpveca(:) = 0.0_r8 ; tmpvecb(:) = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - do k = kts, ktecen - tmpveca(k) = tmpveca(k) + acen_tfin_use(k,icc,jcls)*chem_cls( k, jcls,l) - tmpvecb(k) = tmpvecb(k) + acen_tfin_use(k,icc,jcls)*chem_sub_new(k,icc,jcls,l) - end do - end do - end do - chem_clmavg(4,l) = sum( rhodz_cen(kts:ktecen)*chem_bar(kts:ktecen,l) ) - chem_clmavg(5,l) = sum( rhodz_cen(kts:ktecen)*tmpveca(kts:ktecen) ) - chem_clmavg(6,l) = sum( rhodz_cen(kts:ktecen)*tmpvecb(kts:ktecen) ) - chem_clmavg(1:6,l) = chem_clmavg(1:6,l)/air_clmmass - end do - if ((ktau < 0) .and. (lun121 > 0)) then - l = 17 - icc = 1 -! write(lun121,*) 'ktau, l, ncls_use', ktau, l, ncls_use -! write(lun121,*) 'k, new chem_bar, new chem_cls, chem_sub_new, acen_tfin_use' - do k = ktecen, kts, -1 -! write(lun121,'(i3,1p,e12.5,3(3x,3e12.5))') k, chem_bar(k,l), & -! chem_cls(k,1:3,l), chem_sub_new(k,icc,1:3,l), acen_tfin_use(k,icc,1:3) - end do - end if -! if (ktau > 5) stop - if ((ktau < 5) .and. (lun121 > 0)) then - l = 9 -! write(lun121,'(/a,3i5)') 'ktau, l, ncls_use ', ktau, l, ncls_use -! write(lun121,'(a)') 'k, ((chem_sub_beg(k,icc,jcls,l), chem_sub_new(k,icc,jcls,l), icc=1,2), jcls=1,...) ' - do k = ktecen, kts, -1 -! write(lun121,'(i3,1p,6(2x,2e10.3))') k, & -! ((chem_sub_beg(k,icc,jcls,l), chem_sub_new(k,icc,jcls,l), icc=1,2), jcls=1,ncls_use) - end do - end if - - -! diagnostic output to unit 121 - if (lun121 > 0) then - -! write(lun121,'(/a,2i6)') 'parampollu_1clm clmmass check - ktau, ktau_pp =', & -! ktau, ktau_pp - lewa = 0 - lewc = 0 - tmpew = 0.0_r8 - chem_cutoff_aa = 3.0_r8*epsilc - laicwpair_flagaa = 0 - if ( (activate_onoff_use > 0) .and. & - (activate_onoff_use /=100) ) laicwpair_flagaa = 2 - do la = param_first_ecpp, num_chem_ecpp - l = -999888777 - lc = 0 - if (laicwpair_flagaa == 2) then - if (iphase_of_aerosol(la) == ai_phase) then - lc = laicwpair_of_aerosol(la) - else if (iphase_of_aerosol(la) == cw_phase) then - cycle - end if - end if - if ((lc < param_first_ecpp) .or. (lc > num_chem_ecpp)) lc = 0 - - ! these are the 3 initial and 3 final values of column-average mixing ratio - ! for the current species (or species la-lc pair) - tmpa_clmavg(1:6) = chem_clmavg(1:6,la) - if (lc > 0) tmpa_clmavg(1:6) = tmpa_clmavg(1:6) + chem_clmavg(1:6,lc) - - ! for the 3 final values, subtract off the change from cldchem and wetscav - tmpa = del_chem_clm_cldchem(la) + del_chem_clm_wetscav(la) - if (lc > 0) tmpa = tmpa + del_chem_clm_cldchem(lc) + del_chem_clm_wetscav(lc) - tmpa = tmpa/air_clmmass - tmpa_clmavg(4:6) = tmpa_clmavg(4:6) - tmpa - - do ia = 1, 6 - ib = mod(ia,6) + 1 - tmpa = tmpa_clmavg(ia) - tmpb = tmpa_clmavg(ib) - tmpvece(ia) = abs( tmpa-tmpb ) & - / max( abs(tmpa), abs(tmpb), 1.0e-30_r8 ) - end do - tmpx = maxval( tmpa_clmavg(1:6) ) - tmpy = minval( tmpa_clmavg(1:6) ) - tmpz = max( abs(tmpx), abs(tmpy), 1.0e-30_r8 ) - ! ignore species with max,min( clmavg mixratios ) < chem_cutoff_aa - if (tmpz >= chem_cutoff_aa) then - tmpe = abs( tmpx-tmpy ) / tmpz - else - tmpe = 0.0_r8 - end if - if (tmpe > tmpew) then - tmpew = tmpe - lewa = la - lewc = lc - tmpw_clmavg(:) = tmpa_clmavg(:) - end if - - if (tmpe > 1.0e-12_r8 ) then - write(lun121,'(a,2i3,1p,2(3x,6e10.2))') 'la/c=', la, lc, & - tmpa_clmavg(1:6), tmpvece(1:6) - - write(0,'(a,2i3,1p,2(3x,6e10.2))') 'mass convervation error in ecpp, la/c=', la, lc, & - tmpa_clmavg(1:6), tmpvece(1:6) - call endrun('mass convervation error in ecpp_cleanup') - end if - end do - if (tmpew > tmpeww) then - tmpeww = tmpew - ktaueww = ktau - end if - if (lewa > 0) then - write(lun121,'(a,2i3,1p,e10.2,10x,2i6,e10.2)') 'worst clmmass error - la/c=', & - lewa, lewc, tmpew, ktau, ktaueww, tmpeww - write(lun121,'(a,1p,6e14.6)') 'chem_clmavg(1:6,l)', tmpw_clmavg(1:6) - end if - - end if ! (lun121 > 0) - - -! diagnostic output to unit 119 - lun119 = -1 - if (idiagaa_ecpp(119) > 0) lun119 = ldiagaa_ecpp(119) - if (lun119 > 0) then - write(lun119,'(/a,2i5)') 'parampollu_1clm - pt2 ktau, ktau_pp =', ktau, ktau_pp -! do laa = param_first_ecpp, num_chem_ecpp, 3 -! lbb = min( laa+2, num_chem_ecpp ) -! do laa = param_first_ecpp, num_chem_ecpp, 4 -! lbb = min( laa+3, num_chem_ecpp ) - do laa = 9, 9 - lbb = min( laa+3, num_chem_ecpp ) - write(lun119,'(/a,4i5)') 'ktau, ktau_pp, laa, lbb =', ktau, ktau_pp, laa, lbb - write(lun119,'(a)') ' k, chem_bar_beg, chem_bar' - do k = ktecen, kts, -1 -! write(lun119,'(i2,4(2x,2f9.5))') k, & - write(lun119,'(i2,4(2x,1p,2e10.2))') k, & - (chem_bar_beg(k,l), chem_bar(k,l), l=laa, lbb) - end do -! write(lun119,'(i2,4(2x,2f9.5))') -1, & - write(lun119,'(i2,4(2x,1p,2e10.2))') -1, & - (chem_clmavg(2,l), chem_clmavg(5,l), l=laa, lbb) -! write(lun119,'(i2,1p,4e20.5))') -2, & - write(lun119,'(i2,4(2x,1p,e20.2))') -2, & - ( (chem_clmavg(2,l)-chem_clmavg(5,l)), l=laa, lbb) - end do - end if ! (lun119 > 0) - - - return - end subroutine parampollu_tdx_cleanup - - - -!----------------------------------------------------------------------- - subroutine parampollu_check_adjust_inputs( & - ipass_check_adjust_inputs, & - ktau, dtstep, ktau_pp, dtstep_pp, & - idiagaa_ecpp, ldiagaa_ecpp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - kdraft_bot_ecpp, kdraft_top_ecpp, & - mtype_updnenv_ecpp, & - mfbnd_ecpp, abnd_tavg_ecpp, & - acen_tavg_ecpp, acen_tfin_ecpp, acen_prec_ecpp, & - wbnd_bar_use, & - ncls_use, & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use, & - mfbnd_use, mfbnd_quiescn_up, mfbnd_quiescn_dn, & - abnd_tavg_use, & - acen_tavg_use, acen_tfin_use, acen_prec_use, & - rhodz_cen, & - it, jt, kts,ktebnd,ktecen ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_check_adjust_inputs does checking and adjustment -! of several of the ecpp arrays -! -! fractional areas less than afrac_cut are set to zero -! up and downdraft mass fluxes less than ... are set to zero -! remaining fractional areas are adjusted so that the sum is 1.0 -! -! all mass fluxes are set to zero at/above k_max_wnonzero -! up and downdraft mass fluxes and areas are set to zero at/above k_max_updndraft -! cloud fractional areas are set to zero at/above k_max_clouds -! -! the checks and adjustment are designed to eliminate "problems" in -! the input/incoming arrays that might cause the rest of the -! parampollu code to fail -! -!----------------------------------------------------------------------- - - use module_data_ecpp1 - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message - -! arguments - integer, intent(in) :: & - ipass_check_adjust_inputs, & - ktau, ktau_pp, & - it, jt, kts, ktebnd, ktecen -! ktau - time step number -! ktau_pp - time step number for "parameterized pollutants" calculations - -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - integer, intent(in) :: idiagaa_ecpp(1:199), ldiagaa_ecpp(1:199) - - real(r8), intent(in) :: dtstep, dtstep_pp -! dtstep - main model time step (s) -! dtstep_pp - time step (s) for "parameterized pollutants" calculations - - real(r8), intent(in), dimension( kts:ktecen ) :: & - tcen_bar, pcen_bar, rhocen_bar, dzcen - real(r8), intent(in), dimension( kts:ktebnd ) :: & - rhobnd_bar, zbnd, wbnd_bar - - real(r8), intent(inout), dimension( kts:ktebnd ) :: & - wbnd_bar_use - - real(r8), intent(inout), dimension( kts:ktecen, 1:num_chem_ecpp ) :: & - chem_bar - - integer, intent(in) :: ncls_ecpp - integer, intent(inout) :: ncls_use - - integer, intent(in), dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_ecpp, kdraft_top_ecpp, & - mtype_updnenv_ecpp - integer, intent(inout), dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_use, kdraft_top_use, & - mtype_updnenv_use - - real(r8), intent(in), dimension( kts:ktebnd, 0:2, 0:maxcls_ecpp ) :: & - mfbnd_ecpp, abnd_tavg_ecpp - real(r8), intent(inout), dimension( kts:ktebnd, 0:2, 0:maxcls_ecpp ) :: & - mfbnd_use, abnd_tavg_use - real(r8), intent(in), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tavg_ecpp, acen_tfin_ecpp, acen_prec_ecpp - real(r8), intent(inout), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tavg_use, acen_tfin_use, acen_prec_use - real(r8), intent(inout), dimension( kts:ktebnd, 0:2, 0:2 ) :: & - mfbnd_quiescn_up, mfbnd_quiescn_dn - real(r8), intent(inout), dimension( kts:ktecen ) :: rhodz_cen - - -! local variables - integer :: k_max_updndraft - integer :: k_max_clouds - integer :: k_max_wnonzero - - integer :: i, icc, itmpa, itmpb - integer :: ido_downdr_area_zeroout, ido_updndr_area_adjust, ipass_2_changes - integer :: ispecial_check_acen_tfin - integer :: ja, jb - integer :: jcls, jclsbb - integer :: jclsicc, jclsicc_noc, jclsicc_cld - integer :: k, ka, kb, ktmpa, ktmpb - integer :: lun63, lun141, lun155 - integer :: ncls_noc, ncls_cld - integer :: nchanges(10) - integer :: kdraft_bot_tmp(1:2,1:maxcls_ecpp), kdraft_top_tmp(1:2,1:maxcls_ecpp) - integer :: mtype_updnenv_tmp(1:2,1:maxcls_ecpp) - - real(r8) :: ardz_cut ! sub-class fractional areas below this value are set to zero - real(r8) :: arw_draft_cut ! mass fluxes below this value are set to zero - real(r8) :: a_sum_toleraa = 1.0e-5_r8 ! tolerance for abs(sum(axxx) - 1.0) - real(r8) :: afrac_noc, afrac_cld - real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpq, tmpu - real(r8) :: tmp_afrac - real(r8) :: tmp_mfa, tmp_mfb - real(r8) :: tmp_tola, tmp_tolb - real(r8) :: tmpvecaa(0:ktebnd), tmpvecbb(0:ktebnd), tmpvecdd(0:ktebnd) - real(r8) :: tmp0202aa(0:2,0:2) - real(r8) :: updndr_area_adjust - - character(len=100) :: msg - character(len=10) :: area_name10(1:3) = & - (/ 'abnd_tavg ', 'acen_tavg ', 'acen_tfin ' /) - - - lun63 = -1 - if (idiagaa_ecpp(63) > 0) lun63 = ldiagaa_ecpp(63) - lun141 = -1 - if (idiagaa_ecpp(141) > 0) lun141 = ldiagaa_ecpp(141) - lun155 = -1 - if (idiagaa_ecpp(155) > 0) lun155 = ldiagaa_ecpp(155) - - if ((ipass_check_adjust_inputs /= 1) .and. & - (ipass_check_adjust_inputs /= 2)) return - - -! force w = 0 at kbnd >= k_max_wnonzero -! (note - doing k_max_wnonzero = ktebnd-1 would probably be ok) - k_max_wnonzero = ktebnd-1 - -! force up/dn draft mf & afrac = 0 at kbnd,kcen >= k_max_updndraft -! (note - currently set k_max_updndraft & _kclouds to almost top of domain) - k_max_updndraft = ktebnd-1 - -! force cloud fraction = 0 at kbnd,kcen >= k_max_clouds - k_max_clouds = ktebnd-1 - - nchanges(:) = 0 - - -!----------------------------------------------------- -! when ipass_check_adjust_inputs == 2, -! skip to he beginning of the special stuff for ipass_check_adjust_inputs == 2 - if (ipass_check_adjust_inputs == 2) goto 20000 -!----------------------------------------------------- - - -! -! copy from "_ecpp" arrays to "_use" arrays -! - ncls_use = ncls_ecpp - - kdraft_bot_use(:,:) = kdraft_bot_ecpp(:,:) - kdraft_top_use(:,:) = kdraft_top_ecpp(:,:) - - mtype_updnenv_use(:,:) = mtype_updnenv_ecpp(:,:) - - wbnd_bar_use(:) = wbnd_bar(:) - - mfbnd_use(:,:,:) = mfbnd_ecpp(:,:,:) - abnd_tavg_use(:,:,:) = max( abnd_tavg_ecpp(:,:,:), 0.0_r8 ) - acen_tavg_use(:,:,:) = max( acen_tavg_ecpp(:,:,:), 0.0_r8 ) - acen_tfin_use(:,:,:) = max( acen_tfin_ecpp(:,:,:), 0.0_r8 ) -! acen_tavg_use(kte,:,:) = 0.0 -! acen_tfin_use(kte,:,:) = 0.0 - -! calc rhodz_cen - rhodz_cen(kts:ktecen) = rhocen_bar(kts:ktecen)*dzcen(kts:ktecen) - - -! check that -! the mtype_updnenv_use are valid -! there is exactly one of each quiescent transport class (cloudy, clear) - jclsicc_noc = -1 - jclsicc_cld = -1 - ncls_noc = 0 - ncls_cld = 0 - msg = ' ' - - do jcls = 1, ncls_use - do icc = 1, 2 - jclsicc = jcls*10 + icc - if ((mtype_updnenv_use(icc,jcls) == mtype_quiescn_ecpp) .and. & - (icc == 1)) then - jclsicc_noc = jclsicc - ncls_noc = ncls_noc + 1 - end if - if ((mtype_updnenv_use(icc,jcls) == mtype_quiescn_ecpp) .and. & - (icc == 2)) then - jclsicc_cld = jclsicc - ncls_cld = ncls_cld + 1 - end if - - if ( ((jcls == jcls_qu) .and. & - (mtype_updnenv_use(icc,jcls) /= mtype_quiescn_ecpp)) .or. & - ((jcls /= jcls_qu) .and. & - (mtype_updnenv_use(icc,jcls) /= mtype_updraft_ecpp) .and. & - (mtype_updnenv_use(icc,jcls) /= mtype_dndraft_ecpp)) ) then - write( msg, '(a,5(1x,i5))' ) & - '*** parampollu_check_adjust_inputs - bad mtype_updnenv', & - it, jt, jcls, icc, mtype_updnenv_use(icc,jcls) - call ecpp_message( lunout, msg ) - end if - end do - end do - - if ((jclsicc_noc <= 0) .or. (ncls_noc > 1)) then - write(msg,'(a,2(1x,i5))') & - '*** parampollu_check_adjust_inputs - bad jclsicc_noc, ncls_noc =', & - jclsicc_noc, ncls_noc - call ecpp_message( lunout, msg ) - end if - if ((jclsicc_cld <= 0) .or. (ncls_cld > 1)) then - write(msg,'(a,2(1x,i5))') & - '*** parampollu_check_adjust_inputs - bad jclsicc_cld, ncls_cld =', & - jclsicc_cld, ncls_cld - call ecpp_message( lunout, msg ) - end if - if (msg /= ' ') call ecpp_error_fatal( lunout, msg ) - - - if ((ktau==4) .and. (lun155 > 0)) then - write(lun155,'(/a,3i5)') 'aaa', ktau, ipass_check_adjust_inputs - write(lun155,'(3(i5,i3,1pe16.8))') ((jcls,icc,acen_tavg_use(26,icc,jcls),icc=0,2),jcls=0,3) - end if -! *** this is for testing -! when iflag_ecpp_test_fixed_fcloud == 2/3/4/5, -! set clear fractions to 1.0/0.0/0.7/0.3 -! set cloudy fractions to 0.0/1.0/0.3/0.7 -! -! *** also set k_max_clouds=kte+1 so that it has no effect -! - if ((iflag_ecpp_test_fixed_fcloud >= 2) .and. & - (iflag_ecpp_test_fixed_fcloud <= 5)) then - k_max_clouds = ktebnd+1 - - if (iflag_ecpp_test_fixed_fcloud == 2) then - tmpvecaa(1) = 1.0_r8 - else if (iflag_ecpp_test_fixed_fcloud == 3) then - tmpvecaa(1) = 0.0_r8 - else if (iflag_ecpp_test_fixed_fcloud == 4) then - tmpvecaa(1) = 0.7_r8 - else - tmpvecaa(1) = 0.3_r8 - end if - tmpvecaa(2) = 1.0_r8 - tmpvecaa(1) - - do k = kts, ktebnd - do jcls = 1, ncls_use - tmpa = sum( mfbnd_use(k,1:2,jcls) ) - mfbnd_use(k,1:2,jcls) = tmpa*tmpvecaa(1:2) - - tmpa = sum( abnd_tavg_use(k,1:2,jcls) ) - abnd_tavg_use(k,1:2,jcls) = tmpa*tmpvecaa(1:2) - - if (k > ktecen) cycle - - tmpa = sum( acen_tavg_use(k,1:2,jcls) ) - acen_tavg_use(k,1:2,jcls) = tmpa*tmpvecaa(1:2) - - tmpa = sum( acen_tfin_use(k,1:2,jcls) ) - acen_tfin_use(k,1:2,jcls) = tmpa*tmpvecaa(1:2) - end do ! jcls - end do ! k - end if ! ((iflag_ecpp_test_fixed_fcloud >= 2) .and. (iflag_ecpp_test_fixed_fcloud <= 5)) - - -! check that fractional areas sum to 1.0 (within small tolerance) -! then normalize to exactly 1.0 -! also check and total quiescent areas are each >= a_quiescn_minaa - do k = kts, ktebnd - do jcls = 1, ncls_use - abnd_tavg_use(k,0,jcls) = sum( abnd_tavg_use(k,1:2,jcls) ) - if (k > ktecen) cycle - acen_tavg_use(k,0,jcls) = sum( acen_tavg_use(k,1:2,jcls) ) - acen_tfin_use(k,0,jcls) = sum( acen_tfin_use(k,1:2,jcls) ) - end do - do icc = 0, 2 - abnd_tavg_use(k,icc,0) = sum( abnd_tavg_use(k,icc,1:ncls_use) ) - if (k > ktecen) cycle - acen_tavg_use(k,icc,0) = sum( acen_tavg_use(k,icc,1:ncls_use) ) - acen_tfin_use(k,icc,0) = sum( acen_tfin_use(k,icc,1:ncls_use) ) - end do - - do i = 1, 3 - if ((i >= 2) .and. (k > ktecen)) cycle - if (i == 1) then - tmpa = abnd_tavg_use(k,0,0) - else if (i == 2) then - tmpa = acen_tavg_use(k,0,0) - else - tmpa = acen_tfin_use(k,0,0) - end if - if (abs(tmpa-1.0_r8) < a_sum_toleraa) cycle - write(msg,'(2a,i5,1pe15.7)') & - '*** parampollu_check_adjust_inputs - bad ', & - area_name10(i), k, tmpa - call ecpp_message( lunout, msg ) - call ecpp_error_fatal( lunout, msg ) - end do - - tmpa = abnd_tavg_use(k,0,0) - abnd_tavg_use(k,0:2,0:ncls_use) = abnd_tavg_use(k,0:2,0:ncls_use)/tmpa - if (k <= ktecen) then - tmpa = acen_tavg_use(k,0,0) - acen_tavg_use(k,0:2,0:ncls_use) = acen_tavg_use(k,0:2,0:ncls_use)/tmpa - tmpa = acen_tfin_use(k,0,0) - acen_tfin_use(k,0:2,0:ncls_use) = acen_tfin_use(k,0:2,0:ncls_use)/tmpa - end if - - do i = 1, 3 - if ((i >= 2) .and. (k > ktecen)) cycle - jcls = jcls_qu - if (i == 1) then - tmpa = abnd_tavg_use(k,0,jcls) - else if (i == 2) then - tmpa = acen_tavg_use(k,0,jcls) - else - tmpa = acen_tfin_use(k,0,jcls) - end if - msg = ' ' - if (tmpa < a_quiescn_minaa) then - write(msg,'(2a,i5,1p,2e10.2)') & - '*** parampollu_check_adjust_inputs - a_quiescent(v1) too small ', & - area_name10(i), k, tmpa, a_quiescn_minaa - call ecpp_message( lunout, msg ) - call ecpp_error_fatal( lunout, msg ) - end if - end do - - end do - - -! eliminate cloudy subareas when k >= k_max_clouds - do k = kts, ktebnd - if (k < k_max_clouds) cycle - mfbnd_use( k,1,0:ncls_use) = mfbnd_use( k,1,0:ncls_use) & - + mfbnd_use( k,2,0:ncls_use) - mfbnd_use( k,2,0:ncls_use) = 0.0_r8 - abnd_tavg_use(k,1,0:ncls_use) = abnd_tavg_use(k,1,0:ncls_use) & - + abnd_tavg_use(k,2,0:ncls_use) - abnd_tavg_use(k,2,0:ncls_use) = 0.0_r8 - if (k > ktecen) cycle - acen_tavg_use(k,1,0:ncls_use) = acen_tavg_use(k,1,0:ncls_use) & - + acen_tavg_use(k,2,0:ncls_use) - acen_tavg_use(k,2,0:ncls_use) = 0.0_r8 - acen_tfin_use(k,1,0:ncls_use) = acen_tfin_use(k,1,0:ncls_use) & - + acen_tfin_use(k,2,0:ncls_use) - acen_tfin_use(k,2,0:ncls_use) = 0.0_r8 - end do - - -! at k = kts and k >= k_max_wnonzero -! set mfbnd and wbnd_bar = 0 -! set areas = 0 for drafts (at kts set abnd=0 but allow acen>0) - do k = kts, ktebnd - if ((k > kts) .and. (k < k_max_wnonzero)) cycle - - mfbnd_use(k,:,:) = 0.0_r8 - wbnd_bar_use(k) = 0.0_r8 - - do jcls = 1, ncls_use - if (jcls == jcls_qu) then - abnd_tavg_use(k,0:2,jcls) = abnd_tavg_use(k,0:2,0) - if ((k == kts) .or. (k > ktecen)) cycle - acen_tavg_use(k,0:2,jcls) = acen_tavg_use(k,0:2,0) - acen_tfin_use(k,0:2,jcls) = acen_tfin_use(k,0:2,0) - else - abnd_tavg_use(k,0:2,jcls) = 0.0_r8 - if ((k == kts) .or. (k > ktecen)) cycle - acen_tavg_use(k,0:2,jcls) = 0.0_r8 - acen_tfin_use(k,0:2,jcls) = 0.0_r8 - end if - end do - end do - - -! at k >= k_max_updndraft -! set mfbnd = 0 and areas = 0 for drafts -! set mfbnd = abnd*wbnd_bar*rhobnd_bar for quiescents - do k = kts, ktebnd - if ((k < k_max_updndraft) .or. (k >= k_max_wnonzero)) cycle - - do jcls = 1, ncls_use - if (jcls == jcls_qu) then - abnd_tavg_use(k,0:2,jcls) = abnd_tavg_use(k,0:2,0) - mfbnd_use(k,1:2,jcls) = & - abnd_tavg_use(k,1:2,jcls)*wbnd_bar_use(k)*rhobnd_bar(k) - if (k > ktecen) cycle - acen_tavg_use(k,0:2,jcls) = acen_tavg_use(k,0:2,0) - acen_tfin_use(k,0:2,jcls) = acen_tfin_use(k,0:2,0) - else - abnd_tavg_use(k,0:2,jcls) = 0.0_r8 - mfbnd_use(k,0:2,jcls) = 0.0_r8 - if (k > ktecen) cycle - acen_tavg_use(k,0:2,jcls) = 0.0_r8 - acen_tfin_use(k,0:2,jcls) = 0.0_r8 - end if - end do - end do - - - if ((ktau==4) .and. (lun155 > 0)) then - write(lun155,'(/a,3i5)') 'bbb', ktau, ipass_check_adjust_inputs - write(lun155,'(3(i5,i3,1pe16.8))') ((jcls,icc,acen_tavg_use(26,icc,jcls),icc=0,2),jcls=0,3) - end if -! -! check updraft/dndraft -! - do 3590 jcls = 1, ncls_use - if (jcls == jcls_qu) goto 3590 - - do 3490 icc = 1, 2 - jclsicc = jcls*10 + icc - -! check kts <= kdraft_bot <= ktecen -! and kdraft_bot < kdraft_top <= ktecen - if ( (kdraft_bot_use(icc,jcls) < kts) .or. & - (kdraft_bot_use(icc,jcls) > ktecen) .or. & - (kdraft_top_use(icc,jcls) <= kdraft_bot_use(icc,jcls)) .or. & - (kdraft_top_use(icc,jcls) > ktecen) ) then - msg = '*** parampollu_check_adjust_inputs - ' // & - 'bad up/dndraft kdraft_bot/_top' - call ecpp_message( lunout, msg ) - write( msg, '(a,4(1x,i5))' ) 'it, jt, jclsicc, mtype_updnenv =', & - it, jt, jclsicc, icc, mtype_updnenv_use(icc,jcls) - call ecpp_message( lunout, msg ) - write( msg, '(a,2(1x,i5),2(1x,i10))' ) & - 'kts, ktebnd, kdraft_bot, kdraft_top =', & - kts, ktebnd, kdraft_bot_use(icc,jcls), kdraft_top_use(icc,jcls) - call ecpp_message( lunout, msg ) - call ecpp_error_fatal( lunout, msg ) - end if - -! check/adjust mbfnd_use and abnd_tavg_use -! if either is below the cut-off value, set both to zero -! also set both to zero outside of [kdraft_bot_use, kdraft_top_use] -! set the kdraft_bot/top_use -! -! note that kdraft_bot/top define bottom/top for layer centers -! for layer boundaries, the up/dndraft mfbnd and abnd are zero -! at the bottom of kdraft_bot and at the top of kdraft_top -! - ktmpa = -999888777 ; ktmpb = -999888778 - do k = kts, ktebnd - arw_draft_cut = aw_draft_cut*rhobnd_bar(k) - - tmp_mfa = mfbnd_use(k,icc,jcls) - tmp_mfb = tmp_mfa - tmpa = abnd_tavg_use(k,icc,jcls) - tmpb = tmpa - - if ( (k <= kdraft_bot_use(icc,jcls)) .or. & - (k > kdraft_top_use(icc,jcls)) .or. & - (k == kts) ) then - tmp_mfb = 0.0_r8 - else - if (mtype_updnenv_use(icc,jcls) == mtype_updraft_ecpp) then - if ( tmp_mfa < arw_draft_cut) tmp_mfb = 0.0_r8 - else - if (-tmp_mfa < arw_draft_cut) tmp_mfb = 0.0_r8 - end if - if (abnd_tavg_use(k,icc,jcls) < afrac_cut) tmp_mfb = 0.0_r8 - end if - - if (tmp_mfb /= 0.0_r8) then - tmpb = max( tmpb, afrac_cut ) - else - tmpb = 0.0_r8 - end if - - mfbnd_use(k,icc,jcls) = tmp_mfb - abnd_tavg_use(k,icc,jcls) = tmpb - if (tmp_mfb /= 0.0_r8) then - if (ktmpa <= 0) ktmpa = k-1 - ktmpb = k - end if - -! set change counts -! increment/decrement abnd of quiescent class if up/dndraft abnd has changed - if (tmp_mfb /= tmp_mfa) then - nchanges(1) = nchanges(1) + 1 - end if - if (tmpb /= tmpa) then - nchanges(2) = nchanges(2) + 1 - abnd_tavg_use(k,icc,jcls_qu) = abnd_tavg_use(k,icc,jcls_qu) & - + (tmpa-tmpb) - end if - - end do - - kdraft_bot_use(icc,jcls) = ktmpa - kdraft_top_use(icc,jcls) = ktmpb - -! check/adjust acen_tavg_use -! set acen_tavg to zero outside of kdraft_bot:kdraft_top -! set acen_tavg to zero if abnd_tavg=0 at both layer boundaries (14-apr-2009) - do k = kts, ktecen - tmpa = acen_tavg_use(k,icc,jcls) - tmpb = tmpa - - if ( (k < kdraft_bot_use(icc,jcls)) .or. & - (k > kdraft_top_use(icc,jcls)) ) then - tmpb = 0.0_r8 - else - tmpe = 0.5_r8*( abnd_tavg_use(k, icc,jcls) + & - abnd_tavg_use(k+1,icc,jcls) ) - if (tmpe > 0.0_r8) then - tmpb = max( afrac_cut, tmpe ) - else - tmpb = 0.0_r8 - end if - end if - - if (tmpb /= tmpa) then - nchanges(3) = nchanges(3) + 1 - acen_tavg_use(k,icc,jcls_qu) = & - acen_tavg_use(k,icc,jcls_qu) + (tmpa-tmpb) - end if - - acen_tavg_use(k,icc,jcls) = tmpb - end do - -! check/adjust acen_tfin_use -! set acen_tfin to zero if it is < afrac_cut or if k >= k_max_updndraft -! set acen_tfin to zero if acen_tavg=0 (14-apr-2009) -! for case of parampollu_opt == 2220, but iflag_ecpp_test_fixed_fcloud /= 2,3,4,5 -! do not allow acen_tfin=0 if acen_tavg>0 -! (14-apr-2009 -- do similar for all parampollu_opt) - ispecial_check_acen_tfin = 0 - if (parampollu_opt == 2220) then - ispecial_check_acen_tfin = 1 - if ((iflag_ecpp_test_fixed_fcloud >= 2) .and. & - (iflag_ecpp_test_fixed_fcloud <= 5)) ispecial_check_acen_tfin = 0 - end if - if (ispecial_check_acen_tfin <= 0) then - ispecial_check_acen_tfin = 2 - if ((iflag_ecpp_test_fixed_fcloud >= 2) .and. & - (iflag_ecpp_test_fixed_fcloud <= 5)) ispecial_check_acen_tfin = 0 - end if - - do k = kts, ktecen - tmpa = acen_tfin_use(k,icc,jcls) - tmpb = tmpa - - if ((tmpa < afrac_cut) .or. & - (k >= k_max_updndraft)) then - tmpb = 0.0_r8 - end if - if (acen_tavg_use(k,icc,jcls) <= 0.0_r8) then - tmpb = 0.0_r8 - end if - - if (ispecial_check_acen_tfin > 0) then - if (tmpb < afrac_cut) then - if (acen_tavg_use(k,icc,jcls) >= afrac_cut) then - if (ispecial_check_acen_tfin == 2) then - tmpb = max( 0.5_r8*acen_tavg_use(k,icc,jcls), afrac_cut ) - else - tmpb = acen_tavg_use(k,icc,jcls) - end if - end if - end if - end if - - if (tmpb /= tmpa) then - nchanges(4) = nchanges(4) + 1 - acen_tfin_use(k,icc,jcls_qu) = & - acen_tfin_use(k,icc,jcls_qu) + (tmpa-tmpb) - end if - - acen_tfin_use(k,icc,jcls) = tmpb - end do - -! for empty sub-class (mfbnd/abnd/acen=0 at all levels), -! set kdraft_bot/top_use to ktecen - if ((kdraft_bot_use(icc,jcls) < -999888000) .and. & - (kdraft_top_use(icc,jcls) < -999888000)) then - kdraft_bot_use(icc,jcls) = ktecen - kdraft_top_use(icc,jcls) = ktecen - end if - -3490 continue - -! sum clear and cloudy mfbnd_use - do k = kts, ktebnd - mfbnd_use(k,0,jcls) = sum( mfbnd_use(k,1:2,jcls) ) - end do - -3590 continue - - -! -! check/adjust quiescent transport-class -! - - if ((ktau==4) .and. (lun155 > 0)) then - write(lun155,'(/a,3i5)') 'ccc', ktau, ipass_check_adjust_inputs - write(lun155,'(3(i5,i3,1pe16.8))') ((jcls,icc,acen_tavg_use(26,icc,jcls),icc=0,2),jcls=0,3) - end if -! first set to zero any areas that are < afrac_cut - do k = kts, ktebnd - do i = 1, 3 - jcls = jcls_qu - if ((i >= 2) .and. (k > ktecen)) cycle - - if (i == 1) then - tmpvecaa(0:2) = abnd_tavg_use(k,0:2,jcls) - else if (i == 2) then - tmpvecaa(0:2) = acen_tavg_use(k,0:2,jcls) - else - tmpvecaa(0:2) = acen_tfin_use(k,0:2,jcls) - end if - - tmpvecbb(0:2) = tmpvecaa(0:2) - tmpvecbb(0) = tmpvecbb(1) + tmpvecbb(2) - do icc = 1, 2 - if (tmpvecbb(icc) < afrac_cut) then - tmpvecbb(3-icc) = tmpvecbb(0) - tmpvecbb(icc) = 0.0_r8 - end if - end do - -! for case of parampollu_opt == 2220, but iflag_ecpp_test_fixed_fcloud /= 2,3,4,5 -! do not allow acen_tfin=0 if acen_tavg>0 - if ((i == 3) .and. (ispecial_check_acen_tfin > 0)) then - do icc = 1, 2 - if (tmpvecbb(icc) < afrac_cut) then - if (acen_tavg_use(k,icc,jcls) >= afrac_cut) then - tmpvecbb(icc) = acen_tavg_use(k,icc,jcls) - tmpvecbb(3-icc) = tmpvecbb(0) - tmpvecbb(icc) - end if - end if - end do - end if - - if ((tmpvecbb(1) < 0.0_r8) .or. & - (tmpvecbb(2) < 0.0_r8) .or. & - (tmpvecbb(0) < a_quiescn_minbb)) then -! at this point, the total (adjusted) quiescent area is too small - write(msg,'(a,1p,3e12.4)') & - ' tmpvecaa(0:2) = v1 quiescent areas =', tmpvecaa(0:2) - call ecpp_message( lunout, msg ) - write(msg,'(a,1p,3e12.4)') & - ' tmpvecbb(0:2) = v2 quiescent areas =', tmpvecbb(0:2) - call ecpp_message( lunout, msg ) - - write(msg,'(2a,2i5)') & - '*** parampollu_check_adjust_inputs - a_quiescent(v2) too small ', & - area_name10(i), k, i - call ecpp_message( lunout, msg ) - call ecpp_error_fatal( lunout, msg ) - end if - - if (i == 1) then - abnd_tavg_use(k,0:2,jcls) = tmpvecbb(0:2) - else if (i == 2) then - acen_tavg_use(k,0:2,jcls) = tmpvecbb(0:2) - else - acen_tfin_use(k,0:2,jcls) = tmpvecbb(0:2) - end if - end do ! i = 1, 3 - end do ! k = kts, ktebnd - - -! recalc summed area fractions - do k = kts, ktebnd - do jcls = 1, ncls_use - abnd_tavg_use(k,0,jcls) = sum( abnd_tavg_use(k,1:2,jcls) ) - if (k > ktecen) cycle - acen_tavg_use(k,0,jcls) = sum( acen_tavg_use(k,1:2,jcls) ) - acen_tfin_use(k,0,jcls) = sum( acen_tfin_use(k,1:2,jcls) ) - end do - do icc = 0, 2 - abnd_tavg_use(k,icc,0) = sum( abnd_tavg_use(k,icc,1:ncls_use) ) - if (k > ktecen) cycle - acen_tavg_use(k,icc,0) = sum( acen_tavg_use(k,icc,1:ncls_use) ) - acen_tfin_use(k,icc,0) = sum( acen_tfin_use(k,icc,1:ncls_use) ) - end do - end do ! k = kts, ktebnd - - -! calc kdraft_bot_use & kdraft_top_use - jcls = jcls_qu - do icc = 1, 2 - ktmpa = -999888777 ; ktmpb = -999888778 - do k = kts, ktecen - if (acen_tavg_use(k,icc,jcls) > 0.0_r8) then - if (ktmpa <= 0) ktmpa = k - ktmpb = k - end if - end do - kdraft_bot_use(icc,jcls) = ktmpa - kdraft_top_use(icc,jcls) = ktmpb - end do - -! normally allow cloudy quiescent to be empty -! if iflag_ecpp_test_fixed_fcloud=3 (special testing), allow clear quiescent to be empty - icc = 2 - if (iflag_ecpp_test_fixed_fcloud == 3) icc = 1 - if ((kdraft_bot_use(icc,jcls) < -999888000) .and. & - (kdraft_top_use(icc,jcls) < -999888000)) then - kdraft_bot_use(icc,jcls) = ktecen - kdraft_top_use(icc,jcls) = ktecen - end if - -! check for validity of kdraft_bot_use & kdraft_top_use - ka = min( kdraft_bot_use(1,jcls), kdraft_bot_use(2,jcls) ) - kb = max( kdraft_top_use(1,jcls), kdraft_top_use(2,jcls) ) - do icc = 1, 2 - if ( (kdraft_bot_use(icc,jcls) < kts) .or. & - (kdraft_bot_use(icc,jcls) > ktecen) .or. & - (kdraft_bot_use(icc,jcls) > kdraft_top_use(icc,jcls)) .or. & - (kdraft_top_use(icc,jcls) > ktecen) .or. & - (ka /= kts) .or. & - (kb /= ktecen) ) then - jclsicc = jcls*10 + icc - msg = '*** parampollu_check_adjust_inputs - ' // & - 'bad quiescent transport-class kdraft_bot/top_use' - call ecpp_message( lunout, msg ) - write( msg, '(a,4(1x,i5))' ) 'it, jt, jclsicc, mtype_updnenv =', & - it, jt, jclsicc, mtype_updnenv_use(icc,jcls) - call ecpp_message( lunout, msg ) - write( msg, '(a,2(1x,i5),2(1x,i10))' ) & - 'kts, ktebnd, kdraft_bot, kdraft_top =', & - kts, ktebnd, kdraft_bot_use(icc,jcls), kdraft_top_use(icc,jcls) - call ecpp_message( lunout, msg ) - call ecpp_error_fatal( lunout, msg ) - end if - end do - - -!----------------------------------------------------- -! here ipass_check_adjust_inputs == 1 -! skip over the special stuff for ipass_check_adjust_inputs == 2 -!----------------------------------------------------- - if ((ktau==4) .and. (lun155 > 0)) then - write(lun155,'(/a,3i5)') 'ddd', ktau, ipass_check_adjust_inputs - write(lun155,'(3(i5,i3,1pe16.8))') ((jcls,icc,acen_tavg_use(26,icc,jcls),icc=0,2),jcls=0,3) - end if - goto 30000 - - -!----------------------------------------------------- -! special stuff for ipass_check_adjust_inputs == 2 -!----------------------------------------------------- -20000 continue - ipass_2_changes = 0 - - -! for testing only -- reduce up/dndraft areas -! *** NOTE / TODO - in the "new" code, this may not work correctly - ido_updndr_area_adjust = 0 - if (ido_updndr_area_adjust > 0) then - ipass_2_changes = ipass_2_changes + 1 - - updndr_area_adjust = 1.0_r8 - tmpb = 1.0_r8 - updndr_area_adjust - do k = kts, ktebnd - do icc = 0, 2 - do jcls = 1, ncls_use - if (jcls == jcls_qu) cycle - - abnd_tavg_use(k,icc,jcls_qu) = abnd_tavg_use(k,icc,jcls_qu) & - + abnd_tavg_use(k,icc,jcls )*tmpb - abnd_tavg_use(k,icc,jcls ) = abnd_tavg_use(k,icc,jcls )*updndr_area_adjust - - if (k > ktecen) cycle - - acen_tavg_use(k,icc,jcls_qu) = acen_tavg_use(k,icc,jcls_qu) & - + acen_tavg_use(k,icc,jcls )*tmpb - acen_tavg_use(k,icc,jcls ) = acen_tavg_use(k,icc,jcls )*updndr_area_adjust - - acen_tfin_use(k,icc,jcls_qu) = acen_tfin_use(k,icc,jcls_qu) & - + acen_tfin_use(k,icc,jcls )*tmpb - acen_tfin_use(k,icc,jcls ) = acen_tfin_use(k,icc,jcls )*updndr_area_adjust - - end do - end do - end do - end if ! (ido_updndr_area_adjust > 0) - - -! for testing only -- zero out downdraft -! *** NOTE / TODO - in the "new" code, this may not work correctly - ido_downdr_area_zeroout = 0 - if (ido_downdr_area_zeroout > 0) then - ipass_2_changes = ipass_2_changes + 1 - - do k = kts, ktebnd - do icc = 0, 2 - do jcls = 1, ncls_use - if (jcls == jcls_qu) cycle - if (mtype_updnenv_use(icc,jcls) /= mtype_dndraft_ecpp) cycle - - abnd_tavg_use(k,icc,jcls_qu) = abnd_tavg_use(k,icc,jcls_qu) & - + abnd_tavg_use(k,icc,jcls ) - abnd_tavg_use(k,icc,jcls ) = 0.0_r8 - - mfbnd_use( k,icc,jcls_qu) = mfbnd_use( k,icc,jcls_qu) & - + mfbnd_use( k,icc,jcls ) - mfbnd_use( k,icc,jcls ) = 0.0_r8 - - if (k > ktecen) cycle - - acen_tavg_use(k,icc,jcls_qu) = acen_tavg_use(k,icc,jcls_qu) & - + acen_tavg_use(k,icc,jcls ) - acen_tavg_use(k,icc,jcls ) = 0.0_r8 - - acen_tfin_use(k,icc,jcls_qu) = acen_tfin_use(k,icc,jcls_qu) & - + acen_tfin_use(k,icc,jcls ) - acen_tfin_use(k,icc,jcls ) = 0.0_r8 - end do - end do - end do - end if ! (ido_downdr_area_zeroout > 0) - - -! if (ipass_2_changes == 0) return - - -!----------------------------------------------------- -! common stuff for ipass_check_adjust_inputs == 1,2 -!----------------------------------------------------- -30000 continue -! -! check/adjust quiescent abnd_tavg_use (and mfbnd_use) -! -! before 15-jul-2008 code -! code above may have set afrac_bnd=0 in some transport-class -! now adjust afrac_bnd in quiescent transport-class so that -! all-transport-class-sum = 1.0 -! -! on/after 15-jul-2008 code -! the post-processor does not correctly identify the clear versus -! cloudy parts of the quiescent abnd_tavg -! (it calcs an average qcloud for 2 layers adjacent to the boundary, -! and if qcloud in either layer exceeds cutoff, then the average -! will too (almost always), so this is biased) -! so instead, set these based on the clear/cloud quiescent acen_tavg_use -! also, apportion the quiescent mfbnd_use similarly -! - mfbnd_quiescn_up(:,:,:) = 0.0_r8 - mfbnd_quiescn_dn(:,:,:) = 0.0_r8 - - jcls = jcls_qu - do k = kts, ktecen -! first calc tmpvecdd(k) = fraction of layer-k quiescent-class that is clear - ardz_cut = afrac_cut*rhodz_cen(k)*0.3_r8 - if ((acen_tavg_use(k,1,jcls) >= ardz_cut) .and. & - (acen_tavg_use(k,2,jcls) >= ardz_cut)) then - ! clear and cloudy both > 0 - tmpvecdd(k) = acen_tavg_use(k,1,jcls)/acen_tavg_use(k,0,jcls) - tmpvecdd(k) = max( 0.0_r8, min( 1.0_r8, tmpvecdd(k) ) ) - else if (acen_tavg_use(k,2,jcls) >= ardz_cut) then - ! only cloudy > 0 - tmpvecdd(k) = 0.0_r8 - else - ! only clear > 0 - tmpvecdd(k) = 1.0_r8 - end if - end do - - - do k = kts+1, ktecen -! calc (total quiescent "w-prime" mass flux) = - (sum of up/dndraft mass fluxes) - tmp_mfa = 0.0_r8 - do jcls = 1, ncls_use - if (jcls == jcls_qu) cycle - mfbnd_use(k,0,jcls) = sum( mfbnd_use(k,1:2,jcls) ) - tmp_mfa = tmp_mfa + mfbnd_use(k,0,jcls) - end do - jcls = jcls_qu - mfbnd_use(k,0,jcls) = -tmp_mfa - -! partition total quiescent mass flux to clear/cloudy using the -! quiescent clear/cloud amounts in the "upwind" layer - if (mfbnd_use(k,0,jcls) < 0.0_r8) then - tmpvecaa(1) = tmpvecdd(k) ! upwind is layer above - tmpvecbb(1) = tmpvecdd(k-1) ! downwind is layer below - else - tmpvecaa(1) = tmpvecdd(k-1) ! upwind is layer below - tmpvecbb(1) = tmpvecdd(k) ! downwind is layer above - end if - tmpvecaa(2) = 1.0_r8 - tmpvecaa(1) - tmpvecbb(2) = 1.0_r8 - tmpvecbb(1) - - mfbnd_use(k,1:2,jcls) = mfbnd_use(k,0,jcls)*tmpvecaa(1:2) -! same for abnd - abnd_tavg_use(k,1:2,jcls) = abnd_tavg_use(k,0,jcls)*tmpvecaa(1:2) - -! do other sums - do icc = 0, 2 - mfbnd_use( k,icc,0) = sum( mfbnd_use( k,icc,1:ncls_use) ) - abnd_tavg_use(k,icc,0) = sum( abnd_tavg_use(k,icc,1:ncls_use) ) - end do - - -! now calculate more detailed up and down fluxes -! mfbnd_quiescn_up(k,jccfrom,jcctooo) is mbbnd from (k,jccfrom) to (k+1,jcctooo) -! with jccfrom=0/1/2=both/clear/cloudy; and jcctooo=0/1/2=similar -! -! the clear-->both and cloudy-->both are already determined -! the clear-->clear and cloudy-->cloudy are calculated maximum overlap -! of cloudy and clear regions -! the clear-->cloudy and cloudy-->clear are simply what is left -! -! tmpvecaa holds clear/cloudy fractions of the upwind layer -! tmpvecbb holds clear/cloudy fractions of the downwind layer - jcls = jcls_qu - tmp0202aa(0:2,0) = mfbnd_use(k,0:2,jcls) - tmp0202aa(0:2,1:2) = 0.0_r8 - do ja = 1, 2 - jb = 3-ja - tmpa = 0.0_r8 - if (tmpvecaa(ja) > 0.0_r8) & - tmpa = min(tmpvecbb(ja),tmpvecaa(ja))/tmpvecaa(ja) - tmpa = max( 0.0_r8, min( 1.0_r8, tmpa ) ) - tmp0202aa(ja,ja) = tmp0202aa(ja,0)*tmpa - tmp0202aa(ja,jb) = tmp0202aa(ja,0)*(1.0_r8-tmpa) - end do - do jb = 1, 2 - tmp0202aa(0,jb) = sum( tmp0202aa(1:2,jb) ) - end do - if (mfbnd_use(k,0,jcls) < 0.0_r8) then - mfbnd_quiescn_dn(k,0:2,0:2) = tmp0202aa(0:2,0:2) - else if (mfbnd_use(k,0,jcls) > 0.0_r8) then - mfbnd_quiescn_up(k,0:2,0:2) = tmp0202aa(0:2,0:2) - end if - -! if ((ipass_check_adjust_inputs == 2) .and. (lun141 > 0)) then -! if (k == kts+1) write( 141, '(/a,2i5)' ) & -! 'mfbnd_quiescn at ktau, ipass =', ktau, ipass_check_adjust_inputs -! write( 141, '(i3,1p,2e11.3,2(2x,4e11.3))' ) k, mfbnd_use(k,1:2,jcls), & -! mfbnd_quiescn_up(k,1:2,1:2), mfbnd_quiescn_dn(k,1:2,1:2) -! end if - - end do ! k = kts+1, ktecen - - -! for "empty" drafts, reset the kbot & ktop, and also the mtype_updnenv_use -! -! *** currently the reset of mtype_updnenv_use is deactivated - kdraft_bot_tmp(:,:) = kdraft_bot_use(:,:) - kdraft_top_tmp(:,:) = kdraft_top_use(:,:) - mtype_updnenv_tmp(:,:) = mtype_updnenv_use(:,:) - if (lun63 > 0) write(lun63,'(a/2a)') & - 'parampollu_check_adjust_inputs transport-class summary', & - ' jcls mcc, mf/af nonzero, mtype_tmp/use, ', & - 'kbase/top_inp, kbase/top_tmp, kbase/top_use' - do jcls = 1, ncls_use - do icc = 1, 2 - itmpa = 0 - itmpb = 0 - do k = kts, ktebnd - if (mfbnd_use(k,icc,jcls) /= 0.0_r8) itmpa = itmpa + 1 - if (abnd_tavg_use(k,icc,jcls) /= 0.0_r8) itmpb = itmpb + 1 - end do - if (itmpa+itmpb <= 0) then - kdraft_bot_use(icc,jcls) = ktecen - kdraft_top_use(icc,jcls) = ktecen -! if (mtype_updnenv_use(icc,jcls) == mtype_updraft_ecpp) then -! mtype_updnenv_use(icc,jcls) = mtype_upempty_ecpp -! else if (mtype_updnenv_use(icc,jcls) == mtype_dndraft_ecpp) then -! mtype_updnenv_use(icc,jcls) = mtype_dnempty_ecpp -! else -! mtype_updnenv_use(icc,jcls) = mtype_quempty_ecpp -! end if - end if - if (lun63 > 0) write(lun63,'(2i5,5(5x,2i5))') & - jcls, icc, itmpa, itmpb, & - mtype_updnenv_tmp(icc,jcls), mtype_updnenv_use(icc,jcls), & - kdraft_bot_ecpp(icc,jcls), kdraft_top_ecpp(icc,jcls), & - kdraft_bot_tmp(icc,jcls), kdraft_top_tmp(icc,jcls), & - kdraft_bot_use(icc,jcls), kdraft_top_use(icc,jcls) - end do - end do - - -! now adjust area with precipitation - acen_prec_use(:,:,:) = 0.0_r8 - do jcls = 1, ncls_use - do icc = 1, 2 - do k = kts, ktecen - if (acen_tavg_use(k,icc,jcls) < afrac_cut) cycle - if (acen_prec_ecpp(k,icc,jcls) < afrac_cut) cycle - - tmpa = acen_prec_ecpp(k,icc,jcls) ! portion of sub-area with precip - tmpb = acen_tavg_use(k,icc,jcls) - tmpa ! portion of sub-area without precip - if (tmpb < afrac_cut) tmpa = acen_tavg_use(k,icc,jcls) - acen_prec_use(k,icc,jcls) = tmpa - end do - end do - end do - - -! final recalc summed area fractions - do k = kts, ktebnd - do jcls = 1, ncls_use - abnd_tavg_use(k,0,jcls) = sum( abnd_tavg_use(k,1:2,jcls) ) - if (k > ktecen) cycle - acen_tavg_use(k,0,jcls) = sum( acen_tavg_use(k,1:2,jcls) ) - acen_tfin_use(k,0,jcls) = sum( acen_tfin_use(k,1:2,jcls) ) - acen_prec_use(k,0,jcls) = sum( acen_prec_use(k,1:2,jcls) ) - end do - do icc = 0, 2 - abnd_tavg_use(k,icc,0) = sum( abnd_tavg_use(k,icc,1:ncls_use) ) - if (k > ktecen) cycle - acen_tavg_use(k,icc,0) = sum( acen_tavg_use(k,icc,1:ncls_use) ) - acen_tfin_use(k,icc,0) = sum( acen_tfin_use(k,icc,1:ncls_use) ) - acen_prec_use(k,icc,0) = sum( acen_prec_use(k,icc,1:ncls_use) ) - end do - end do - - - if (lun63 > 0) then - write(lun63,'(a,i2)') 'parampollu_check_adjust_inputs -- ipass =', & - ipass_check_adjust_inputs - do k = 1, 10 - write(lun63,'(a,i2,a,i10)') ' nchanges(', k, ') =', nchanges(k) - end do - end if ! (lun63 > 0) - - - if ((ktau==4) .and. (lun155 > 0)) then - write(lun155,'(/a,3i5)') 'eee', ktau, ipass_check_adjust_inputs - write(lun155,'(3(i5,i3,1pe16.8))') ((jcls,icc,acen_tavg_use(26,icc,jcls),icc=0,2),jcls=0,3) - end if - - return - end subroutine parampollu_check_adjust_inputs - - - -!----------------------------------------------------------------------- - subroutine parampollu_1clm_dumpaa( & - ktau, dtstep, ktau_pp, dtstep_pp, & - tcen_bar, pcen_bar, rhocen_bar, dzcen, & - rhobnd_bar, zbnd, wbnd_bar, & - chem_bar, & - ncls_ecpp, & - kdraft_bot_ecpp, kdraft_top_ecpp, & - mtype_updnenv_ecpp, & - mfbnd, abnd_tavg, & - acen_tavg, acen_tbeg, acen_tfin, & - it, jt, kts,ktebnd,ktecen, & - lun ) - -!----------------------------------------------------------------------- -! DESCRIPTION -! -! parampollu_1clm_dumpaa does a diagnostic print of -! numerous ecpp arrays -! -!----------------------------------------------------------------------- - - use module_data_ecpp1 - - use module_ecpp_util, only: ecpp_error_fatal, ecpp_message - -! arguments - integer, intent(in) :: & - ktau, ktau_pp, & - it, jt, kts, ktebnd, ktecen, & - lun -! ktau - time step number -! ktau_pp - time step number for "parameterized pollutants" calculations - -! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for "tile" -! chem_driver and routines under it do calculations -! over these spatial indices. - - real(r8), intent(in) :: dtstep, dtstep_pp -! dtstep - main model time step (s) -! dtstep_pp - time step (s) for "parameterized pollutants" calculations - - real(r8), intent(in), dimension( kts:ktecen ) :: & - tcen_bar, pcen_bar, rhocen_bar, dzcen - real(r8), intent(in), dimension( kts:ktebnd ) :: & - rhobnd_bar, zbnd, wbnd_bar - - real(r8), intent(in), dimension( kts:ktecen, 1:num_chem_ecpp ) :: & - chem_bar - - integer, intent(in) :: ncls_ecpp - - integer, intent(in), dimension( 1:2, 1:maxcls_ecpp ) :: & - kdraft_bot_ecpp, kdraft_top_ecpp, & - mtype_updnenv_ecpp - - real(r8), intent(in), dimension( kts:ktebnd, 0:2, 0:maxcls_ecpp ) :: & - mfbnd, abnd_tavg - real(r8), intent(in), dimension( kts:ktecen, 0:2, 0:maxcls_ecpp ) :: & - acen_tavg, acen_tbeg, acen_tfin - - character(len=8), dimension( kts:ktebnd ) :: dumchar8 - - -! local variables - integer :: iclrcld - integer :: itmp_mtype_clrcldy(1:2) - integer :: jcls, jclsaa, jclsbb - integer :: k, l - - real(r8) :: duma - real(r8), dimension( kts:ktebnd ) :: dumarr1, dumarr2, dumarr3, dumarr4, dumarr5 - - -! -! output with same format as ppboxmakeinp01 -! -9400 format( a ) -9410 format( 5i15 ) -9415 format( a, i10 ) -9416 format( a, 5i10 ) -!9420 format( 5(1pe15.7) ) -9420 format( 5(1pe12.4) ) - - if (lun <= 0) return - - - itmp_mtype_clrcldy(1) = mtype_nocloud_ecpp - itmp_mtype_clrcldy(2) = mtype_iscloud_ecpp - -! write(lun,9400) 'output from ppboxmakeinp01' - write(lun,9400) - write(lun,9400) - write(lun,9416) 'output from ppboxmakeinp01 - ktau, ktau_pp', & - ktau, ktau_pp - - write(lun,9400) 'kts, kte, ncls_ecpp_clm' - write(lun,9410) kts, ktebnd, ncls_ecpp - - write(lun,9410) num_chem_ecpp - - write(lun,9400) 'rho,z,w bnd' - do k = kts, ktebnd - write(lun,9420) rhobnd_bar(k), & - zbnd(k), wbnd_bar(k) - end do - - write(lun,9400) 'p,t,rho cen' - do k = kts, ktecen - write(lun,9420) pcen_bar(k), tcen_bar(k), rhocen_bar(k) - end do - - do l = 1, num_chem_ecpp - write(lun,9415) 'chem ', l - write(lun,9420) (chem_bar(k,l), k=kts,ktecen) - end do - - do jcls = 1, ncls_ecpp - do iclrcld = 1, 2 - write(lun,9416) 'jcls, iclrcld // mtype a,b,c; kdraft a,b', jcls, iclrcld - write(lun,9410) & - mtype_updnenv_ecpp(iclrcld,jcls), & - itmp_mtype_clrcldy(iclrcld), mtype_noprecip_ecpp, & - kdraft_bot_ecpp(iclrcld,jcls), kdraft_top_ecpp(iclrcld,jcls) - - write(lun,9416) 'afrac', jcls, iclrcld - write(lun,9420) (abnd_tavg(k,iclrcld,jcls), k=kts,ktebnd) - - write(lun,9416) 'mf', jcls, iclrcld - write(lun,9420) (mfbnd(k,iclrcld,jcls), k=kts,ktebnd) - end do - end do - - - write(lun,'(/a)') 'baraa' - write(lun,'(a)') ' k z(km) p(mb) rho t(C) w(cm/s)' - do k = ktebnd, kts, -1 - if (k < ktebnd) then - duma = zbnd(k) + 0.5_r8*dzcen(k) - write(lun,'(i2,2x,f8.3,f8.1,f8.4,f8.1, 8x)') & - k, duma*1.0e-3_r8, pcen_bar(k)*1.0e-2_r8, rhocen_bar(k), tcen_bar(k)-273.16_r8 - end if - duma = k-0.5_r8 - write(lun,'( f4.1,f8.3, 8x,f8.4, 8x,f8.2)') & - duma, zbnd(k)*1.0e-3_r8, rhobnd_bar(k), wbnd_bar(k)*1.0e2_r8 - end do - write(lun,'(a)') ' k z(km) p(mb) rho t(C) w(cm/s)' - - write(lun,'(/a)') 'draftaa' - do jcls = 1, ncls_ecpp - do iclrcld = 1, 2 - write(lun,'(/a,7i5)') 'draftbb - ktau_pp, jcls, iclrcld, updn, clrcldy, top, bot =', & - ktau_pp, jcls, iclrcld, & - mtype_updnenv_ecpp(iclrcld,jcls), itmp_mtype_clrcldy(iclrcld), & - kdraft_bot_ecpp(iclrcld,jcls), kdraft_top_ecpp(iclrcld,jcls) - - write(lun,'(a)') 'afrac' - do k = kts, ktebnd - duma = abnd_tavg(k,iclrcld,jcls) - if (duma == 0.0_r8) then - dumchar8(k) = ' 0. ' - else if (abs(duma) >= 5.0e-5_r8) then - write(dumchar8(k),'(f8.4)') duma - else - write(dumchar8(k),'(1p,e8.0)') duma - end if - end do - write(lun,'(15a)') (dumchar8(k), k=kts,ktebnd) - - do k = kts, ktebnd - duma = max( 1.0e-10_r8, abnd_tavg(k,iclrcld,jcls) ) - dumarr1(k) = mfbnd(k,iclrcld,jcls)/(rhobnd_bar(k)*duma) - end do - write(lun,'(a)') 'w' - write(lun,'(15f8.4)') (dumarr1(k), k=kts,ktebnd) - - write(lun,'(a)') 'mfbnd' - write(lun,'(1p,10e12.5)') (mfbnd(k,iclrcld,jcls), k=kts,ktebnd) - - write(lun,'(a)') 'abnd_tavg' - write(lun,'(1p,10e12.5)') (abnd_tavg(k,iclrcld,jcls), k=kts,ktebnd) -! write(lun,'(1p,15e8.1 )') (abnd_tavg(k,iclrcld,jcls), k=kts,ktebnd) - - write(lun,'(a)') 'acen_tavg' - write(lun,'(1p,10e12.5)') (acen_tavg(k,iclrcld,jcls), k=kts,ktecen) - - write(lun,'(a)') 'acen_tbeg' - write(lun,'(1p,10e12.5)') (acen_tbeg(k,iclrcld,jcls), k=kts,ktecen) - - write(lun,'(a)') 'acen_tfin' - write(lun,'(1p,10e12.5)') (acen_tfin(k,iclrcld,jcls), k=kts,ktecen) - - end do - end do - - do k = kts, ktebnd - dumarr1(k) = 0.0_r8 - dumarr2(k) = 0.0_r8 - dumarr3(k) = 0.0_r8 - dumarr4(k) = 0.0_r8 - dumarr5(k) = 0.0_r8 - do jcls = 1, ncls_ecpp - do iclrcld = 1, 2 - dumarr1(k) = dumarr1(k) + mfbnd(k,iclrcld,jcls) - dumarr2(k) = dumarr2(k) + abnd_tavg(k,iclrcld,jcls) - if (k > ktecen) cycle - dumarr3(k) = dumarr3(k) + acen_tavg(k,iclrcld,jcls) - dumarr4(k) = dumarr4(k) + acen_tbeg(k,iclrcld,jcls) - dumarr5(k) = dumarr5(k) + acen_tfin(k,iclrcld,jcls) - end do - end do - duma = max( 1.0e-10_r8, dumarr2(k) ) - dumarr1(k) = dumarr1(k)/(rhobnd_bar(k)*duma) - end do - write(lun,'(/a,4i5)') 'draftbb - ktau_pp, all subs =', & - ktau_pp - write(lun,'(a)') 'wbar' - write(lun,'(12f10.5)') (wbnd_bar(k), k=kts,ktebnd) - write(lun,'(a)') '(mfbnd summed over all subs)/rhobnd' - write(lun,'(12f10.5)') (dumarr1(k), k=kts,ktebnd) - write(lun,'(a)') '(abnd_tavg-1) summed over all subs' - write(lun,'(1p,12e10.2)') ((dumarr2(k)-1.0_r8), k=kts,ktebnd) - write(lun,'(a)') '(acen_tavg-1) summed over all subs' - write(lun,'(1p,12e10.2)') ((dumarr3(k)-1.0_r8), k=kts,ktecen) - write(lun,'(a)') '(acen_tbeg-1) summed over all subs' - write(lun,'(1p,12e10.2)') ((dumarr4(k)-1.0_r8), k=kts,ktecen) - write(lun,'(a)') '(acen_tfin-1) summed over all subs' - write(lun,'(1p,12e10.2)') ((dumarr5(k)-1.0_r8), k=kts,ktecen) - - - do jclsaa = 1, ncls_ecpp, 3 - jclsbb = min( jclsaa+2, ncls_ecpp ) - write(lun,'(/a,3i5)') 'draftcc - ktau_pp, jclsaa, jclsbb', & - ktau_pp, jclsaa, jclsbb - write(lun,'(a)') & - 'k, acen_tavg(k,1:2,jclsaa:jclsbb), mfbnd(k+1,1:2,jclsaa:jclsbb)' - do k = ktecen, kts, -1 - write(lun,'(i3,2x,3(1x,2f8.5),2x,1p,3(1x,2e10.2))') k, & - acen_tavg(k,1:2,jclsaa:jclsbb), & - mfbnd(k,1:2,jclsaa:jclsbb) - end do - end do - - - - return - end subroutine parampollu_1clm_dumpaa - - - -!----------------------------------------------------------------------- - end module module_ecpp_td2clm diff --git a/src/physics/spcam/ecpp/module_ecpp_util.F90 b/src/physics/spcam/ecpp/module_ecpp_util.F90 deleted file mode 100644 index 5318fd75bd..0000000000 --- a/src/physics/spcam/ecpp/module_ecpp_util.F90 +++ /dev/null @@ -1,112 +0,0 @@ -!#********************************************************************************** -! This computer software was prepared by Battelle Memorial Institute, hereinafter -! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of -! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, -! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. -! -! miscellaneous debuging routines for CBMZ and MOSAIC -!********************************************************************************** - module module_ecpp_util - - use cam_abortutils, only: endrun - - contains - -!----------------------------------------------------------------------- - subroutine ecpp_debugmsg( lun, level, str ) -! -! when lun > 0, writes "str" to unit "lun" -! when lun <= 0, passes "str" on to wrf_debug -! - implicit none -! subr arguments - integer, intent(in) :: lun, level - character(len=*), intent(in) :: str -! local variables - integer n - - n = max( 1, len_trim(str) ) - if (lun .ge. 0) then - write(lun,'(a)') str(1:n) - else - call endrun( str(1:n) ) - end if - return - end subroutine ecpp_debugmsg - - -!----------------------------------------------------------------------- - subroutine ecpp_message( lun, str ) -! -! when lun > 0, writes "str" to unit "lun" -! when lun <= 0, passes "str" on to wrf_message -! - implicit none -! subr arguments - integer, intent(in) :: lun - character(len=*), intent(in) :: str -! local variables - integer n - - n = max( 1, len_trim(str) ) - if (lun .ge. 0) then - write(lun,'(a)') str(1:n) - else - call endrun( str(1:n) ) - end if - return - end subroutine ecpp_message - - -!----------------------------------------------------------------------- - subroutine ecpp_error_fatal( lun, str ) -! -! when lun > 0, writes "str" to unit "lun" -! then (always) passes "str" on to wrf_error_fatal -! - implicit none -! subr arguments - integer, intent(in) :: lun - character(len=*), intent(in) :: str -! local variables - integer n - - n = max( 1, len_trim(str) ) - call endrun( str(1:n) ) - return - end subroutine ecpp_error_fatal - - -!----------------------------------------------------------------------- - subroutine parampollu_1clm_set_opts( & - xppopt_updn_prof_aa, & - xppopt_quiescn_mf, xppopt_quiescn_sosi, & - xppopt_chemtend_wq, xppopt_chemtend_dtsub, & - xppopt_chemtend_updnfreq ) - - use module_data_ecpp1 - - implicit none - - -! subr arguments - integer, intent(in) :: & - xppopt_updn_prof_aa, & - xppopt_quiescn_mf, xppopt_quiescn_sosi, & - xppopt_chemtend_wq, xppopt_chemtend_dtsub, & - xppopt_chemtend_updnfreq - - - ppopt_updn_prof_aa = xppopt_updn_prof_aa - ppopt_quiescn_mf = xppopt_quiescn_mf - ppopt_quiescn_sosi = xppopt_quiescn_sosi - ppopt_chemtend_wq = xppopt_chemtend_wq - ppopt_chemtend_dtsub = xppopt_chemtend_dtsub - ppopt_chemtend_updnfreq = xppopt_chemtend_updnfreq - - - return - end subroutine parampollu_1clm_set_opts - -!----------------------------------------------------------------------- - end module module_ecpp_util diff --git a/src/physics/spcam/spcam_drivers.F90 b/src/physics/spcam/spcam_drivers.F90 deleted file mode 100644 index b9f7a596cc..0000000000 --- a/src/physics/spcam/spcam_drivers.F90 +++ /dev/null @@ -1,2396 +0,0 @@ -module spcam_drivers - - -use camsrfexch, only: cam_out_t, cam_in_t -use ppgrid, only: pcols, pver -use camsrfexch , only: cam_export -use shr_kind_mod, only: r8 => shr_kind_r8 -#ifdef CRM -use crmdims, only: crm_nx, crm_ny, crm_nz -#endif -use radiation, only: rad_out_t -use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_index -use physics_types, only: physics_state, physics_state_copy, physics_ptend -use pkg_cldoptics, only: cldems, cldovrlap, cldefr -use phys_grid, only: get_rlat_all_p, get_rlon_all_p -use cam_history, only: outfld -use cam_history_support, only : fillvalue - -implicit none -save -private - -type rad_avgdata_type_sam1mom - real(r8), allocatable :: solin_m(:) ! Solar incident flux - real(r8), allocatable :: fsntoa_m(:) ! Net solar flux at TOA - real(r8), allocatable :: fsutoa_m(:) ! upwelling solar flux at TOA - real(r8), allocatable :: fsntoac_m(:) ! Clear sky net solar flux at TOA - real(r8), allocatable :: fsnirt_m(:) ! Near-IR flux absorbed at toa - real(r8), allocatable :: fsnrtc_m(:) ! Clear sky near-IR flux absorbed at toa - real(r8), allocatable :: fsnirtsq_m(:) ! Near-IR flux absorbed at toa >= 0.7 microns - real(r8), allocatable :: fsntc_m(:) ! Clear sky total column abs solar flux - real(r8), allocatable :: fsnsc_m(:) ! Clear sky surface abs solar flux - real(r8), allocatable :: fsdsc_m(:) ! Clear sky surface downwelling solar flux - real(r8), allocatable :: flut_m(:) ! Upward flux at top of model - real(r8), allocatable :: flutc_m(:) ! Upward Clear Sky flux at top of model - real(r8), allocatable :: flntc_m(:) ! Clear sky lw flux at model top - real(r8), allocatable :: flnsc_m(:) ! Clear sky lw flux at srf (up-down) - real(r8), allocatable :: fldsc_m(:) ! Clear sky lw flux at srf (down) - real(r8), allocatable :: flwds_m(:) ! Down longwave flux at surface - real(r8), allocatable :: fsns_m(:) ! Surface solar absorbed flux - real(r8), allocatable :: fsnr_m(:) - real(r8), allocatable :: fsnt_m(:) ! Net column abs solar flux at model top - real(r8), allocatable :: flns_m(:) ! Srf longwave cooling (up-down) flux - real(r8), allocatable :: flnt_m(:) ! Net outgoing lw flux at model top - real(r8), allocatable :: flnr_m(:) - real(r8), allocatable :: fsds_m(:) ! Surface solar down flux - real(r8), allocatable :: fln200_m(:) ! net longwave flux interpolated to 200 mb - real(r8), allocatable :: fln200c_m(:) ! net clearsky longwave flux interpolated to 200 mb - real(r8), allocatable :: fsn200_m(:) ! fns interpolated to 200 mb - real(r8), allocatable :: fsn200c_m(:) ! fcns interpolated to 200 mb - real(r8), allocatable :: sols_m(:) ! Solar downward visible direct to surface - real(r8), allocatable :: soll_m(:) ! Solar downward near infrared direct to surface - real(r8), allocatable :: solsd_m(:) ! Solar downward visible diffuse to surface - real(r8), allocatable :: solld_m(:) ! Solar downward near infrared diffuse to surface - real(r8), allocatable :: qrs_m(:,:) - real(r8), allocatable :: qrl_m(:,:) - real(r8), allocatable :: qrsc_m(:,:) - real(r8), allocatable :: qrlc_m(:,:) - real(r8), allocatable :: rel_crm(:,:,:,:) - real(r8), allocatable :: rei_crm(:,:,:,:) - real(r8), allocatable :: qrl_crm(:,:,:,:) - real(r8), allocatable :: qrs_crm(:,:,:,:) - real(r8), allocatable :: fsdtoa_m(:) ! Solar input = Flux Solar Downward Top of Atmosphere - real(r8), allocatable :: flds_m(:) ! Down longwave flux at surface - - real(r8), pointer :: t_rad (:,:,:,:) ! rad temperuture - real(r8), pointer :: qv_rad(:,:,:,:) ! rad vapor - real(r8), pointer :: qc_rad(:,:,:,:) ! rad cloud water - real(r8), pointer :: qi_rad(:,:,:,:) ! rad cloud ice - real(r8), pointer :: crm_qrad(:,:,:,:) ! rad heating - - real(r8), allocatable :: tot_cld_vistau_m(:,:) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) - real(r8), allocatable :: tot_icld_vistau_m(:,:) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) - real(r8), allocatable :: liq_icld_vistau_m(:,:) ! in-cld liq cloud optical depth (only during day, night = fillvalue) - real(r8), allocatable :: ice_icld_vistau_m(:,:) ! in-cld ice cloud optical depth (only during day, night = fillvalue) - real(r8), allocatable :: nct_tot_icld_vistau_m(:,:) ! the number of CRM columns that has in-cloud visible sw optical depth - real(r8), allocatable :: nct_liq_icld_vistau_m(:,:) ! the number of CRM column that has liq in-cloud visible sw optical depth - real(r8), allocatable :: nct_ice_icld_vistau_m(:,:) ! the number of CRM column that has ice in-cloud visible sw optical depth - - ! Just used in m2005 -- needed for compilation only - real(r8), allocatable :: snow_icld_vistau_m(:,:) ! snow in-cloud visible sw optical depth for output on history files - real(r8), allocatable :: nct_snow_icld_vistau_m(:,:) ! the number of CRM column that has snow in-cloud visible sw optical depth - real(r8), allocatable :: crm_aodvisz(:,:,:,:) ! layer aerosol optical depth at 550nm at CRM grids - real(r8), allocatable :: crm_aodvis(:,:,:) ! AOD at 550nm at CRM grids - real(r8), allocatable :: crm_aod400(:,:,:) ! AOD at 400nm at CRM grids - real(r8), allocatable :: crm_aod700(:,:,:) ! AOD at 700nm at CRM grids - real(r8), allocatable :: aod400(:) ! AOD at 400nm at CRM grids - real(r8), allocatable :: aod700(:) ! AOD at 700nm at CRM grids - real(r8), allocatable :: cld_tau_crm(:,:,:,:) - real(r8), allocatable :: crm_fsnt(:,:,:) ! net shortwave fluxes at TOA at CRM grids - real(r8), allocatable :: crm_fsntc(:,:,:) ! net clear-sky shortwave fluxes at TOA at CRM grids - real(r8), allocatable :: crm_fsns(:,:,:) ! net shortwave fluxes at surface at CRM grids - real(r8), allocatable :: crm_fsnsc(:,:,:) ! net clear-sky shortwave fluxes at surface at CRM grids - real(r8), allocatable :: crm_flnt(:,:,:) ! net longwave fluxes at TOA at CRM grids - real(r8), allocatable :: crm_flntc(:,:,:) ! net clear-sky longwave fluxes at TOA at CRM grids - real(r8), allocatable :: crm_flns(:,:,:) ! net longwave fluxes at surface at CRM grids - real(r8), allocatable :: crm_flnsc(:,:,:) ! net clear-sky longwave fluxes at surface at CRM grids - real(r8), allocatable :: crm_swcf(:,:,:) ! shortwave cloud forcing at CRM grids -end type rad_avgdata_type_sam1mom - -type rad_avgdata_type_m2005 - real(r8),allocatable :: solin_m(:) ! Solar incident flux - real(r8),allocatable :: fsntoa_m(:) ! Net solar flux at TOA - real(r8),allocatable :: fsutoa_m(:) ! upwelling solar flux at TOA - real(r8),allocatable :: fsntoac_m(:) ! Clear sky net solar flux at TOA - real(r8),allocatable :: fsnirt_m(:) ! Near-IR flux absorbed at toa - real(r8),allocatable :: fsnrtc_m(:) ! Clear sky near-IR flux absorbed at toa - real(r8),allocatable :: fsnirtsq_m(:) ! Near-IR flux absorbed at toa >= 0.7 microns - real(r8),allocatable :: fsntc_m(:) ! Clear sky total column abs solar flux - real(r8),allocatable :: fsnsc_m(:) ! Clear sky surface abs solar flux - real(r8),allocatable :: fsdsc_m(:) ! Clear sky surface downwelling solar flux - real(r8),allocatable :: flut_m(:) ! Upward flux at top of model - real(r8),allocatable :: flutc_m(:) ! Upward Clear Sky flux at top of model - real(r8),allocatable :: flntc_m(:) ! Clear sky lw flux at model top - real(r8),allocatable :: flnsc_m(:) ! Clear sky lw flux at srf (up-down) - real(r8),allocatable :: fldsc_m(:) ! Clear sky lw flux at srf (down) - real(r8),allocatable :: flwds_m(:) ! Down longwave flux at surface - real(r8),allocatable :: fsns_m(:) ! Surface solar absorbed flux - real(r8),allocatable :: fsnr_m(:) - real(r8),allocatable :: fsnt_m(:) ! Net column abs solar flux at model top - real(r8),allocatable :: flns_m(:) ! Srf longwave cooling (up-down) flux - real(r8),allocatable :: flnt_m(:) ! Net outgoing lw flux at model top - real(r8),allocatable :: flnr_m(:) - real(r8),allocatable :: fsds_m(:) ! Surface solar down flux - real(r8),allocatable :: fln200_m(:) ! net longwave flux interpolated to 200 mb - real(r8),allocatable :: fln200c_m(:) ! net clearsky longwave flux interpolated to 200 mb - real(r8),allocatable :: fsn200_m(:) ! fns interpolated to 200 mb - real(r8),allocatable :: fsn200c_m(:) ! fcns interpolated to 200 mb - real(r8),allocatable :: sols_m(:) ! Solar downward visible direct to surface - real(r8),allocatable :: soll_m(:) ! Solar downward near infrared direct to surface - real(r8),allocatable :: solsd_m(:) ! Solar downward visible diffuse to surface - real(r8),allocatable :: solld_m(:) ! Solar downward near infrared diffuse to surface - real(r8),allocatable :: qrs_m(:,:) - real(r8),allocatable :: qrl_m(:,:) - real(r8),allocatable :: qrsc_m(:,:) - real(r8),allocatable :: qrlc_m(:,:) - real(r8),allocatable :: su_m(:,:,:) ! shortwave spectral flux up - real(r8),allocatable :: sd_m(:,:,:) ! shortwave spectral flux down - real(r8),allocatable :: lu_m(:,:,:) ! longwave spectral flux up - real(r8),allocatable :: ld_m(:,:,:) ! longwave spectral flux down - real(r8),pointer :: su(:,:,:) ! shortwave spectral flux up - real(r8),pointer :: sd(:,:,:) ! shortwave spectral flux down - real(r8),pointer :: lu(:,:,:) ! longwave spectral flux up - real(r8),pointer :: ld(:,:,:) ! longwave spectral flux down - real(r8), allocatable :: dei_crm(:,:,:,:) ! cloud scale ice effective diameter for optics - real(r8), allocatable :: mu_crm(:,:,:,:) ! cloud scale gamma parameter for optics - real(r8), allocatable :: lambdac_crm(:,:,:,:) ! cloud scale slope of droplet distribution for optics - real(r8), allocatable :: des_crm(:,:,:,:) ! cloud scale snow crystal diameter (micro-meter) - real(r8), allocatable :: rel_crm(:,:,:,:) - real(r8), allocatable :: rei_crm(:,:,:,:) - real(r8), allocatable :: cld_tau_crm(:,:,:,:) - real(r8), allocatable :: qrl_crm(:,:,:,:) - real(r8), allocatable :: qrs_crm(:,:,:,:) - real(r8), allocatable :: crm_fsnt(:,:,:) ! net shortwave fluxes at TOA at CRM grids - real(r8), allocatable :: crm_fsntc(:,:,:) ! net clear-sky shortwave fluxes at TOA at CRM grids - real(r8), allocatable :: crm_fsns(:,:,:) ! net shortwave fluxes at surface at CRM grids - real(r8), allocatable :: crm_fsnsc(:,:,:) ! net clear-sky shortwave fluxes at surface at CRM grids - real(r8), allocatable :: crm_flnt(:,:,:) ! net longwave fluxes at TOA at CRM grids - real(r8), allocatable :: crm_flntc(:,:,:) ! net clear-sky longwave fluxes at TOA at CRM grids - real(r8), allocatable :: crm_flns(:,:,:) ! net longwave fluxes at surface at CRM grids - real(r8), allocatable :: crm_flnsc(:,:,:) ! net clear-sky longwave fluxes at surface at CRM grids - real(r8), allocatable :: crm_swcf(:,:,:) ! shortwave cloud forcing at CRM grids - - - real(r8), allocatable :: crm_aodvisz(:,:,:,:) ! layer aerosol optical depth at 550nm at CRM grids - real(r8), allocatable :: crm_aodvis(:,:,:) ! AOD at 550nm at CRM grids - real(r8), allocatable :: crm_aod400(:,:,:) ! AOD at 400nm at CRM grids - real(r8), allocatable :: crm_aod700(:,:,:) ! AOD at 700nm at CRM grids - real(r8), allocatable :: aod400(:) ! AOD at 400nm at CRM grids - real(r8), allocatable :: aod700(:) ! AOD at 700nm at CRM grids - - real(r8), pointer :: t_rad (:,:,:) ! rad temperuture - real(r8), pointer :: qv_rad(:,:,:) ! rad vapor - real(r8), pointer :: qc_rad(:,:,:) ! rad cloud water - real(r8), pointer :: qi_rad(:,:,:) ! rad cloud ice - real(r8), pointer :: crm_qrad(:,:,:) ! rad heating - - real(r8), allocatable :: tot_cld_vistau_m(:,:) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) - real(r8), allocatable :: tot_icld_vistau_m(:,:) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) - real(r8), allocatable :: liq_icld_vistau_m(:,:) ! in-cld liq cloud optical depth (only during day, night = fillvalue) - real(r8), allocatable :: ice_icld_vistau_m(:,:) ! in-cld ice cloud optical depth (only during day, night = fillvalue) - real(r8), allocatable :: nct_tot_icld_vistau_m(:,:) ! the number of CRM columns that has in-cloud visible sw optical depth - real(r8), allocatable :: nct_liq_icld_vistau_m(:,:) ! the number of CRM column that has liq in-cloud visible sw optical depth - real(r8), allocatable :: nct_ice_icld_vistau_m(:,:) ! the number of CRM column that has ice in-cloud visible sw optical depth - - ! These do not need N_DIAG dimension - real(r8),allocatable :: snow_tau(:,:,:) ! snow extinction optical depth - - real(r8),allocatable :: snow_lw_abs (:,:,:) ! snow absorption optics depth (LW) - - ! Just used in m2005 - real(r8),allocatable :: snow_icld_vistau_m(:,:) ! snow in-cloud visible sw optical depth for output on history files - real(r8),allocatable :: nct_snow_icld_vistau_m(:,:) ! the number of CRM column that has snow in-cloud visible sw optical depth - - -end type rad_avgdata_type_m2005 - -public :: tphysbc_spcam, spcam_register, spcam_init - -integer :: dei_idx = -1 -integer :: mu_idx = -1 -integer :: lambdac_idx = -1 -integer :: des_idx = -1 -integer :: dgnumwet_crm_idx = -1 -integer :: qaerwat_crm_idx = -1 -integer :: rel_idx = -1 -integer :: rei_idx = -1 -integer :: landm_idx = -1 -integer :: iciwp_idx = -1 -integer :: iclwp_idx = -1 -integer :: icswp_idx = -1 -integer :: cld_idx = -1 -integer :: dgnumwet_idx = -1 -integer :: qaerwat_idx = -1 -integer :: crm_t_rad_idx = -1 -integer :: crm_qc_rad_idx = -1 -integer :: crm_qi_rad_idx = -1 -integer :: crm_qv_rad_idx = -1 -integer :: crm_qrad_idx = -1 -integer :: crm_cld_rad_idx = -1 -integer :: crm_nc_rad_idx = -1 -integer :: crm_ni_rad_idx = -1 -integer :: crm_qs_rad_idx = -1 -integer :: crm_ns_rad_idx = -1 -integer :: cicewp_idx = -1 -integer :: cliqwp_idx = -1 -integer :: cldemis_idx = -1 -integer :: cldtau_idx = -1 -integer :: pmxrgn_idx = -1 -integer :: nmxrgn_idx = -1 -integer :: qrs_idx = -1 -integer :: qrl_idx = -1 -integer :: fsns_idx = -1 -integer :: fsnt_idx = -1 -integer :: flns_idx = -1 -integer :: flnt_idx = -1 -integer :: fsds_idx = -1 -integer :: cldfsnow_idx = -1 - -! Minghuai - todo -- CAC note -! These values will be "averaged" as appropriate and stored back in the pbuf -! They should no longer be "saved" -- Probably will want to put in rad_avgdata structure -! Email from Minghaui - 10/10/14 said to put on todo list as he did not have -! time to address it now -! real(r8),allocatable :: cicewp(:,:) -! real(r8),allocatable :: cliqwp(:,:) -! real(r8),allocatable :: rel(:,:) -! real(r8),allocatable :: rei(:,:) -! real(r8),allocatable :: dei(:,:) -! real(r8),allocatable :: mu(:,:) -! real(r8),allocatable :: lambdac(:,:) -! real(r8),allocatable :: des(:,:) -! real(r8),allocatable :: cld(:,:) ! cloud fraction -! real(r8),allocatable :: cldfsnow(:,:) ! cloud fraction of just "snow clouds- whatever they are" -! real(r8),allocatable :: csnowp(:,:) -! real(r8),allocatable :: dgnumwet(:,:,:) ! number mode diameter -! real(r8),allocatable :: qaerwat(:,:,:) ! aerosol water - - -integer :: nmodes -logical :: is_spcam_m2005, is_spcam_sam1mom -logical :: prog_modal_aero - -contains -subroutine tphysbc_spcam (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 : pbuf_old_tim_idx, dyn_time_lvls - use physics_types, only: physics_state, physics_tend, physics_ptend, physics_update, & - physics_state_check - use dadadj_cam, only: dadadj_tend - 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 constituents, only: pcnst, qmin, cnst_get_ind - use time_manager, only: get_nstep - use check_energy, only: check_energy_cam_chng, check_energy_cam_fix - use check_energy, only: check_tracers_data, check_tracers_init - use dycore, only: dycore_is - use radiation, only: radiation_tend - use cloud_diagnostics, only: cloud_diagnostics_calc - use perf_mod - use tropopause, only: tropopause_output - use cam_abortutils, only: endrun -#ifdef CRM - use crm_physics, only: crm_physics_tend -#endif - use phys_control, only: phys_getopts - use sslt_rebin, only: sslt_rebin_adv - use qneg_module, only: qneg3 - - implicit none - - ! - ! 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 - - -#ifdef CRM - ! - !---------------------------Local workspace----------------------------- - ! - - type(physics_ptend) :: ptend ! indivdual parameterization tendencies - type(physics_state) :: state_loc - - integer :: nstep ! current timestep number - - real(r8) :: net_flx(pcols) - - real(r8) cldn(pcols,pver) - - - integer lchnk ! chunk identifier - integer ncol ! number of atmospheric columns - - integer i ! index - integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. - - ! 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 - - - ! energy checking variables - real(r8) :: zero(pcols) ! array of zeros - real(r8) :: flx_heat(pcols) - type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes - - logical :: state_debug_checks ! Debug physics_state. - - - type(rad_avgdata_type_sam1mom) :: rad_avgdata_sam1mom - type(rad_avgdata_type_m2005) :: rad_avgdata_m2005 - type(rad_out_t) :: rd - - integer :: teout_idx, qini_idx, cldliqini_idx, cldiceini_idx - integer :: ii, jj - !----------------------------------------------------------------------- - call t_startf('bc_init') - zero = 0._r8 - - lchnk = state%lchnk - ncol = state%ncol - - nstep = get_nstep() - - teout_idx = pbuf_get_index('TEOUT') - qini_idx = pbuf_get_index('QINI') - cldliqini_idx = pbuf_get_index('CLDLIQINI') - cldiceini_idx = pbuf_get_index('CLDICEINI') - - call phys_getopts(state_debug_checks_out=state_debug_checks) - - ! 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 - - call qneg3('TPHYSBCb',lchnk ,ncol ,pcols ,pver , & - 1, pcnst, qmin ,state%q ) - - ! Validate state coming from the dynamics. - if (state_debug_checks) & - call physics_state_check(state, name="before tphysbc (dycore?)") - ! - ! 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_cam_fix(state, ptend, nstep, flx_heat) - call physics_update(state, ptend, ztodt, tend) - call check_energy_cam_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') - - call sslt_rebin_adv(pbuf, state) - - ! - !=================================================== - ! 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') - - ! ------------------------------------------------------------------------------- - ! Call cloud resolving model - ! ------------------------------------------------------------------------------- - - call crm_physics_tend(ztodt, state, tend, ptend, pbuf, cam_in) - call physics_update(state, ptend, ztodt, tend) - - !=================================================== - ! 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 - !=================================================== - - if (is_spcam_sam1mom) then - call spcam_radiation_setup_sam1mom(cam_in, cldn, state, pbuf, rad_avgdata_sam1mom, state_loc) - else if (is_spcam_m2005) then - call spcam_radiation_setup_m2005(state, pbuf, rad_avgdata_m2005, state_loc) - end if - - 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') - - if (is_spcam_sam1mom) then - do jj=1,crm_ny - do ii=1,crm_nx - call spcam_radiation_col_setup_sam1mom(ii, jj, state_loc, pbuf, rad_avgdata_sam1mom) - call radiation_tend(state_loc, ptend, pbuf, & - cam_out, cam_in, & - net_flx, rd) - call spcam_radiation_col_finalize_sam1mom(state, ii, jj, pbuf, rd, cam_out, rad_avgdata_sam1mom) - end do - end do - call spcam_radiation_finalize_sam1mom(cam_in, state, pbuf, rad_avgdata_sam1mom, cam_out, cldn, net_flx, ptend) - - else if(is_spcam_m2005) then - do jj=1,crm_ny - do ii=1,crm_nx - call spcam_radiation_col_setup_m2005(ii, jj, ixcldice, ixcldliq, state_loc, pbuf, rad_avgdata_m2005) - call radiation_tend(state_loc, ptend, pbuf, & - cam_out, cam_in, & - net_flx, rd) - call spcam_radiation_col_finalize_m2005(state, ii, jj, pbuf, rd, cam_out, rad_avgdata_m2005) - end do - end do - call spcam_radiation_finalize_m2005(cam_in, state, pbuf, rad_avgdata_m2005, cam_out, net_flx, ptend) - end if - - ! Set net flux used by spectral dycores - do i=1,ncol - tend%flx_net(i) = net_flx(i) - end do - - ! don't add radiative tendency to GCM temperature in case of superparameterization - ! as it was added above as part of crm tendency. - ptend%s = 0._r8 - - call physics_update(state, ptend, ztodt, tend) - - call check_energy_cam_chng(state, tend, "spradheat", nstep, ztodt, zero, zero, zero, zero) - - 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') - -#endif -end subroutine tphysbc_spcam - -!=============================================================================== - -subroutine spcam_register() - use physics_buffer, only: pbuf_add_field, dtype_r8, dyn_time_lvls ! is dyn_time_lvls needed ??? - use phys_control, only: cam_physpkg_is -#ifdef CRM - use crm_physics, only: crm_physics_register - use crmx_vars, only: naer, vaer, hgaer - use crmx_grid -#ifdef MODAL_AERO - use modal_aero_data, only: ntot_amode - - allocate(naer(nzm, ntot_amode)) ! Aerosol number concentration [/m3] - allocate(vaer(nzm, ntot_amode)) ! aerosol volume concentration [m3/m3] - allocate(hgaer(nzm, ntot_amode)) ! hygroscopicity of aerosol mode -#endif - - - call crm_physics_register() - -#endif - - is_spcam_m2005 = cam_physpkg_is('spcam_m2005') - is_spcam_sam1mom = cam_physpkg_is('spcam_sam1mom') - - if (is_spcam_m2005) then - call pbuf_add_field('ICSWP', 'physpkg',dtype_r8,(/pcols,pver/), icswp_idx) - call pbuf_add_field('CLDFSNOW', 'physpkg',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldfsnow_idx) - endif - -end subroutine spcam_register - -!=============================================================================== - -subroutine spcam_init(pbuf2d) - use physics_buffer, only: pbuf_get_index - use phys_control, only: phys_getopts -#ifdef CRM - use crm_physics, only: crm_physics_init -#endif - use rad_constituents, only: rad_cnst_get_info - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - -#ifdef CRM - - call phys_getopts(prog_modal_aero_out = prog_modal_aero) - - call rad_cnst_get_info(0, nmodes=nmodes) - - dei_idx = pbuf_get_index('DEI') - mu_idx = pbuf_get_index('MU') - lambdac_idx = pbuf_get_index('LAMBDAC') - des_idx = pbuf_get_index('DES') - rel_idx = pbuf_get_index('REL') - rei_idx = pbuf_get_index('REI') - landm_idx = pbuf_get_index('LANDM') - cld_idx = pbuf_get_index('CLD') - qrs_idx = pbuf_get_index('QRS') - qrl_idx = pbuf_get_index('QRL') - fsns_idx = pbuf_get_index('FSNS') - fsds_idx = pbuf_get_index('FSDS') - fsnt_idx = pbuf_get_index('FSNT') - flnt_idx = pbuf_get_index('FLNT') - flns_idx = pbuf_get_index('FLNS') - - crm_t_rad_idx = pbuf_get_index('CRM_T_RAD') - crm_qc_rad_idx = pbuf_get_index('CRM_QC_RAD') - crm_qi_rad_idx = pbuf_get_index('CRM_QI_RAD') - crm_qv_rad_idx = pbuf_get_index('CRM_QV_RAD') - crm_qrad_idx = pbuf_get_index('CRM_QRAD') - crm_cld_rad_idx = pbuf_get_index('CRM_CLD_RAD') - - - if (is_spcam_sam1mom) then - cldemis_idx = pbuf_get_index('CLDEMIS') - cldtau_idx = pbuf_get_index('CLDTAU') - cicewp_idx = pbuf_get_index('CICEWP') - cliqwp_idx = pbuf_get_index('CLIQWP') - pmxrgn_idx = pbuf_get_index('PMXRGN') - nmxrgn_idx = pbuf_get_index('NMXRGN') - else if (is_spcam_m2005) then - iciwp_idx = pbuf_get_index('ICIWP') - iclwp_idx = pbuf_get_index('ICLWP') - crm_nc_rad_idx = pbuf_get_index('CRM_NC_RAD') - crm_ni_rad_idx = pbuf_get_index('CRM_NI_RAD') - crm_qs_rad_idx = pbuf_get_index('CRM_QS_RAD') - crm_ns_rad_idx = pbuf_get_index('CRM_NS_RAD') - end if - - if (prog_modal_aero) then - dgnumwet_idx = pbuf_get_index('DGNUMWET') - qaerwat_idx = pbuf_get_index('QAERWAT') - dgnumwet_crm_idx = pbuf_get_index('CRM_DGNUMWET') - qaerwat_crm_idx = pbuf_get_index('CRM_QAERWAT') - end if - - ! Initialize the crm_physics layer - call crm_physics_init(pbuf2d) - -#endif -end subroutine spcam_init - -!=============================================================================== - -subroutine spcam_radiation_setup_m2005(state, pbuf, rad_avgdata, state_loc) - - use physics_buffer, only: physics_buffer_desc, pbuf_get_field - use physics_buffer, only: pbuf_old_tim_idx - - type(physics_state), intent(in) :: state - type(physics_buffer_desc), intent(inout), pointer :: pbuf(:) - - type(rad_avgdata_type_m2005), intent(out) :: rad_avgdata - type(physics_state), intent(out) :: state_loc - -#ifdef m2005 - real(r8), pointer, dimension(:, :) :: cicewp - real(r8), pointer, dimension(:, :) :: cliqwp - real(r8), pointer, dimension(:, :) :: csnowp - real(r8), pointer, dimension(:,:) :: rel ! liquid effective drop radius (microns) - real(r8), pointer, dimension(:,:) :: rei ! ice effective drop size (microns) - real(r8), pointer, dimension(:,:) :: cld ! cloud fraction - real(r8), pointer, dimension(:,:) :: cldfsnow ! cloud fraction of just "snow clouds- whatever they are" - real(r8), pointer, dimension(:, :) :: dei ! ice effective diameter for optics (radiation) - real(r8), pointer, dimension(:, :) :: mu ! gamma parameter for optics (radiation) - real(r8), pointer, dimension(:, :) :: lambdac ! slope of droplet distribution for optics (radiation) - real(r8), pointer, dimension(:, :) :: des ! snow crystatl diameter for optics (mirometer, radiation) - - integer :: ncol ! number of atmospheric columns - integer :: itim_old - - ncol = state%ncol - - call physics_state_copy(state, state_loc) - - allocate(rad_avgdata%solin_m (pcols)) - allocate(rad_avgdata%fsntoa_m (pcols)) - allocate(rad_avgdata%fsutoa_m (pcols)) - allocate(rad_avgdata%fsntoac_m (pcols)) - allocate(rad_avgdata%fsnirt_m (pcols)) - allocate(rad_avgdata%fsnrtc_m (pcols)) - allocate(rad_avgdata%fsnirtsq_m (pcols)) - allocate(rad_avgdata%fsntc_m (pcols)) - allocate(rad_avgdata%fsnsc_m (pcols)) - allocate(rad_avgdata%fsdsc_m (pcols)) - allocate(rad_avgdata%flut_m (pcols)) - allocate(rad_avgdata%flutc_m (pcols)) - allocate(rad_avgdata%flntc_m (pcols)) - allocate(rad_avgdata%flnsc_m (pcols)) - allocate(rad_avgdata%fldsc_m (pcols)) - allocate(rad_avgdata%flwds_m (pcols)) - allocate(rad_avgdata%fsns_m (pcols)) - allocate(rad_avgdata%fsnr_m (pcols)) - allocate(rad_avgdata%fsnt_m (pcols)) - allocate(rad_avgdata%flns_m (pcols)) - allocate(rad_avgdata%flnt_m (pcols)) - allocate(rad_avgdata%flnr_m (pcols)) - allocate(rad_avgdata%fsds_m (pcols)) - allocate(rad_avgdata%fln200_m (pcols)) - allocate(rad_avgdata%fln200c_m (pcols)) - allocate(rad_avgdata%fsn200_m (pcols)) - allocate(rad_avgdata%fsn200c_m (pcols)) - allocate(rad_avgdata%sols_m (pcols)) - allocate(rad_avgdata%soll_m (pcols)) - allocate(rad_avgdata%solsd_m (pcols)) - allocate(rad_avgdata%solld_m (pcols)) - allocate(rad_avgdata%qrs_m (pcols,pver)) - allocate(rad_avgdata%qrl_m (pcols,pver)) - allocate(rad_avgdata%qrsc_m (pcols,pver)) - allocate(rad_avgdata%qrlc_m (pcols,pver)) - allocate(rad_avgdata%rel_crm (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%rei_crm (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%cld_tau_crm (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%qrl_crm (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%qrs_crm (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%crm_fsnt (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_fsntc (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_fsns (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_fsnsc (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_flnt (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_flntc (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_flns (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_flnsc (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_swcf (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_aodvisz (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%crm_aodvis (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_aod400 (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_aod700 (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%aod400 (pcols)) - allocate(rad_avgdata%aod700 (pcols)) - - allocate(rad_avgdata%tot_cld_vistau_m (pcols,pver)) - allocate(rad_avgdata%tot_icld_vistau_m (pcols,pver)) - allocate(rad_avgdata%liq_icld_vistau_m (pcols,pver)) - allocate(rad_avgdata%ice_icld_vistau_m (pcols,pver)) - allocate(rad_avgdata%nct_tot_icld_vistau_m (pcols,pver)) - allocate(rad_avgdata%nct_liq_icld_vistau_m (pcols,pver)) - allocate(rad_avgdata%nct_ice_icld_vistau_m (pcols,pver)) - allocate(rad_avgdata%snow_icld_vistau_m (pcols,pver)) - allocate(rad_avgdata%nct_snow_icld_vistau_m(pcols,pver)) - - allocate(rad_avgdata%dei_crm(pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%mu_crm(pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%lambdac_crm(pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%des_crm(pcols, crm_nx, crm_ny, crm_nz)) - - call pbuf_get_field(pbuf, iciwp_idx, cicewp) - call pbuf_get_field(pbuf, iclwp_idx, cliqwp) - call pbuf_get_field(pbuf, icswp_idx, csnowp) - call pbuf_get_field(pbuf, rel_idx, rel) - call pbuf_get_field(pbuf, rei_idx, rei) - call pbuf_get_field(pbuf, dei_idx, dei) - call pbuf_get_field(pbuf, mu_idx, mu) - call pbuf_get_field(pbuf, lambdac_idx, lambdac) - call pbuf_get_field(pbuf, des_idx, des) - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - if (cldfsnow_idx > 0) then - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - endif - - ! Initialize the summation values - - rad_avgdata%solin_m = 0._r8 - rad_avgdata%fsntoa_m = 0._r8 - rad_avgdata%fsutoa_m = 0._r8 - rad_avgdata%fsntoac_m = 0._r8 - rad_avgdata%fsnirt_m = 0._r8 - rad_avgdata%fsnrtc_m = 0._r8 - rad_avgdata%fsnirtsq_m = 0._r8 - rad_avgdata%fsntc_m = 0._r8 - rad_avgdata%fsnsc_m = 0._r8 - rad_avgdata%fsdsc_m = 0._r8 - rad_avgdata%flut_m = 0._r8 - rad_avgdata%flutc_m = 0._r8 - rad_avgdata%flntc_m = 0._r8 - rad_avgdata%flnsc_m = 0._r8 - rad_avgdata%fldsc_m = 0._r8 - rad_avgdata%flwds_m = 0._r8 - rad_avgdata%fsns_m = 0._r8 - rad_avgdata%fsnt_m = 0._r8 - rad_avgdata%flns_m = 0._r8 - rad_avgdata%flnt_m = 0._r8 - rad_avgdata%flnr_m = 0._r8 - rad_avgdata%fsds_m = 0._r8 - rad_avgdata%fsnr_m = 0._r8 - rad_avgdata%fln200_m = 0._r8 - rad_avgdata%fln200c_m = 0._r8 - rad_avgdata%fsn200_m = 0._r8 - rad_avgdata%fsn200c_m = 0._r8 - rad_avgdata%sols_m = 0._r8 - rad_avgdata%soll_m = 0._r8 - rad_avgdata%solsd_m = 0._r8 - rad_avgdata%solld_m = 0._r8 - rad_avgdata%qrs_m = 0._r8 - rad_avgdata%qrl_m = 0._r8 - rad_avgdata%qrsc_m = 0._r8 - rad_avgdata%qrlc_m = 0._r8 - rad_avgdata%qrs_crm = 0._r8 - rad_avgdata%qrl_crm = 0._r8 - rad_avgdata%cld_tau_crm = 0.0_r8 - rad_avgdata%crm_aodvisz = 0._r8 - rad_avgdata%crm_aodvis = 0._r8 - - rad_avgdata%crm_aod400 = 0._r8 ; rad_avgdata%crm_aod700 = 0._r8 - rad_avgdata%aod400 = 0._r8 ; rad_avgdata%aod700 = 0._r8 - rad_avgdata%crm_fsnt = 0._r8 ; rad_avgdata%crm_fsntc = 0._r8 - rad_avgdata%crm_fsns = 0._r8 ; rad_avgdata%crm_fsnsc = 0._r8 - rad_avgdata%crm_flnt = 0._r8 ; rad_avgdata%crm_flntc = 0._r8 - rad_avgdata%crm_flns = 0._r8 ; rad_avgdata%crm_flnsc = 0._r8 - rad_avgdata%crm_swcf = 0._r8 - - - rad_avgdata%tot_cld_vistau_m = 0._r8 - rad_avgdata%tot_icld_vistau_m = 0._r8 ; rad_avgdata%nct_tot_icld_vistau_m = 0._r8 - rad_avgdata%liq_icld_vistau_m = 0._r8 ; rad_avgdata%nct_liq_icld_vistau_m = 0._r8 - rad_avgdata%ice_icld_vistau_m = 0._r8 ; rad_avgdata%nct_ice_icld_vistau_m = 0._r8 - rad_avgdata%snow_icld_vistau_m = 0._r8 ; rad_avgdata%nct_snow_icld_vistau_m = 0._r8 - - ! Initialize the pbuf values - lambdac = 0.0_r8 - des = 0.0_r8 - cicewp(1:ncol,1:pver) = 0.0_r8 - cliqwp(1:ncol,1:pver) = 0.0_r8 - csnowp(1:ncol,1:pver) = 0.0_r8 - cld = 0.0_r8 - cldfsnow = 0.0_r8 - rel = 0.0_r8 - rei = 0.0_r8 - dei = 0.0_r8 - mu = 0.0_r8 - -#endif -end subroutine spcam_radiation_setup_m2005 - -!=============================================================================== - -subroutine spcam_radiation_col_setup_m2005(ii, jj, ixcldice, ixcldliq, state_loc, pbuf, rad_avgdata) - - use physics_buffer, only: pbuf_old_tim_idx - use physconst, only: gravit -#ifdef CRM - use crm_physics, only: m2005_effradius -#endif - - - integer, intent(in) :: ii,jj - integer, intent(in) :: ixcldice, ixcldliq ! constituent indices for cloud liq and ice water. - - type(physics_state), intent(inout) :: state_loc - type(physics_buffer_desc), intent(inout), pointer :: pbuf(:) - type(rad_avgdata_type_m2005), intent(inout) :: rad_avgdata - -#ifdef m2005 - real(r8),pointer :: nc_rad(:,:,:,:) ! rad cloud water droplet number (#/kg) - real(r8),pointer :: ni_rad(:,:,:,:) ! rad cloud ice crystal nubmer (#/kg) - real(r8),pointer :: qs_rad(:,:,:,:) ! rad cloud snow crystal mass (kg/kg) - real(r8),pointer :: ns_rad(:,:,:,:) ! rad cloud snow crystal nubmer (#/kg) - - - real(r8),pointer :: t_rad (:,:,:,:) ! rad temperuture - real(r8),pointer :: qv_rad(:,:,:,:) ! rad vapor - real(r8),pointer :: qc_rad(:,:,:,:) ! rad cloud water - real(r8),pointer :: qi_rad(:,:,:,:) ! rad cloud ice - real(r8),pointer :: crm_qrad(:,:,:,:) ! rad heating - real(r8),pointer :: cld_rad(:,:,:,:) ! rad cloud fraction - - - real(r8), pointer, dimension(:,:) :: cicewp - real(r8), pointer, dimension(:,:) :: cliqwp - real(r8), pointer, dimension(:,:) :: csnowp - real(r8), pointer, dimension(:,:) :: rel ! liquid effective drop radius (microns) - real(r8), pointer, dimension(:,:) :: rei ! ice effective drop size (microns) - real(r8), pointer, dimension(:,:) :: cld ! cloud fraction - real(r8), pointer, dimension(:,:) :: cldfsnow ! cloud fraction of just "snow clouds- whatever they are" - real(r8), pointer, dimension(:,:) :: dei ! ice effective diameter for optics (radiation) - real(r8), pointer, dimension(:,:) :: mu ! gamma parameter for optics (radiation) - real(r8), pointer, dimension(:,:) :: lambdac ! slope of droplet distribution for optics (radiation) - real(r8), pointer, dimension(:,:) :: des ! snow crystatl diameter for optics (mirometer, radiation) - real(r8), pointer, dimension(:,:,:) :: dgnumwet ! number mode diameter - real(r8), pointer, dimension(:,:,:) :: qaerwat ! aerosol water - - real(r8),pointer, dimension(:,:,:,:,:) :: qaerwat_crm ! aerosol water - real(r8),pointer, dimension(:,:,:,:,:) :: dgnumwet_crm ! wet mode dimaeter - - real(r8) :: qtot - real(r8) :: effl ! droplet effective radius [micrometer] - real(r8) :: effi ! ice crystal effective radius [micrometer] - real(r8) :: effl_fn ! effl for fixed number concentration of nlic = 1.e8 - - real(r8) :: deffi ! ice effective diameter for optics (radiation) - real(r8) :: lamc ! slope of droplet distribution for optics (radiation) - real(r8) :: pgam ! gamma parameter for optics (radiation) - real(r8) :: dest ! snow crystal effective diameters for optics (radiation) (micro-meter) - - - integer :: itim_old - integer :: m, k, i - integer :: ncol ! number of atmospheric columns - - ncol = state_loc%ncol - - 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, dei_idx, dei) - call pbuf_get_field(pbuf, mu_idx, mu) - call pbuf_get_field(pbuf, lambdac_idx, lambdac) - call pbuf_get_field(pbuf, des_idx, des) - if (prog_modal_aero) then - call pbuf_get_field(pbuf, dgnumwet_crm_idx, dgnumwet_crm) - call pbuf_get_field(pbuf, qaerwat_crm_idx, qaerwat_crm) - call pbuf_get_field(pbuf, dgnumwet_idx, dgnumwet) - call pbuf_get_field(pbuf, qaerwat_idx, qaerwat) - endif - - call pbuf_get_field(pbuf, rel_idx, rel) - call pbuf_get_field(pbuf, rei_idx, rei) - - call pbuf_get_field(pbuf, crm_t_rad_idx, t_rad) - call pbuf_get_field(pbuf, crm_qc_rad_idx, qc_rad) - call pbuf_get_field(pbuf, crm_qi_rad_idx, qi_rad) - call pbuf_get_field(pbuf, crm_qv_rad_idx, qv_rad) - call pbuf_get_field(pbuf, crm_qrad_idx, crm_qrad) - call pbuf_get_field(pbuf, crm_cld_rad_idx, cld_rad) - - crm_qrad=0._r8 - - - call pbuf_get_field(pbuf, iciwp_idx, cicewp) - call pbuf_get_field(pbuf, iclwp_idx, cliqwp) - call pbuf_get_field(pbuf, icswp_idx, csnowp) - - call pbuf_get_field(pbuf, crm_nc_rad_idx, nc_rad, start=(/1,1,1,1/), kount=(/pcols,crm_nx, crm_ny, crm_nz/)) - call pbuf_get_field(pbuf, crm_ni_rad_idx, ni_rad, start=(/1,1,1,1/), kount=(/pcols,crm_nx, crm_ny, crm_nz/)) - call pbuf_get_field(pbuf, crm_qs_rad_idx, qs_rad, start=(/1,1,1,1/), kount=(/pcols,crm_nx, crm_ny, crm_nz/)) - call pbuf_get_field(pbuf, crm_ns_rad_idx, ns_rad, start=(/1,1,1,1/), kount=(/pcols,crm_nx, crm_ny, crm_nz/)) - - if (cldfsnow_idx > 0) then - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - endif - - do m=1,crm_nz - k = pver-m+1 - do i=1,ncol - - qtot = qc_rad(i,ii,jj,m) + qi_rad(i,ii,jj,m) - if(qtot.gt.1.e-9_r8) then - cld(i,k) = min(0.99_r8, cld_rad(i,ii,jj,m)) - - ! In-cloud ice water path. - cicewp(i,k) = qi_rad(i,ii,jj,m)*state_loc%pdel(i,k)/gravit / max(0.01_r8,cld(i,k)) - ! In-cloud liquid water path. - cliqwp(i,k) = qc_rad(i,ii,jj,m)*state_loc%pdel(i,k)/gravit / max(0.01_r8,cld(i,k)) - else - cld(i,k) = 0._r8 - cicewp(i,k) = 0._r8 ! In-cloud ice water path. - cliqwp(i,k) = 0._r8 ! In-cloud liquid water path. - end if - - ! - ! snow water-related variables: - ! snow water is an important component in m2005 microphysics, and is therefore taken - ! account in the radiative calculation (snow water path is several times larger than ice water path in m2005 globally). - ! - if( qs_rad(i, ii, jj, m).gt.1.0e-7_r8) then - cldfsnow(i,k) = 0.99_r8 - csnowp(i,k) = qs_rad(i,ii,jj,m)*state_loc%pdel(i,k)/gravit / max(0.001_r8,cldfsnow(i,k)) - else - cldfsnow(i,k) = 0.0_r8 - csnowp(i,k) = 0.0_r8 - end if - - - ! update ice water, liquid water, water vapor, and temperature in state_loc - state_loc%q(i,k,ixcldice) = qi_rad(i,ii,jj,m) - state_loc%q(i,k,ixcldliq) = qc_rad(i,ii,jj,m) - state_loc%q(i,k,1) = max(1.e-9_r8,qv_rad(i,ii,jj,m)) - state_loc%t(i,k) = t_rad(i, ii, jj, m) - - ! Using CRM scale aerosol water to calculate aerosol optical depth. - ! Here we assume no aerosol water uptake at cloudy sky at CRM grids. - ! This is not really phyisically correct. But if we assume 100% of relative humidity for - ! aerosol water uptake, this will bias 'AODVIS' to be large, since 'AODVIS' is used - ! to compare with observated clear sky AOD. In the future, AODVIS is needed to be calcualted - ! from clear sky CRM AOD only. But before this is done, we will assume no water uptake at CCRM - ! cloudy grids (The radiative effects of this assumption will be small, since in cloudy sky, - ! aerosol effects is small anyway. - ! - if (prog_modal_aero) then - qaerwat(i, k, 1:nmodes) = qaerwat_crm(i, ii, jj, m, 1:nmodes) - dgnumwet(i, k, 1:nmodes) = dgnumwet_crm(i, ii, jj, m, 1:nmodes) - endif - end do ! i - end do ! m - - - ! update effective radius - do m=1,crm_nz - k = pver-m+1 - do i=1,ncol - - call m2005_effradius(qc_rad(i,ii,jj,m), nc_rad(i,ii,jj,m), qi_rad(i,ii,jj,m), & - ni_rad(i,ii,jj,m), qs_rad(i,ii,jj,m), ns_rad(i,ii,jj,m), & - 1.0_r8, state_loc%pmid(i,k), state_loc%t(i,k), effl, effi, effl_fn, deffi, lamc, pgam, dest) - - rel(i,k) = effl - rei(i,k) = effi - dei(i,k) = deffi - mu(i,k) = pgam - lambdac(i,k) = lamc - des(i,k) = dest - - rad_avgdata%dei_crm(i,ii,jj,m) = dei(i,k) - rad_avgdata%mu_crm(i,ii,jj,m) = mu(i,k) - rad_avgdata%lambdac_crm(i,ii,jj,m) = lambdac(i,k) - rad_avgdata%des_crm(i,ii,jj,m) = des(i,k) - rad_avgdata%rel_crm(i,ii,jj,m) = rel(i,k) - rad_avgdata%rei_crm(i,ii,jj,m) = rei(i,k) - end do - end do - -#endif -end subroutine spcam_radiation_col_setup_m2005 - -!=============================================================================== - -subroutine spcam_radiation_finalize_m2005(cam_in, state, pbuf, rad_avgdata, cam_out, net_flx, ptend) - - use physconst, only: cpair - use rad_constituents,only: rad_cnst_out - - use physconst, only: cappa - use radiation_data, only: rad_data_write - use radheat, only: radheat_tend - use time_manager, only: get_curr_calday - use physics_buffer, only: pbuf_old_tim_idx - use radheat, only: radheat_tend - use orbit, only: zenith - - type(cam_in_t), intent(in) :: cam_in - type(physics_state), intent(in) :: state - - - type(physics_buffer_desc), intent(inout), pointer :: pbuf(:) - type(rad_avgdata_type_m2005), intent(inout) :: rad_avgdata - type(cam_out_t), intent(inout) :: cam_out - - real(r8), intent(inout) :: net_flx(pcols) - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - - - -#ifdef m2005 - - real(r8), parameter :: factor_xy = 1._r8/dble(crm_nx*crm_ny) - - real(r8), pointer, dimension(:,:) :: cicewp - real(r8), pointer, dimension(:,:) :: cliqwp - real(r8), pointer, dimension(:,:) :: csnowp - real(r8), pointer, dimension(:,:) :: rel ! liquid effective drop radius (microns) - real(r8), pointer, dimension(:,:) :: rei ! ice effective drop size (microns) - real(r8), pointer, dimension(:,:) :: landm - real(r8), pointer, dimension(:,:) :: cld ! cloud fraction - real(r8), pointer, dimension(:,:) :: cldfsnow ! cloud fraction of just "snow clouds- whatever they are" - real(r8), pointer, dimension(:,:) :: dei ! ice effective diameter for optics (radiation) - real(r8), pointer, dimension(:,:) :: mu ! gamma parameter for optics (radiation) - real(r8), pointer, dimension(:,:) :: lambdac ! slope of droplet distribution for optics (radiation) - real(r8), pointer, dimension(:,:) :: des ! snow crystatl diameter for optics (mirometer, radiation) - real(r8), pointer, dimension(:,:,:) :: dgnumwet ! number mode diameter - real(r8), pointer, dimension(:,:,:) :: qaerwat ! aerosol water - real(r8), pointer, dimension(:,:,:,:) :: crm_qrad ! rad heating - real(r8), pointer, dimension(:,:) :: qrs - real(r8), pointer, dimension(:,:) :: qrl - real(r8), pointer, dimension(:) :: fsns ! Surface solar absorbed flux - real(r8), pointer, dimension(:) :: fsnt ! Net column abs solar flux at model top - real(r8), pointer, dimension(:) :: flns ! Srf longwave cooling (up-down) flux - real(r8), pointer, dimension(:) :: flnt ! Net outgoing lw flux at model top - real(r8), pointer, dimension(:) :: fsds ! Surface solar down flux - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - - integer :: Nday ! Number of daylight columns - integer :: Nnite ! Number of night columns - integer :: itim_old - integer :: i, k, m - - integer, dimension(pcols) :: IdxNite ! Indicies of night coumns - - real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables - real(r8) :: calday ! current calendar day - real(r8) :: clat(pcols) ! current latitudes(radians) - real(r8) :: clon(pcols) ! current longitudes(radians) - real(r8) :: coszrs(pcols) ! Cosine solar zenith angle - - - lchnk = state%lchnk - ncol = state%ncol - - calday = get_curr_calday() - - ! - ! 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) - - ! Gather night/day column indices. - Nday = 0 - Nnite = 0 - do i = 1, ncol - if ( coszrs(i) > 0.0_r8 ) then - Nday = Nday + 1 - else - Nnite = Nnite + 1 - IdxNite(Nnite) = i - end if - end do - - - - ! Shortwave - - ftem(:ncol,:pver) = rad_avgdata%qrs_m(:ncol,:pver)/cpair - call outfld('QRS'//' ',ftem ,pcols,lchnk) - ftem(:ncol,:pver) = rad_avgdata%qrsc_m(:ncol,:pver)/cpair - call outfld('QRSC'//' ',ftem ,pcols,lchnk) - call outfld('SOLIN'//' ',rad_avgdata%solin_m(:) ,pcols,lchnk) - call outfld('FSDS'//' ',rad_avgdata%fsds_m(:) ,pcols,lchnk) - call outfld('FSNIRTOA'//' ',rad_avgdata%fsnirt_m(:),pcols,lchnk) - call outfld('FSNRTOAC'//' ',rad_avgdata%fsnrtc_m(:),pcols,lchnk) - call outfld('FSNRTOAS'//' ',rad_avgdata%fsnirtsq_m(:),pcols,lchnk) - call outfld('FSNT'//' ',rad_avgdata%fsnt_m(:) ,pcols,lchnk) - call outfld('FSNS'//' ',rad_avgdata%fsns_m(:) ,pcols,lchnk) - call outfld('FSNTC'//' ',rad_avgdata%fsntc_m(:) ,pcols,lchnk) - call outfld('FSNSC'//' ',rad_avgdata%fsnsc_m(:) ,pcols,lchnk) - call outfld('FSDSC'//' ',rad_avgdata%fsdsc_m(:) ,pcols,lchnk) - call outfld('FSNTOA'//' ',rad_avgdata%fsntoa_m(:),pcols,lchnk) - call outfld('FSUTOA'//' ',rad_avgdata%fsutoa_m(:),pcols,lchnk) - call outfld('FSNTOAC'//' ',rad_avgdata%fsntoac_m(:),pcols,lchnk) - call outfld('SOLS'//' ',rad_avgdata%sols_m(:) ,pcols,lchnk) - call outfld('SOLL'//' ',rad_avgdata%soll_m(:) ,pcols,lchnk) - call outfld('SOLSD'//' ',rad_avgdata%solsd_m(:) ,pcols,lchnk) - call outfld('SOLLD'//' ',rad_avgdata%solld_m(:) ,pcols,lchnk) - call outfld('FSN200'//' ',rad_avgdata%fsn200_m(:),pcols,lchnk) - call outfld('FSN200C'//' ',rad_avgdata%fsn200c_m(:),pcols,lchnk) - call outfld('SWCF'//' ',rad_avgdata%fsntoa_m(:)-rad_avgdata%fsntoac_m(:) ,pcols,lchnk) - call outfld('FSNR'//' ',rad_avgdata%fsnr_m(:) ,pcols,lchnk) - - do i = 1, nnite - rad_avgdata%crm_aodvis(idxnite(i), :, :) = fillvalue - rad_avgdata%crm_aod400(idxnite(i), :, :) = fillvalue - rad_avgdata%crm_aod700(idxnite(i), :, :) = fillvalue - rad_avgdata%aod400(idxnite(i)) = fillvalue - rad_avgdata%aod700(idxnite(i)) = fillvalue - rad_avgdata%crm_aodvisz(idxnite(i), :, :, :) = fillvalue - rad_avgdata%tot_cld_vistau_m(IdxNite(i),:) = fillvalue - rad_avgdata%tot_icld_vistau_m(IdxNite(i),:) = fillvalue - rad_avgdata%liq_icld_vistau_m(IdxNite(i),:) = fillvalue - rad_avgdata%ice_icld_vistau_m(IdxNite(i),:) = fillvalue - if (cldfsnow_idx > 0) then - rad_avgdata%snow_icld_vistau_m(IdxNite(i),:) = fillvalue - endif - end do - - call outfld('CRM_FSNT', rad_avgdata%crm_fsnt, pcols, lchnk) - call outfld('CRM_FSNTC', rad_avgdata%crm_fsntc, pcols, lchnk) - call outfld('CRM_FSNS', rad_avgdata%crm_fsns, pcols, lchnk) - call outfld('CRM_FSNSC', rad_avgdata%crm_fsnsc, pcols, lchnk) - call outfld('CRM_AODVIS', rad_avgdata%crm_aodvis, pcols, lchnk) - call outfld('CRM_AOD400', rad_avgdata%crm_aod400, pcols, lchnk) - call outfld('CRM_AOD700', rad_avgdata%crm_aod700, pcols, lchnk) - call outfld('AOD400', rad_avgdata%aod400, pcols, lchnk) - call outfld('AOD700', rad_avgdata%aod700, pcols, lchnk) - call outfld('CRM_AODVISZ', rad_avgdata%crm_aodvisz, pcols, lchnk) - call outfld('TOT_CLD_VISTAU', rad_avgdata%tot_cld_vistau_m, pcols, lchnk) - call outfld('TOT_ICLD_VISTAU', rad_avgdata%tot_icld_vistau_m, pcols, lchnk) - call outfld('LIQ_ICLD_VISTAU', rad_avgdata%liq_icld_vistau_m, pcols, lchnk) - call outfld('ICE_ICLD_VISTAU', rad_avgdata%ice_icld_vistau_m, pcols, lchnk) - if (cldfsnow_idx > 0) then - call outfld('SNOW_ICLD_VISTAU', rad_avgdata%snow_icld_vistau_m, pcols, lchnk) - endif - - ! Longwave - call outfld('QRL'//' ',rad_avgdata%qrl_m (:ncol,:)/cpair,ncol,lchnk) - call outfld('QRLC'//' ',rad_avgdata%qrlc_m(:ncol,:)/cpair,ncol,lchnk) - call outfld('FLNT'//' ',rad_avgdata%flnt_m(:) ,pcols,lchnk) - call outfld('FLUT'//' ',rad_avgdata%flut_m(:) ,pcols,lchnk) - call outfld('FLUTC'//' ',rad_avgdata%flutc_m(:) ,pcols,lchnk) - call outfld('FLNTC'//' ',rad_avgdata%flntc_m(:) ,pcols,lchnk) - call outfld('FLNS'//' ',rad_avgdata%flns_m(:) ,pcols,lchnk) - - call outfld('FLDSC'//' ',rad_avgdata%fldsc_m(:) ,pcols,lchnk) - call outfld('FLNSC'//' ',rad_avgdata%flnsc_m(:) ,pcols,lchnk) - call outfld('LWCF'//' ',rad_avgdata%flutc_m(:)-rad_avgdata%flut_m(:) ,pcols,lchnk) - call outfld('FLN200'//' ',rad_avgdata%fln200_m(:),pcols,lchnk) - call outfld('FLN200C'//' ',rad_avgdata%fln200c_m(:),pcols,lchnk) - call outfld('FLDS'//' ',rad_avgdata%flwds_m(:) ,pcols,lchnk) - call outfld('FLNR'//' ',rad_avgdata%flnr_m(:),pcols,lchnk) - - call outfld('CRM_FLNT', rad_avgdata%crm_flnt, pcols, lchnk) - call outfld('CRM_FLNTC', rad_avgdata%crm_flntc, pcols, lchnk) - call outfld('CRM_FLNS', rad_avgdata%crm_flns, pcols, lchnk) - call outfld('CRM_FLNSC', rad_avgdata%crm_flnsc, pcols, lchnk) - - call outfld('CRM_REL', rad_avgdata%rel_crm, pcols, lchnk) - call outfld('CRM_REI', rad_avgdata%rei_crm, pcols, lchnk) - call outfld('CRM_MU', rad_avgdata%mu_crm, pcols, lchnk) - call outfld('CRM_DEI', rad_avgdata%dei_crm, pcols, lchnk) - call outfld('CRM_DES', rad_avgdata%des_crm, pcols, lchnk) - call outfld('CRM_LAMBDA', rad_avgdata%lambdac_crm, pcols, lchnk) - call outfld('CRM_TAU', rad_avgdata%cld_tau_crm, pcols, lchnk) - call outfld('CRM_QRL', rad_avgdata%qrl_crm, pcols, lchnk) - call outfld('CRM_QRS', rad_avgdata%qrs_crm, pcols, lchnk) - - - - do i=1, ncol - do k=1, pver - rad_avgdata%tot_cld_vistau_m(i,k) = rad_avgdata%tot_icld_vistau_m(i,k) * factor_xy - if(rad_avgdata%nct_tot_icld_vistau_m(i,k).ge. 0.1_r8) then - rad_avgdata%tot_icld_vistau_m(i,k) = rad_avgdata%tot_icld_vistau_m(i,k)/rad_avgdata%nct_tot_icld_vistau_m(i,k) - else - rad_avgdata%tot_icld_vistau_m(i,k) = 0.0_r8 - end if - - if(rad_avgdata%nct_liq_icld_vistau_m(i,k).ge. 0.1_r8) then - rad_avgdata%liq_icld_vistau_m(i,k) = rad_avgdata%liq_icld_vistau_m(i,k)/rad_avgdata%nct_liq_icld_vistau_m(i,k) - else - rad_avgdata%liq_icld_vistau_m(i,k) = 0.0_r8 - end if - - if(rad_avgdata%nct_ice_icld_vistau_m(i,k).ge. 0.1_r8) then - rad_avgdata%ice_icld_vistau_m(i,k) = rad_avgdata%ice_icld_vistau_m(i,k)/rad_avgdata%nct_ice_icld_vistau_m(i,k) - else - rad_avgdata%ice_icld_vistau_m(i,k) = 0.0_r8 - end if - - if(rad_avgdata%nct_snow_icld_vistau_m(i,k).ge. 0.1_r8) then - rad_avgdata%snow_icld_vistau_m(i,k) = rad_avgdata%snow_icld_vistau_m(i,k)/rad_avgdata%nct_snow_icld_vistau_m(i,k) - else - rad_avgdata%snow_icld_vistau_m(i,k) = 0.0_r8 - end if - - end do - end do - - ! Output aerosol mmr - call rad_cnst_out(0, state, pbuf) - - - ! restore to the non-spcam values - - call pbuf_get_field(pbuf, iciwp_idx, cicewp) - call pbuf_get_field(pbuf, iclwp_idx, cliqwp) - call pbuf_get_field(pbuf, icswp_idx, csnowp) - call pbuf_get_field(pbuf, rel_idx, rel) - call pbuf_get_field(pbuf, rei_idx, rei) - call pbuf_get_field(pbuf, landm_idx, landm) - call pbuf_get_field(pbuf, dei_idx, dei) - call pbuf_get_field(pbuf, mu_idx, mu) - call pbuf_get_field(pbuf, lambdac_idx, lambdac) - call pbuf_get_field(pbuf, des_idx, des) - call pbuf_get_field(pbuf, crm_qrad_idx, crm_qrad) - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - if (cldfsnow_idx > 0) then - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - endif - - if (prog_modal_aero) then - call pbuf_get_field(pbuf, dgnumwet_idx, dgnumwet, start=(/1,1,1/), kount=(/pcols,pver,nmodes/) ) - call pbuf_get_field(pbuf, qaerwat_idx, qaerwat, start=(/1,1,1/), kount=(/pcols,pver,nmodes/) ) - endif - - do m=1,crm_nz - k = pver-m+1 - do i = 1,ncol - ! for energy conservation - crm_qrad(i,:,:,m) = (rad_avgdata%qrs_crm(i,:,:,m)+rad_avgdata%qrl_crm(i,:,:,m)) * state%pdel(i,k) - end do - end do - - ! 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, rad_avgdata%qrl_m(:,:), rad_avgdata%qrs_m(:,:), rad_avgdata%fsns_m(:), & - rad_avgdata%fsnt_m(:), rad_avgdata%flns_m(:), rad_avgdata%flnt_m(:), cam_in%asdir, net_flx) - - ! Compute heating rate for dtheta/dt - do k=1,pver - do i=1,ncol - ftem(i,k) = (rad_avgdata%qrs_m(i,k) + rad_avgdata%qrl_m(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa - end do - end do - call outfld('HR ',ftem ,pcols ,lchnk ) - - ! convert radiative heating rates to Q*dp for energy conservation - call pbuf_get_field(pbuf, qrs_idx, qrs) - call pbuf_get_field(pbuf, qrl_idx, qrl) - do k =1 , pver - do i = 1, ncol - qrs(i,k) = rad_avgdata%qrs_m(i,k)*state%pdel(i,k) - qrl(i,k) = rad_avgdata%qrl_m(i,k)*state%pdel(i,k) - end do - end do - - ! Output icall=0 (climate) - cam_out%flwds(:ncol) = rad_avgdata%flwds_m(:ncol) - cam_out%netsw(:ncol) = rad_avgdata%fsns_m(:ncol) - cam_out%sols(:ncol) = rad_avgdata%sols_m(:ncol) - cam_out%soll(:ncol) = rad_avgdata%soll_m(:ncol) - cam_out%solsd(:ncol) = rad_avgdata%solsd_m(:ncol) - cam_out%solld(:ncol) = rad_avgdata%solld_m(:ncol) - - - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, flns_idx, flns) - call pbuf_get_field(pbuf, flnt_idx, flnt) - call pbuf_get_field(pbuf, fsds_idx, fsds) - fsns(:ncol) = rad_avgdata%fsns_m(:ncol) - fsnt(:ncol) = rad_avgdata%fsnt_m(:ncol) - flns(:ncol) = rad_avgdata%flns_m(:ncol) - flnt(:ncol) = rad_avgdata%flnt_m(:ncol) - fsds(:ncol) = rad_avgdata%fsds_m(:ncol) - - deallocate(rad_avgdata%solin_m) - deallocate(rad_avgdata%fsntoa_m) - deallocate(rad_avgdata%fsutoa_m) - deallocate(rad_avgdata%fsntoac_m) - deallocate(rad_avgdata%fsnirt_m) - deallocate(rad_avgdata%fsnrtc_m) - deallocate(rad_avgdata%fsnirtsq_m) - deallocate(rad_avgdata%fsntc_m) - deallocate(rad_avgdata%fsnsc_m) - deallocate(rad_avgdata%fsdsc_m) - deallocate(rad_avgdata%flut_m) - deallocate(rad_avgdata%flutc_m) - deallocate(rad_avgdata%flntc_m) - deallocate(rad_avgdata%flnsc_m) - deallocate(rad_avgdata%fldsc_m) - deallocate(rad_avgdata%flwds_m) - deallocate(rad_avgdata%fsns_m) - deallocate(rad_avgdata%fsnr_m) - deallocate(rad_avgdata%fsnt_m) - deallocate(rad_avgdata%flns_m) - deallocate(rad_avgdata%flnt_m) - deallocate(rad_avgdata%flnr_m) - deallocate(rad_avgdata%fsds_m) - deallocate(rad_avgdata%fln200_m) - deallocate(rad_avgdata%fln200c_m) - deallocate(rad_avgdata%fsn200_m) - deallocate(rad_avgdata%fsn200c_m) - deallocate(rad_avgdata%sols_m) - deallocate(rad_avgdata%soll_m) - deallocate(rad_avgdata%solsd_m) - deallocate(rad_avgdata%solld_m) - deallocate(rad_avgdata%qrs_m) - deallocate(rad_avgdata%qrl_m) - deallocate(rad_avgdata%qrsc_m) - deallocate(rad_avgdata%qrlc_m) - deallocate(rad_avgdata%rel_crm) - deallocate(rad_avgdata%rei_crm) - deallocate(rad_avgdata%cld_tau_crm) - deallocate(rad_avgdata%qrl_crm) - deallocate(rad_avgdata%qrs_crm) - deallocate(rad_avgdata%crm_fsnt) - deallocate(rad_avgdata%crm_fsntc) - deallocate(rad_avgdata%crm_fsns) - deallocate(rad_avgdata%crm_fsnsc) - deallocate(rad_avgdata%crm_flnt) - deallocate(rad_avgdata%crm_flntc) - deallocate(rad_avgdata%crm_flns) - deallocate(rad_avgdata%crm_flnsc) - deallocate(rad_avgdata%crm_swcf) - deallocate(rad_avgdata%crm_aodvisz) - deallocate(rad_avgdata%crm_aodvis) - deallocate(rad_avgdata%crm_aod400) - deallocate(rad_avgdata%crm_aod700) - deallocate(rad_avgdata%aod400) - deallocate(rad_avgdata%aod700) - - deallocate(rad_avgdata%tot_cld_vistau_m) - deallocate(rad_avgdata%tot_icld_vistau_m) - deallocate(rad_avgdata%liq_icld_vistau_m) - deallocate(rad_avgdata%ice_icld_vistau_m) - deallocate(rad_avgdata%nct_tot_icld_vistau_m) - - deallocate(rad_avgdata%nct_liq_icld_vistau_m) - deallocate(rad_avgdata%nct_ice_icld_vistau_m) - deallocate(rad_avgdata%snow_icld_vistau_m) - deallocate(rad_avgdata%nct_snow_icld_vistau_m) - - deallocate(rad_avgdata%dei_crm) - deallocate(rad_avgdata%mu_crm) - deallocate(rad_avgdata%lambdac_crm) - deallocate(rad_avgdata%des_crm) - -#endif -end subroutine spcam_radiation_finalize_m2005 - -!=============================================================================== - -subroutine spcam_radiation_col_finalize_m2005(state, ii, jj, pbuf, rd, cam_out, rad_avgdata) - - use physconst, only: cpair - use physics_buffer, only: pbuf_old_tim_idx - use radiation, only: radiation_do - use cam_history, only: hist_fld_active - - type(physics_state), intent(in) :: state - integer, intent(in) :: ii - integer, intent(in) :: jj - type(physics_buffer_desc), pointer :: pbuf(:) - type(rad_out_t), intent(in) :: rd - type(cam_out_t), intent(inout) :: cam_out - - type(rad_avgdata_type_m2005), intent(inout) :: rad_avgdata - -#ifdef m2005 - - real(r8), parameter :: cgs2mks = 1.e-3_r8 - real(r8), parameter :: factor_xy = 1._r8/dble(crm_nx*crm_ny) - - integer :: i, k, m - integer :: ncol - integer :: itim_old - - logical :: dosw, dolw - - real(r8), pointer, dimension(:,:) :: qrs, qrl, cld - real(r8), pointer, dimension(:) :: fsds, fsns, fsnt, flns, flnt - - ncol = state%ncol - - dosw = radiation_do('sw') ! do shortwave heating calc this timestep? - dolw = radiation_do('lw') ! do longwave heating calc this timestep? - - 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, qrs_idx, qrs) - call pbuf_get_field(pbuf, qrl_idx, qrl) - - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, flns_idx, flns) - call pbuf_get_field(pbuf, flnt_idx, flnt) - call pbuf_get_field(pbuf, fsds_idx, fsds) - - ! convert radiative heating rates from 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 - - do m=1,crm_nz - k = pver-m+1 - do i=1,ncol - rad_avgdata%cld_tau_crm(i,ii,jj,m)= rd%cld_tau_cloudsim(i,k) - end do ! i - end do ! m - - if (dosw) then - - do i=1, ncol - rad_avgdata%qrs_m(i,:pver) = rad_avgdata%qrs_m(i,:pver) + qrs(i,:pver) *factor_xy - rad_avgdata%fsds_m(i) = rad_avgdata%fsds_m(i) + fsds(i) *factor_xy - rad_avgdata%fsnt_m(i) = rad_avgdata%fsnt_m(i) + fsnt(i) *factor_xy - rad_avgdata%fsns_m(i) = rad_avgdata%fsns_m(i) + fsns(i) *factor_xy - rad_avgdata%qrsc_m(i,:pver) = rad_avgdata%qrsc_m(i,:pver) + rd%qrsc(i,:pver) *factor_xy - rad_avgdata%solin_m(i) = rad_avgdata%solin_m(i) + rd%solin(i) *factor_xy - rad_avgdata%fsnirt_m(i) = rad_avgdata%fsnirt_m(i) + rd%fsnirt(i) *factor_xy - rad_avgdata%fsnrtc_m(i) = rad_avgdata%fsnrtc_m(i) + rd%fsnrtc(i) *factor_xy - rad_avgdata%fsnirtsq_m(i) = rad_avgdata%fsnirtsq_m(i) + rd%fsnirtsq(i) *factor_xy - rad_avgdata%fsntc_m(i) = rad_avgdata%fsntc_m(i) + rd%fsntc(i) *factor_xy - rad_avgdata%fsnsc_m(i) = rad_avgdata%fsnsc_m(i) + rd%fsnsc(i) *factor_xy - rad_avgdata%fsdsc_m(i) = rad_avgdata%fsdsc_m(i) + rd%fsdsc(i) *factor_xy - rad_avgdata%fsntoa_m(i) = rad_avgdata%fsntoa_m(i) + rd%fsntoa(i) *factor_xy - rad_avgdata%fsutoa_m(i) = rad_avgdata%fsutoa_m(i) + rd%fsutoa(i) *factor_xy - rad_avgdata%fsntoac_m(i) = rad_avgdata%fsntoac_m(i) + rd%fsntoac(i) *factor_xy - rad_avgdata%sols_m(i) = rad_avgdata%sols_m(i) + cam_out%sols(i) *factor_xy - rad_avgdata%soll_m(i) = rad_avgdata%soll_m(i) + cam_out%soll(i) *factor_xy - rad_avgdata%solsd_m(i) = rad_avgdata%solsd_m(i) + cam_out%solsd(i) *factor_xy - rad_avgdata%solld_m(i) = rad_avgdata%solld_m(i) + cam_out%solld(i) *factor_xy - rad_avgdata%fsn200_m(i) = rad_avgdata%fsn200_m(i) + rd%fsn200(i) *factor_xy - rad_avgdata%fsn200c_m(i) = rad_avgdata%fsn200c_m(i) + rd%fsn200c(i) *factor_xy - if (hist_fld_active('FSNR')) then - rad_avgdata%fsnr_m(i) = rad_avgdata%fsnr_m(i) + rd%fsnr(i) *factor_xy - end if - rad_avgdata%crm_fsnt(i, ii, jj) = fsnt(i) - rad_avgdata%crm_fsntc(i,ii,jj) = rd%fsntc(i) - rad_avgdata%crm_fsns(i, ii, jj) = fsns(i) - rad_avgdata%crm_fsnsc(i,ii,jj) = rd%fsnsc(i) - rad_avgdata%crm_swcf(i,ii,jj) = rd%fsntoa(i) - rd%fsntoac(i) - rad_avgdata%crm_aodvis(i,ii,jj) = sum(rd%aer_tau550(i, :)) - rad_avgdata%crm_aod400(i,ii,jj) = sum(rd%aer_tau400(i, :)) - rad_avgdata%crm_aod700(i,ii,jj) = sum(rd%aer_tau700(i, :)) - rad_avgdata%aod400(i) = rad_avgdata%aod400(i)+rad_avgdata%crm_aod400(i,ii,jj) * factor_xy - rad_avgdata%aod700(i) = rad_avgdata%aod700(i)+rad_avgdata%crm_aod700(i,ii,jj) * factor_xy - end do - do m=1,crm_nz - k = pver-m+1 - rad_avgdata%qrs_crm(:ncol,ii,jj,m) = qrs(:ncol,k) / cpair - rad_avgdata%crm_aodvisz(:ncol, ii, jj, m) = rd%aer_tau550(:ncol,k) - end do - - do i=1, ncol - do k=1, pver - if(rd%tot_icld_vistau(i,k).gt.1.0e-10_r8) then - rad_avgdata%tot_icld_vistau_m(i,k) = rad_avgdata%tot_icld_vistau_m(i,k) + & - rd%tot_icld_vistau(i,k)*cld(i,k) - rad_avgdata%nct_tot_icld_vistau_m(i,k) = rad_avgdata%nct_tot_icld_vistau_m(i,k) + cld(i,k) - end if - if(rd%liq_icld_vistau(i,k).gt.1.0e-10_r8) then - rad_avgdata%liq_icld_vistau_m(i,k) = rad_avgdata%liq_icld_vistau_m(i,k) + & - rd%liq_icld_vistau(i,k)*cld(i,k) - rad_avgdata%nct_liq_icld_vistau_m(i,k) = rad_avgdata%nct_liq_icld_vistau_m(i,k) + cld(i,k) - end if - if(rd%ice_icld_vistau(i,k).gt.1.0e-10_r8) then - rad_avgdata%ice_icld_vistau_m(i,k) = rad_avgdata%ice_icld_vistau_m(i,k) + & - rd%ice_icld_vistau(i,k)*cld(i,k) - rad_avgdata%nct_ice_icld_vistau_m(i,k) = rad_avgdata%nct_ice_icld_vistau_m(i,k) + cld(i,k) - end if - if(rd%snow_icld_vistau(i,k).gt.1.0e-10_r8) then - rad_avgdata%snow_icld_vistau_m(i,k) = rad_avgdata%snow_icld_vistau_m(i,k) + & - rd%snow_icld_vistau(i,k) - rad_avgdata%nct_snow_icld_vistau_m(i,k) = rad_avgdata%nct_snow_icld_vistau_m(i,k) + 1 - end if - end do - end do - end if ! dosw - - if (dolw) then - - do i=1, ncol - rad_avgdata%qrl_m(i,:pver) = rad_avgdata%qrl_m(i,:pver) + qrl(i,:pver)*factor_xy - rad_avgdata%qrlc_m(i,:pver) = rad_avgdata%qrlc_m(i,:pver) + rd%qrlc(i,:pver)*factor_xy - rad_avgdata%flnt_m(i) = rad_avgdata%flnt_m(i) + flnt(i) *factor_xy - rad_avgdata%flut_m(i) = rad_avgdata%flut_m(i)+rd%flut(i) *factor_xy - rad_avgdata%flutc_m(i) = rad_avgdata%flutc_m(i)+rd%flutc(i) *factor_xy - rad_avgdata%flntc_m(i) = rad_avgdata%flntc_m(i)+rd%flntc(i) *factor_xy - rad_avgdata%flns_m(i) = rad_avgdata%flns_m(i) + flns(i) *factor_xy - rad_avgdata%flnsc_m(i) = rad_avgdata%flnsc_m(i)+rd%flnsc(i) *factor_xy - rad_avgdata%fldsc_m(i) = rad_avgdata%fldsc_m(i)+rd%fldsc(i) *factor_xy - rad_avgdata%flwds_m(i) = rad_avgdata%flwds_m(i)+cam_out%flwds(i) *factor_xy - rad_avgdata%fln200_m(i) = rad_avgdata%fln200_m(i)+rd%fln200(i) *factor_xy - rad_avgdata%fln200c_m(i) = rad_avgdata%fln200c_m(i)+rd%fln200c(i) *factor_xy - if (hist_fld_active('FLNR')) then - rad_avgdata%flnr_m(i) = rad_avgdata%flnr_m(i)+rd%flnr(i) *factor_xy - end if - - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, flns_idx, flns) - call pbuf_get_field(pbuf, flnt_idx, flnt) - call pbuf_get_field(pbuf, fsds_idx, fsds) - - rad_avgdata%crm_flnt(i, ii, jj) = flnt(i) - rad_avgdata%crm_flntc(i,ii,jj) = rd%flntc(i) - rad_avgdata%crm_flns(i, ii, jj) = flns(i) - rad_avgdata%crm_flnsc(i,ii,jj) = rd%flnsc(i) - do m=1,crm_nz - k = pver-m+1 - rad_avgdata%qrl_crm(:ncol,ii,jj,m) = qrl(:ncol,k) / cpair - end do - - end do - - end if !dolw - - -#endif - -end subroutine spcam_radiation_col_finalize_m2005 - -!=============================================================================== - -subroutine spcam_radiation_setup_sam1mom(cam_in, cldn, state, pbuf, rad_avgdata, state_loc) - - use physics_buffer, only: physics_buffer_desc, pbuf_get_field - use physics_buffer, only: pbuf_old_tim_idx - - type(cam_in_t), intent(in) :: cam_in - real(r8), dimension(:,:), intent(out) :: cldn - type(physics_state), intent(in) :: state - type(physics_buffer_desc), intent(inout), pointer :: pbuf(:) - - type(rad_avgdata_type_sam1mom) :: rad_avgdata - type(physics_state), intent(inout) :: state_loc - -#ifdef sam1mom - real(r8),pointer :: emis(:,:) ! Cloud longwave emissivity - real(r8),pointer :: cldtau(:,:) ! Cloud longwave optical depth - real(r8),pointer :: cicewp(:,:) ! in-cloud cloud ice water path - real(r8),pointer :: cliqwp(:,:) ! in-cloud cloud liquid water path - - real(r8), pointer, dimension(:,:) :: rel ! liquid effective drop radius (microns) - real(r8), pointer, dimension(:,:) :: rei ! ice effective drop size (microns) - real(r8), pointer, dimension(:,:) :: cld - real(r8), pointer, dimension(:) :: landm ! land fraction ramp - - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: itim_old - - ncol = state%ncol - lchnk = state%lchnk - - - call physics_state_copy(state, state_loc) - - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - ! Save the grid level cld values as cld will be overwritten with each crm-scale level value during radiation - cldn = cld - - allocate(rad_avgdata%solin_m (pcols)) - allocate(rad_avgdata%fsntoa_m (pcols)) - allocate(rad_avgdata%fsutoa_m (pcols)) - allocate(rad_avgdata%fsntoac_m (pcols)) - allocate(rad_avgdata%fsnirt_m (pcols)) - allocate(rad_avgdata%fsnrtc_m (pcols)) - allocate(rad_avgdata%fsnirtsq_m (pcols)) - allocate(rad_avgdata%fsntc_m (pcols)) - allocate(rad_avgdata%fsnsc_m (pcols)) - allocate(rad_avgdata%fsdsc_m (pcols)) - allocate(rad_avgdata%flut_m (pcols)) - allocate(rad_avgdata%flutc_m (pcols)) - allocate(rad_avgdata%flntc_m (pcols)) - allocate(rad_avgdata%flnsc_m (pcols)) - allocate(rad_avgdata%fldsc_m (pcols)) - allocate(rad_avgdata%flwds_m (pcols)) - allocate(rad_avgdata%fsns_m (pcols)) - allocate(rad_avgdata%fsnr_m (pcols)) - allocate(rad_avgdata%fsnt_m (pcols)) - allocate(rad_avgdata%flns_m (pcols)) - allocate(rad_avgdata%flnt_m (pcols)) - allocate(rad_avgdata%flnr_m (pcols)) - allocate(rad_avgdata%fsds_m (pcols)) - allocate(rad_avgdata%fln200_m (pcols)) - allocate(rad_avgdata%fln200c_m (pcols)) - allocate(rad_avgdata%fsn200_m (pcols)) - allocate(rad_avgdata%fsn200c_m (pcols)) - allocate(rad_avgdata%sols_m (pcols)) - allocate(rad_avgdata%soll_m (pcols)) - allocate(rad_avgdata%solsd_m (pcols)) - allocate(rad_avgdata%solld_m (pcols)) - allocate(rad_avgdata%qrs_m (pcols,pver)) - allocate(rad_avgdata%qrl_m (pcols,pver)) - allocate(rad_avgdata%qrsc_m (pcols,pver)) - allocate(rad_avgdata%qrlc_m (pcols,pver)) - allocate(rad_avgdata%rel_crm (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%rei_crm (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%cld_tau_crm (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%qrl_crm (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%qrs_crm (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%crm_fsnt (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_fsntc (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_fsns (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_fsnsc (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_flnt (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_flntc (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_flns (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_flnsc (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_swcf (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_aodvisz (pcols, crm_nx, crm_ny, crm_nz)) - allocate(rad_avgdata%crm_aodvis (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_aod400 (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%crm_aod700 (pcols, crm_nx, crm_ny)) - allocate(rad_avgdata%aod400 (pcols)) - allocate(rad_avgdata%aod700 (pcols)) - allocate(rad_avgdata%fsdtoa_m (pcols)) - allocate(rad_avgdata%flds_m (pcols)) - - allocate(rad_avgdata%tot_cld_vistau_m ( pcols,pver)) - allocate(rad_avgdata%tot_icld_vistau_m (pcols,pver)) - allocate(rad_avgdata%liq_icld_vistau_m (pcols,pver)) - allocate(rad_avgdata%ice_icld_vistau_m (pcols,pver)) - allocate(rad_avgdata%nct_tot_icld_vistau_m(pcols,pver)) - allocate(rad_avgdata%nct_liq_icld_vistau_m(pcols,pver)) - allocate(rad_avgdata%nct_ice_icld_vistau_m(pcols,pver)) - - call pbuf_get_field(pbuf, rel_idx, rel) - call pbuf_get_field(pbuf, rei_idx, rei) - call pbuf_get_field(pbuf, landm_idx, landm) - call pbuf_get_field(pbuf, crm_t_rad_idx, rad_avgdata%t_rad) - call pbuf_get_field(pbuf, crm_qc_rad_idx, rad_avgdata%qc_rad) - call pbuf_get_field(pbuf, crm_qi_rad_idx, rad_avgdata%qi_rad) - call pbuf_get_field(pbuf, crm_qv_rad_idx, rad_avgdata%qv_rad) - call pbuf_get_field(pbuf, crm_qrad_idx, rad_avgdata%crm_qrad) - - - ! pbuf cloud properties set in cloud_diagnostics - call pbuf_get_field(pbuf, cicewp_idx, cicewp) - call pbuf_get_field(pbuf, cliqwp_idx, cliqwp) - call pbuf_get_field(pbuf, cldemis_idx, emis) - call pbuf_get_field(pbuf, cldtau_idx, cldtau) - - - rad_avgdata%solin_m = 0._r8 - rad_avgdata%fsntoa_m = 0._r8 - rad_avgdata%fsutoa_m = 0._r8 - rad_avgdata%fsntoac_m = 0._r8 - rad_avgdata%fsnirt_m = 0._r8 - rad_avgdata%fsnrtc_m = 0._r8 - rad_avgdata%fsnirtsq_m = 0._r8 - rad_avgdata%fsntc_m = 0._r8 - rad_avgdata%fsdtoa_m = 0._r8 - rad_avgdata%fsnsc_m = 0._r8 - rad_avgdata%fsdsc_m = 0._r8 - rad_avgdata%flut_m = 0._r8 - rad_avgdata%flutc_m = 0._r8 - rad_avgdata%flntc_m = 0._r8 - rad_avgdata%flnsc_m = 0._r8 - rad_avgdata%flds_m = 0._r8 - rad_avgdata%fldsc_m = 0._r8 - rad_avgdata%fsns_m = 0._r8 - rad_avgdata%fsnt_m = 0._r8 - rad_avgdata%flns_m = 0._r8 - rad_avgdata%flnt_m = 0._r8 - rad_avgdata%flnr_m = 0._r8 - rad_avgdata%fsds_m = 0._r8 - rad_avgdata%fsnr_m = 0._r8 - rad_avgdata%fln200_m = 0._r8 - rad_avgdata%fln200c_m = 0._r8 - rad_avgdata%fsn200_m = 0._r8 - rad_avgdata%fsn200c_m = 0._r8 - rad_avgdata%sols_m = 0._r8 - rad_avgdata%soll_m = 0._r8 - rad_avgdata%solsd_m = 0._r8 - rad_avgdata%solld_m = 0._r8 - rad_avgdata%qrs_m = 0._r8 - rad_avgdata%qrl_m = 0._r8 - rad_avgdata%qrsc_m = 0._r8 - rad_avgdata%qrlc_m = 0._r8 - rad_avgdata%qrs_crm = 0._r8 - rad_avgdata%qrl_crm = 0._r8 - - rad_avgdata%tot_cld_vistau_m =0._r8 - rad_avgdata%tot_icld_vistau_m=0._r8 ; rad_avgdata%nct_tot_icld_vistau_m=0._r8 - rad_avgdata%liq_icld_vistau_m=0._r8 ; rad_avgdata%nct_liq_icld_vistau_m=0._r8 - rad_avgdata%ice_icld_vistau_m=0._r8 ; rad_avgdata%nct_ice_icld_vistau_m=0._r8 - - - ! Compute effective sizes - call cldefr(lchnk, ncol, cam_in%landfrac, state%t, rel, rei, state%ps, state%pmid, landm, cam_in%icefrac, cam_in%snowhland) - - cicewp(1:ncol,1:pver) = 0._r8 - cliqwp(1:ncol,1:pver) = 0._r8 - -#endif -end subroutine spcam_radiation_setup_sam1mom - -!=============================================================================== - -subroutine spcam_radiation_col_setup_sam1mom(ii, jj, state_loc, pbuf, rad_avgdata) - - use physics_buffer, only: pbuf_old_tim_idx - use physconst, only: gravit - - integer,intent(in) :: ii,jj - - type(physics_state), intent(inout) :: state_loc - type(physics_buffer_desc), intent(inout), pointer :: pbuf(:) - type(rad_avgdata_type_sam1mom), intent(inout) :: rad_avgdata - -#ifdef sam1mom - - real(r8),pointer :: emis(:,:) ! Cloud longwave emissivity - real(r8),pointer :: cldtau(:,:) ! Cloud longwave optical depth - real(r8),pointer :: cicewp(:,:) ! in-cloud cloud ice water path - real(r8),pointer :: cliqwp(:,:) ! in-cloud cloud liquid water path - - real(r8), pointer, dimension(:,:) :: rel ! liquid effective drop radius (microns) - real(r8), pointer, dimension(:,:) :: rei ! ice effective drop size (microns) - real(r8), pointer, dimension(:,:,:,:) :: cld_rad ! rad cloud fraction - real(r8), pointer, dimension(:,:) :: pmxrgn ! Maximum values of pressure for each - ! maximally overlapped region. - ! 0->pmxrgn(i,1) is range of pressure for - ! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for - ! 2nd region, etc - integer, pointer, dimension(:) :: nmxrgn ! pbuf pointer to Number of maximally overlapped regions - - real(r8) :: qtot - real(r8), dimension(pcols,pver) :: fice - real(r8), dimension(pcols,pver) :: tmp - real(r8), pointer, dimension(:,:) :: cld ! cloud fraction - - integer :: itim_old - integer :: m, k, i - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - - lchnk = state_loc%lchnk - ncol = state_loc%ncol - - 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, pmxrgn_idx, pmxrgn) - call pbuf_get_field(pbuf, nmxrgn_idx, nmxrgn) - call pbuf_get_field(pbuf, rel_idx, rel) - call pbuf_get_field(pbuf, rei_idx, rei) - call pbuf_get_field(pbuf, crm_cld_rad_idx, cld_rad) - - call pbuf_get_field(pbuf, crm_t_rad_idx, rad_avgdata%t_rad) - call pbuf_get_field(pbuf, crm_qc_rad_idx, rad_avgdata%qc_rad) - call pbuf_get_field(pbuf, crm_qi_rad_idx, rad_avgdata%qi_rad) - call pbuf_get_field(pbuf, crm_qv_rad_idx, rad_avgdata%qv_rad) - call pbuf_get_field(pbuf, crm_qrad_idx, rad_avgdata%crm_qrad) - - - ! pbuf cloud properties set in cloud_diagnostics - call pbuf_get_field(pbuf, cicewp_idx, cicewp) - call pbuf_get_field(pbuf, cliqwp_idx, cliqwp) - call pbuf_get_field(pbuf, cldemis_idx, emis) - call pbuf_get_field(pbuf, cldtau_idx, cldtau) - - fice(1:ncol,1:pver-crm_nz) = 0._r8 - - do m=1,crm_nz - k = pver-m+1 - do i=1,ncol - - qtot = rad_avgdata%qc_rad(i,ii,jj,m) + rad_avgdata%qi_rad(i,ii,jj,m) - if(qtot.gt.1.e-9_r8) then - fice(i,k) = rad_avgdata%qi_rad(i,ii,jj,m)/qtot - ! In case CRM produces fractional cloudiness - cld(i,k) = min(0.99_r8, cld_rad(i,ii,jj,m)) - - cicewp(i,k) = rad_avgdata%qi_rad(i,ii,jj,m)*state_loc%pdel(i,k)/gravit*1000.0_r8 & - / max(0.01_r8,cld(i,k)) ! In-cloud ice water path. - cliqwp(i,k) = rad_avgdata%qc_rad(i,ii,jj,m)*state_loc%pdel(i,k)/gravit*1000.0_r8 & - / max(0.01_r8,cld(i,k)) ! In-cloud liquid water path. - else - fice(i,k)=0._r8 - cld(i,k)=0._r8 - cicewp(i,k) = 0._r8 ! In-cloud ice water path. - cliqwp(i,k) = 0._r8 ! In-cloud liquid water path. - end if - end do ! i - end do ! m - - ! Cloud emissivity. - - tmp(:ncol,:) = cicewp(:ncol,:) + cliqwp(:ncol,:) - call cldems(lchnk, ncol, tmp, fice, rei, emis, cldtau) - - call cldovrlap(lchnk, ncol, state_loc%pint, cld, nmxrgn, pmxrgn) - - ! Setup the trad and qvrad variables (now in state) - do m=1,crm_nz - k = pver-m+1 - do i=1,ncol - state_loc%q(i,k,1) = max(1.e-9_r8,rad_avgdata%qv_rad(i,ii,jj,m)) - state_loc%t(i,k) = rad_avgdata%t_rad(i,ii,jj,m) - end do - end do - - -#endif -end subroutine spcam_radiation_col_setup_sam1mom - -!=============================================================================== - -subroutine spcam_radiation_finalize_sam1mom(cam_in, state, pbuf, rad_avgdata, cam_out, cldn, net_flx, ptend) - - use physconst, only: cpair - use rad_constituents,only: rad_cnst_out - - use physconst, only: cappa - use radiation_data, only: rad_data_write - use radheat, only: radheat_tend - use time_manager, only: get_curr_calday - use physics_buffer, only: pbuf_old_tim_idx - use orbit, only: zenith - - type(cam_in_t), intent(in) :: cam_in - type(physics_state), intent(in) :: state - - - type(physics_buffer_desc), intent(inout), pointer :: pbuf(:) - type(rad_avgdata_type_sam1mom), intent(inout) :: rad_avgdata - type(cam_out_t), intent(inout) :: cam_out - real(r8), dimension(:,:), intent(in) :: cldn - real(r8), intent(inout) :: net_flx(pcols) - - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - -#ifdef sam1mom - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: i, k, m - real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables - - real(r8), pointer, dimension(:,:) :: qrs, qrl, cld - 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 :: fsds(:) ! Surface solar down flux - - - - real(r8) :: calday ! current calendar day - real(r8) :: clat(pcols) ! current latitudes(radians) - real(r8) :: clon(pcols) ! current longitudes(radians) - real(r8) :: coszrs(pcols) ! Cosine solar zenith angle - real(r8) :: factor_xy - - integer :: Nday ! Number of daylight columns - integer :: Nnite ! Number of night columns - integer, dimension(pcols) :: IdxDay ! Indicies of daylight coumns - integer, dimension(pcols) :: IdxNite ! Indicies of night coumns - integer :: itim_old - - lchnk = state%lchnk - ncol = state%ncol - - call pbuf_get_field(pbuf, qrs_idx, qrs) - call pbuf_get_field(pbuf, qrl_idx, qrl) - - factor_xy = 1._r8/dble(crm_nx*crm_ny) - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - ! Reassign the grid level cld values since cld was overwritten with each crm-scale level value during radiation - cld = cldn - - - do m=1,crm_nz - k = pver-m+1 - do i = 1,ncol - ! for energy conservation - rad_avgdata%crm_qrad(i,:,:,m) = (rad_avgdata%qrs_crm(i,:,:,m)+rad_avgdata%qrl_crm(i,:,:,m)) * state%pdel(i,k) - end do - end do - - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, flns_idx, flns) - call pbuf_get_field(pbuf, flnt_idx, flnt) - call pbuf_get_field(pbuf, fsds_idx, fsds) - - fsns = rad_avgdata%fsns_m(:) - fsnt = rad_avgdata%fsnt_m(:) - flns = rad_avgdata%flns_m(:) - flnt = rad_avgdata%flnt_m(:) - fsds = rad_avgdata%fsds_m(:) - - calday = get_curr_calday() - - ! 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) - - ! 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 - - cam_out%sols(:ncol) = rad_avgdata%sols_m(:ncol) - cam_out%soll(:ncol) = rad_avgdata%soll_m(:ncol) - cam_out%solsd(:ncol) = rad_avgdata%solsd_m(:ncol) - cam_out%solld(:ncol) = rad_avgdata%solld_m(:ncol) - - call outfld('CRM_QRS ',rad_avgdata%qrs_crm,pcols,lchnk) - call outfld('QRS ',rad_avgdata%qrs_m(:,:)/cpair ,pcols,lchnk) - call outfld('QRSC ',rad_avgdata%qrsc_m/cpair,pcols,lchnk) - call outfld('SOLIN ',rad_avgdata%solin_m(:) ,pcols,lchnk) - call outfld('FSDS ',rad_avgdata%fsds_m(:) ,pcols,lchnk) - call outfld('FSNIRTOA',rad_avgdata%fsnirt_m(:),pcols,lchnk) - call outfld('FSNRTOAC',rad_avgdata%fsnrtc_m(:),pcols,lchnk) - call outfld('FSNRTOAS',rad_avgdata%fsnirtsq_m(:),pcols,lchnk) - call outfld('FSNT ',rad_avgdata%fsnt_m(:) ,pcols,lchnk) - call outfld('FSDTOA ',rad_avgdata%fsdtoa_m(:),pcols,lchnk) - call outfld('FSNS ',rad_avgdata%fsns_m(:) ,pcols,lchnk) - call outfld('FSNTC ',rad_avgdata%fsntc_m(:) ,pcols,lchnk) - call outfld('FSNSC ',rad_avgdata%fsnsc_m(:) ,pcols,lchnk) - call outfld('FSDSC ',rad_avgdata%fsdsc_m(:) ,pcols,lchnk) - call outfld('FSNTOA ',rad_avgdata%fsntoa_m(:),pcols,lchnk) - call outfld('FSUTOA ',rad_avgdata%fsutoa_m(:),pcols,lchnk) - call outfld('FSNTOAC ',rad_avgdata%fsntoac_m(:),pcols,lchnk) - call outfld('SOLS ',cam_out%sols ,pcols,lchnk) - call outfld('SOLL ',cam_out%soll ,pcols,lchnk) - call outfld('SOLSD ',cam_out%solsd ,pcols,lchnk) - call outfld('SOLLD ',cam_out%solld ,pcols,lchnk) - call outfld('FSN200 ',rad_avgdata%fsn200_m(:),pcols,lchnk) - call outfld('FSN200C ',rad_avgdata%fsn200c_m(:),pcols,lchnk) - call outfld('FSNR' ,rad_avgdata%fsnr_m(:) ,pcols,lchnk) - call outfld('SWCF ',rad_avgdata%fsntoa_m(:ncol)-rad_avgdata%fsntoac_m(:ncol) ,ncol,lchnk) - - do i=1, Nday - do k=1, pver - rad_avgdata%tot_cld_vistau_m(IdxDay(i),k) = rad_avgdata%tot_icld_vistau_m(IdxDay(i),k) * factor_xy - if(rad_avgdata%nct_tot_icld_vistau_m(IdxDay(i),k).ge. 0.1_r8) then - rad_avgdata%tot_icld_vistau_m(IdxDay(i),k) = rad_avgdata%tot_icld_vistau_m(IdxDay(i),k)/& - rad_avgdata%nct_tot_icld_vistau_m(IdxDay(i),k) - else - rad_avgdata%tot_icld_vistau_m(IdxDay(i),k) = 0.0_r8 - end if - if(rad_avgdata%nct_liq_icld_vistau_m(IdxDay(i),k).ge. 0.1_r8) then - rad_avgdata%liq_icld_vistau_m(IdxDay(i),k) = rad_avgdata%liq_icld_vistau_m(IdxDay(i),k)/& - rad_avgdata%nct_liq_icld_vistau_m(IdxDay(i),k) - else - rad_avgdata%liq_icld_vistau_m(IdxDay(i),k) = 0.0_r8 - end if - if(rad_avgdata%nct_ice_icld_vistau_m(IdxDay(i),k).ge. 0.1_r8) then - rad_avgdata%ice_icld_vistau_m(IdxDay(i),k) = rad_avgdata%ice_icld_vistau_m(IdxDay(i),k)/& - rad_avgdata%nct_ice_icld_vistau_m(IdxDay(i),k) - else - rad_avgdata%ice_icld_vistau_m(IdxDay(i),k) = 0.0_r8 - end if - end do - end do - - ! add fillvalue for night columns - do i = 1, Nnite - rad_avgdata%tot_cld_vistau_m(IdxNite(i),:) = fillvalue - rad_avgdata%tot_icld_vistau_m(IdxNite(i),:) = fillvalue - rad_avgdata%liq_icld_vistau_m(IdxNite(i),:) = fillvalue - rad_avgdata%ice_icld_vistau_m(IdxNite(i),:) = fillvalue - end do - - call outfld ('TOT_CLD_VISTAU ',rad_avgdata%tot_cld_vistau_m ,pcols,lchnk) - call outfld ('TOT_ICLD_VISTAU ',rad_avgdata%tot_icld_vistau_m ,pcols,lchnk) - call outfld ('LIQ_ICLD_VISTAU ',rad_avgdata%liq_icld_vistau_m ,pcols,lchnk) - call outfld ('ICE_ICLD_VISTAU ',rad_avgdata%ice_icld_vistau_m ,pcols,lchnk) - - - ! Longwave - cam_out%flwds(:) = rad_avgdata%flds_m(:) - call outfld('CRM_QRL ',rad_avgdata%qrl_crm, pcols, lchnk) - call outfld('QRL ',rad_avgdata%qrl_m(:ncol,:)/cpair, ncol, lchnk) - call outfld('QRLC ',rad_avgdata%qrlc_m(:ncol,:)/cpair, ncol, lchnk) - call outfld('FLNT ',rad_avgdata%flnt_m , pcols, lchnk) - call outfld('FLUT ',rad_avgdata%flut_m, pcols, lchnk) - call outfld('FLUTC ',rad_avgdata%flutc_m, pcols, lchnk) - call outfld('FLNTC ',rad_avgdata%flntc_m, pcols, lchnk) - call outfld('FLNS ',rad_avgdata%flns_m, pcols, lchnk) - call outfld('FLDS ',rad_avgdata%flds_m, pcols, lchnk) - call outfld('FLNSC ',rad_avgdata%flnsc_m, pcols, lchnk) - call outfld('FLDSC ',rad_avgdata%fldsc_m, pcols, lchnk) - call outfld('LWCF ',rad_avgdata%flutc_m-rad_avgdata%flut_m, pcols, lchnk) - call outfld('FLN200 ',rad_avgdata%fln200_m, pcols, lchnk) - call outfld('FLN200C ',rad_avgdata%fln200c_m, pcols, lchnk) - call outfld('FLNR ' ,rad_avgdata%flnr_m, pcols, lchnk) - - ! Output aerosol mmr - call rad_cnst_out(0, state, pbuf) - - ! 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, rad_avgdata%qrl_m, rad_avgdata%qrs_m, rad_avgdata%fsns_m, & - rad_avgdata%fsnt_m, rad_avgdata%flns_m, rad_avgdata%flnt_m, cam_in%asdir, net_flx) - - ! Compute heating rate for dtheta/dt - do k=1,pver - do i=1,ncol - ftem(i,k) = (rad_avgdata%qrs_m(i,k) + rad_avgdata%qrl_m(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa - end do - end do - call outfld('HR ',ftem ,pcols ,lchnk ) - - do k =1 , pver - do i = 1, ncol - qrs(i,k) = rad_avgdata%qrs_m(i,k)*state%pdel(i,k) - qrl(i,k) = rad_avgdata%qrl_m(i,k)*state%pdel(i,k) - end do - end do - - cam_out%netsw(:ncol) = rad_avgdata%fsns_m(:ncol) - cam_out%flwds(:ncol) = rad_avgdata%flds_m(:ncol) - - deallocate(rad_avgdata%solin_m) - deallocate(rad_avgdata%fsntoa_m) - deallocate(rad_avgdata%fsutoa_m) - deallocate(rad_avgdata%fsntoac_m) - deallocate(rad_avgdata%fsnirt_m) - deallocate(rad_avgdata%fsnrtc_m) - deallocate(rad_avgdata%fsnirtsq_m) - deallocate(rad_avgdata%fsntc_m) - deallocate(rad_avgdata%fsnsc_m) - deallocate(rad_avgdata%fsdsc_m) - deallocate(rad_avgdata%flut_m) - deallocate(rad_avgdata%flutc_m) - deallocate(rad_avgdata%flntc_m) - deallocate(rad_avgdata%flnsc_m) - deallocate(rad_avgdata%fldsc_m) - deallocate(rad_avgdata%flwds_m) - deallocate(rad_avgdata%fsns_m) - deallocate(rad_avgdata%fsnr_m) - deallocate(rad_avgdata%fsnt_m) - deallocate(rad_avgdata%flns_m) - deallocate(rad_avgdata%flnt_m) - deallocate(rad_avgdata%flnr_m) - deallocate(rad_avgdata%fsds_m) - deallocate(rad_avgdata%fln200_m) - deallocate(rad_avgdata%fln200c_m) - deallocate(rad_avgdata%fsn200_m) - deallocate(rad_avgdata%fsn200c_m) - deallocate(rad_avgdata%sols_m) - deallocate(rad_avgdata%soll_m) - deallocate(rad_avgdata%solsd_m) - deallocate(rad_avgdata%solld_m) - deallocate(rad_avgdata%qrs_m) - deallocate(rad_avgdata%qrl_m) - deallocate(rad_avgdata%qrsc_m) - deallocate(rad_avgdata%qrlc_m) - deallocate(rad_avgdata%rel_crm) - deallocate(rad_avgdata%rei_crm) - deallocate(rad_avgdata%cld_tau_crm) - deallocate(rad_avgdata%qrl_crm) - deallocate(rad_avgdata%qrs_crm) - deallocate(rad_avgdata%crm_fsnt) - deallocate(rad_avgdata%crm_fsntc) - deallocate(rad_avgdata%crm_fsns) - deallocate(rad_avgdata%crm_fsnsc) - deallocate(rad_avgdata%crm_flnt) - deallocate(rad_avgdata%crm_flntc) - deallocate(rad_avgdata%crm_flns) - deallocate(rad_avgdata%crm_flnsc) - deallocate(rad_avgdata%crm_swcf) - deallocate(rad_avgdata%crm_aodvisz) - deallocate(rad_avgdata%crm_aodvis) - deallocate(rad_avgdata%crm_aod400) - deallocate(rad_avgdata%crm_aod700) - deallocate(rad_avgdata%aod400) - deallocate(rad_avgdata%aod700) - deallocate(rad_avgdata%fsdtoa_m) - deallocate(rad_avgdata%flds_m) - - deallocate(rad_avgdata%tot_cld_vistau_m) - deallocate(rad_avgdata%tot_icld_vistau_m) - deallocate(rad_avgdata%liq_icld_vistau_m) - deallocate(rad_avgdata%ice_icld_vistau_m) - deallocate(rad_avgdata%nct_tot_icld_vistau_m) - deallocate(rad_avgdata%nct_liq_icld_vistau_m) - deallocate(rad_avgdata%nct_ice_icld_vistau_m) -#endif - -end subroutine spcam_radiation_finalize_sam1mom - -subroutine spcam_radiation_col_finalize_sam1mom(state, ii, jj, pbuf, rd, cam_out, rad_avgdata) - - use physconst, only: cpair - use physics_buffer, only: pbuf_old_tim_idx - use orbit, only: zenith - use time_manager, only: get_curr_calday - use radiation, only: radiation_do - - type(physics_state), intent(in) :: state - integer, intent(in) :: ii - integer, intent(in) :: jj - type(physics_buffer_desc), pointer :: pbuf(:) - type(rad_out_t), intent(in) :: rd - type(cam_out_t), intent(inout) :: cam_out - - real(r8), parameter :: cgs2mks = 1.e-3_r8 - - type(rad_avgdata_type_sam1mom), intent(inout) :: rad_avgdata - -#ifdef sam1mom - - 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 :: fsds(:) ! Surface solar down flux - - integer :: itim_old - integer :: ncol - integer :: i, m, k, lchnk - - - logical :: dosw, dolw - integer :: Nday ! Number of daylight columns - integer :: Nnite ! Number of night columns - integer, dimension(pcols) :: IdxDay ! Indicies of daylight coumns - - - real(r8) :: calday ! current calendar day - real(r8) :: clat(pcols) ! current latitudes(radians) - real(r8) :: clon(pcols) ! current longitudes(radians) - real(r8) :: coszrs(pcols) ! Cosine solar zenith angle - real(r8) :: factor_xy - - real(r8), pointer, dimension(:,:) :: cld - real(r8), pointer, dimension(:,:) :: qrs - real(r8), pointer, dimension(:,:) :: qrl - - ncol = state%ncol - lchnk = state%lchnk - - calday = get_curr_calday() - - ! 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) - - ! 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 - end if - end do - - dosw = radiation_do('sw') ! do shortwave heating calc this timestep? - dolw = radiation_do('lw') ! do longwave heating calc this timestep? - - factor_xy = 1._r8/dble(crm_nx*crm_ny) - - 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, qrs_idx,qrs) - call pbuf_get_field(pbuf, qrl_idx,qrl) - call pbuf_get_field(pbuf, qrl_idx,qrl) - - ! convert radiative heating rates from 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 - - if (dosw) then - call pbuf_get_field(pbuf, fsds_idx, fsds) - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - do i=1,ncol - rad_avgdata%fsds_m(i) = rad_avgdata%fsds_m(i) +fsds(i) *factor_xy - rad_avgdata%fsns_m(i) = rad_avgdata%fsns_m(i) +fsns(i) *factor_xy - rad_avgdata%fsnt_m(i) = rad_avgdata%fsnt_m(i) +fsnt(i) *factor_xy - - rad_avgdata%solin_m(i) = rad_avgdata%solin_m(i) +rd%solin(i)*factor_xy - rad_avgdata%fsnirt_m(i) = rad_avgdata%fsnirt_m(i) +rd%fsnirt(i)*factor_xy - rad_avgdata%fsnrtc_m(i) = rad_avgdata%fsnrtc_m(i) +rd%fsnrtc(i)*factor_xy - rad_avgdata%fsnirtsq_m(i)= rad_avgdata%fsnirtsq_m(i)+rd%fsnirtsq(i)*factor_xy - rad_avgdata%fsdtoa_m(i) = rad_avgdata%fsdtoa_m(i) +rd%fsdtoa(i)*factor_xy - rad_avgdata%fsntc_m(i) = rad_avgdata%fsntc_m(i) +rd%fsntc(i)*factor_xy - rad_avgdata%fsnsc_m(i) = rad_avgdata%fsnsc_m(i) +rd%fsnsc(i)*factor_xy - rad_avgdata%fsdsc_m(i) = rad_avgdata%fsdsc_m(i) +rd%fsdsc(i)*factor_xy - rad_avgdata%fsntoa_m(i) = rad_avgdata%fsntoa_m(i) +rd%fsntoa(i)*factor_xy - rad_avgdata%fsutoa_m(i) = rad_avgdata%fsutoa_m(i) +rd%fsutoa(i)*factor_xy - rad_avgdata%fsntoac_m(i) = rad_avgdata%fsntoac_m(i) +rd%fsntoac(i)*factor_xy - - ! sols, soll, solsd, solld have unit of mks, so no conversion is needed - rad_avgdata%sols_m(i) = rad_avgdata%sols_m(i) +cam_out%sols(i) *factor_xy - rad_avgdata%soll_m(i) = rad_avgdata%soll_m(i) +cam_out%soll(i) *factor_xy - rad_avgdata%solsd_m(i) = rad_avgdata%solsd_m(i) +cam_out%solsd(i) *factor_xy - rad_avgdata%solld_m(i) = rad_avgdata%solld_m(i) +cam_out%solld(i) *factor_xy - - rad_avgdata%fsn200_m(i) = rad_avgdata%fsn200_m(i) +rd%fsn200(i) *factor_xy - rad_avgdata%fsn200c_m(i) = rad_avgdata%fsn200c_m(i) +rd%fsn200c(i) *factor_xy - rad_avgdata%fsnr_m(i) = rad_avgdata%fsnr_m(i) +rd%fsnr(i) *factor_xy - end do - rad_avgdata%qrs_m(:ncol,:pver) = rad_avgdata%qrs_m(:ncol,:pver) + qrs(:ncol,:pver) *factor_xy - rad_avgdata%qrsc_m(:ncol,:pver) = rad_avgdata%qrsc_m(:ncol,:pver) + rd%qrsc(:ncol,:pver)*factor_xy - do m=1,crm_nz - k = pver-m+1 - rad_avgdata%qrs_crm(:ncol,ii,jj,m) = qrs(:ncol,k) / cpair - end do - do i=1, Nday - do k=1, pver - if((rd%liq_icld_vistau(IdxDay(i),k)+rd%ice_icld_vistau(IdxDay(i),k)).gt.1.0e-10_r8) then - rad_avgdata%tot_icld_vistau_m(IdxDay(i),k) = rad_avgdata%tot_icld_vistau_m(IdxDay(i),k) + & - (rd%liq_icld_vistau(IdxDay(i),k)+rd%ice_icld_vistau(IdxDay(i),k)) * cld(i,k) - rad_avgdata%nct_tot_icld_vistau_m(IdxDay(i),k) = rad_avgdata%nct_tot_icld_vistau_m(IdxDay(i),k) + cld(i,k) - end if - if(rd%liq_icld_vistau(IdxDay(i),k).gt.1.0e-10_r8) then - rad_avgdata%liq_icld_vistau_m(IdxDay(i),k) = rad_avgdata%liq_icld_vistau_m(IdxDay(i),k) + & - rd%liq_icld_vistau(IdxDay(i),k) * cld(i,k) - rad_avgdata%nct_liq_icld_vistau_m(IdxDay(i),k) = rad_avgdata%nct_liq_icld_vistau_m(IdxDay(i),k) + cld(i,k) - end if - if(rd%ice_icld_vistau(IdxDay(i),k).gt.1.0e-10_r8) then - rad_avgdata%ice_icld_vistau_m(IdxDay(i),k) = rad_avgdata%ice_icld_vistau_m(IdxDay(i),k) + & - rd%ice_icld_vistau(IdxDay(i),k) * cld(i,k) - rad_avgdata%nct_ice_icld_vistau_m(IdxDay(i),k) = rad_avgdata%nct_ice_icld_vistau_m(IdxDay(i),k) + cld(i,k) - end if - end do - end do - end if ! dosw - - if (dolw) then - call pbuf_get_field(pbuf, flns_idx, flns) - call pbuf_get_field(pbuf, flnt_idx, flnt) - do i=1,ncol - rad_avgdata%flns_m(i) = rad_avgdata%flns_m(i) +flns(i) *factor_xy - rad_avgdata%flnt_m(i) = rad_avgdata%flnt_m(i) +flnt(i) *factor_xy - - rad_avgdata%flut_m(i) = rad_avgdata%flut_m(i) +rd%flut(i) *factor_xy - rad_avgdata%flutc_m(i) = rad_avgdata%flutc_m(i) +rd%flutc(i) *factor_xy - rad_avgdata%flds_m(i) = rad_avgdata%flds_m(i) +cam_out%flwds(i) *factor_xy - rad_avgdata%fldsc_m(i) = rad_avgdata%fldsc_m(i) +rd%fldsc(i) *factor_xy - rad_avgdata%flntc_m(i) = rad_avgdata%flntc_m(i) +rd%flntc(i) *factor_xy - rad_avgdata%fln200_m(i) = rad_avgdata%fln200_m(i) +rd%fln200(i) *factor_xy - rad_avgdata%fln200c_m(i) = rad_avgdata%fln200c_m(i) +rd%fln200c(i) *factor_xy - rad_avgdata%flnsc_m(i) = rad_avgdata%flnsc_m(i) +rd%flnsc(i) *factor_xy - rad_avgdata%flnr_m(i) = rad_avgdata%flnr_m(i) +rd%flnr(i) *factor_xy - end do - rad_avgdata%qrl_m(:ncol,:pver) = rad_avgdata%qrl_m(:ncol,:pver) + qrl(:ncol,:pver) *factor_xy - rad_avgdata%qrlc_m(:ncol,:pver) = rad_avgdata%qrlc_m(:ncol,:pver) + rd%qrlc(:ncol,:pver) *factor_xy - - do m=1,crm_nz - k = pver-m+1 - rad_avgdata%qrl_crm(:ncol,ii,jj,m) = qrl(:ncol,k) / cpair - end do - end if - - do m=1,crm_nz - k = pver-m+1 - do i = 1,ncol - ! for energy conservation - rad_avgdata%crm_qrad(i,ii,jj,m) = (rad_avgdata%qrs_crm(i,ii,jj,m)+rad_avgdata%qrl_crm(i,ii,jj,m)) * state%pdel(i,k) - end do - end do - -#endif -end subroutine spcam_radiation_col_finalize_sam1mom - -end module spcam_drivers diff --git a/src/utils/cam_ccpp/ccpp_constituent_prop_mod.F90 b/src/utils/cam_ccpp/ccpp_constituent_prop_mod.F90 index edbc4d59e9..29ae61fc53 100644 --- a/src/utils/cam_ccpp/ccpp_constituent_prop_mod.F90 +++ b/src/utils/cam_ccpp/ccpp_constituent_prop_mod.F90 @@ -8,12 +8,19 @@ module ccpp_constituent_prop_mod type, public :: ccpp_constituent_prop_ptr_t logical, private :: thermo_active = .false. logical, private :: water_species = .false. - contains + logical, private :: species_is_dry + character(len=256) :: std_name = '' + + contains procedure :: standard_name => ccp_get_standard_name + procedure :: set_standard_name => ccp_set_standard_name procedure :: is_thermo_active => ccp_is_thermo_active procedure :: is_water_species => ccp_is_water_species procedure :: set_thermo_active => ccp_set_thermo_active procedure :: set_water_species => ccp_set_water_species + procedure :: is_dry => ccp_is_dry + procedure :: set_dry => ccp_set_dry + end type ccpp_constituent_prop_ptr_t ! CCPP properties init routine @@ -37,20 +44,43 @@ subroutine ccp_get_standard_name(this, std_name, errcode, errmsg) integer, optional, intent(out) :: errcode character(len=*), optional, intent(out) :: errmsg - std_name = 'Not Used!' + std_name = this%std_name ! Provide err values if requested: if(present(errcode)) then errcode = 0 end if if(present(errmsg)) then - errmsg = 'Still Not Used!' + errmsg = '' end if end subroutine ccp_get_standard_name !------ + subroutine ccp_set_standard_name(this, std_name, errcode, errmsg) + ! Set this constituent's standard name + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(inout) :: this + character(len=*), intent(in) :: std_name + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + this%std_name = std_name + + ! Provide err values if requested: + if(present(errcode)) then + errcode = 0 + end if + if(present(errmsg)) then + errmsg = '' + end if + + end subroutine ccp_set_standard_name + + !------ + subroutine ccp_is_thermo_active(this, val_out, errcode, errmsg) ! Dummy arguments @@ -97,6 +127,29 @@ end subroutine ccp_is_water_species !------ + subroutine ccp_is_dry(this, val_out, errcode, errmsg) + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(in) :: this + logical, intent(out) :: val_out + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + ! Pass back water species property: + val_out = this%species_is_dry + + ! Provide err values if requested: + if(present(errcode)) then + errcode = 0 + end if + if(present(errmsg)) then + errmsg = '' + end if + + end subroutine ccp_is_dry + + !------ + subroutine ccp_set_thermo_active(this, thermo_flag, errcode, errmsg) ! Set whether this constituent is thermodynamically active, which ! means that certain physics schemes will use this constitutent @@ -147,18 +200,41 @@ subroutine ccp_set_water_species(this, water_flag, errcode, errmsg) end subroutine ccp_set_water_species + subroutine ccp_set_dry(this, dry_flag, errcode, errmsg) + ! Set whether this constituent is a dry species or not using the dry_flag which is passed in + + ! Dummy arguments + class(ccpp_constituent_prop_ptr_t), intent(inout) :: this + logical, intent(in) :: dry_flag + integer, optional, intent(out) :: errcode + character(len=*), optional, intent(out) :: errmsg + + ! Set dry_flag for this constituent: + this%species_is_dry = dry_flag + + ! Provide err values if requested: + if(present(errcode)) then + errcode = 0 + end if + if(present(errmsg)) then + errmsg = '' + end if + + end subroutine ccp_set_dry + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++ !CAM-equivalent CCPP constituents initialization routine !+++++++++++++++++++++++++++++++++++++++++++++++++++++++ -subroutine ccpp_const_props_init() +subroutine ccpp_const_props_init(ix_qv) ! Use statements: - use constituents, only: pcnst + use constituents, only: pcnst, cnst_get_type_byind use cam_abortutils, only: handle_allocate_error use air_composition, only: dry_air_species_num use air_composition, only: thermodynamic_active_species_idx + integer, intent(in) :: ix_qv ! Local variables: integer :: ierr integer :: m @@ -185,6 +261,18 @@ subroutine ccpp_const_props_init() end if end do + ! Set "set_dry" property: + do m=1,pcnst + if (cnst_get_type_byind(m).eq.'dry') then + call ccpp_const_props(m)%set_dry(.true.) + else + call ccpp_const_props(m)%set_dry(.false.) + end if + end do + + ! Set "std_name" property: + call ccpp_const_props(ix_qv)%set_standard_name('water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water') + end subroutine ccpp_const_props_init end module ccpp_constituent_prop_mod diff --git a/src/utils/error_messages.F90 b/src/utils/error_messages.F90 deleted file mode 100644 index a2a64bca91..0000000000 --- a/src/utils/error_messages.F90 +++ /dev/null @@ -1,151 +0,0 @@ -module error_messages - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! General purpose routines for issuing error messages. - ! - ! Author: B. Eaton - ! - !----------------------------------------------------------------------- - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - - implicit none - save - private - public :: & - alloc_err, &! Issue error message after non-zero return from an allocate statement. - handle_err, &! Issue error message after non-zero return from anything - handle_ncerr ! Handle error returns from netCDF library procedures. - - ! If an error message string is not empty, abort with that string as the - ! error message. - public :: handle_errmsg - -!############################################################################## -contains -!############################################################################## - - subroutine alloc_err( istat, routine, name, nelem ) - - !----------------------------------------------------------------------- - ! Purpose: - ! Issue error message after non-zero return from an allocate statement. - ! - ! Author: B. Eaton - !----------------------------------------------------------------------- - - integer, intent(in) ::& - istat ! status from allocate statement - character(len=*), intent(in) ::& - routine, &! routine that called allocate - name ! name of array - integer, intent(in) ::& - nelem ! number of elements attempted to allocate - !----------------------------------------------------------------------- - - if ( istat .ne. 0 ) then - write(iulog,*)'ERROR trying to allocate memory in routine: ' & - //trim(routine) - write(iulog,*)' Variable name: '//trim(name) - write(iulog,*)' Number of elements: ',nelem - call endrun ('ALLOC_ERR') - end if - - return - - end subroutine alloc_err - -!############################################################################## - - subroutine handle_err( istat, msg ) - - !----------------------------------------------------------------------- - ! Purpose: - ! Issue error message after non-zero return from anything. - ! - ! Author: T. Henderson - !----------------------------------------------------------------------- - - integer, intent(in) :: istat ! status, zero = "no error" - character(len=*), intent(in) :: msg ! error message to print - !----------------------------------------------------------------------- - - if ( istat .ne. 0 ) then - call endrun (trim(msg)) - end if - - return - - end subroutine handle_err - -!############################################################################## - - subroutine handle_ncerr( ret, mes, line ) - - !----------------------------------------------------------------------- - ! Purpose: - ! Check netCDF library function return code. If error detected - ! issue error message then abort. - ! - ! Author: B. Eaton - !----------------------------------------------------------------------- - -!----------------------------------------------------------------------- - use netcdf -!----------------------------------------------------------------------- - - integer, intent(in) ::& - ret ! return code from netCDF library routine - character(len=*), intent(in) ::& - mes ! message to be printed if error detected - integer, intent(in), optional :: line - !----------------------------------------------------------------------- - - if ( ret .ne. NF90_NOERR ) then - if(present(line)) then - write(iulog,*) mes, line - else - write(iulog,*) mes - end if - write(iulog,*) nf90_strerror( ret ) - call endrun ('HANDLE_NCERR') - endif - - return - - end subroutine handle_ncerr - -!############################################################################## - - subroutine handle_errmsg(errmsg, subname, extra_msg) - - ! String that is asserted to be null. - character(len=*), intent(in) :: errmsg - ! Name of procedure generating the message. - character(len=*), intent(in), optional :: subname - ! Additional message from the procedure calling this one. - character(len=*), intent(in), optional :: extra_msg - - if (trim(errmsg) /= "") then - - if (present(extra_msg)) & - write(iulog,*) "handle_errmsg: & - &Message from caller: ",trim(extra_msg) - - if (present(subname)) then - call endrun("ERROR: handle_errmsg: "// & - trim(subname)//": "//trim(errmsg)) - else - call endrun("ERROR: handle_errmsg: "// & - "Error message received from routine: "//trim(errmsg)) - end if - - end if - - end subroutine handle_errmsg - -!############################################################################## - -end module error_messages diff --git a/src/utils/namelist_utils.F90 b/src/utils/namelist_utils.F90 deleted file mode 100644 index c12dfad2d6..0000000000 --- a/src/utils/namelist_utils.F90 +++ /dev/null @@ -1,6 +0,0 @@ -module namelist_utils - -use shr_nl_mod, only: & - find_group_name => shr_nl_find_group_name - -end module namelist_utils