diff --git a/bld/build-namelist b/bld/build-namelist index 3b2182bdc7..3a4a574f2b 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -3686,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'); @@ -4369,11 +4369,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 9feec64a03..f5731e289b 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,9 +83,9 @@ Switch to turn on UNICON package: 0 => off, 1 => on Switch to turn on/off advecting CLUBB moments: 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: @@ -310,23 +310,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 82bae67421..9b9b930284 100755 --- a/bld/configure +++ b/bld/configure @@ -98,18 +98,12 @@ 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. @@ -253,7 +247,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'}, @@ -302,10 +295,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'}, @@ -565,10 +554,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') { @@ -599,7 +588,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". @@ -764,46 +753,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 @@ -821,12 +770,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'}) { @@ -916,14 +859,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 @@ -955,18 +890,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'; } @@ -998,15 +927,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) { @@ -1058,10 +981,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/) { @@ -1116,31 +1039,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'}) { @@ -1349,10 +1247,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 { @@ -1377,10 +1275,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 @@ -1539,11 +1433,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"; } } @@ -1843,28 +1737,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 +2161,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 diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 53af1a16cf..b2a84861cf 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -352,8 +352,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 @@ -1993,8 +1991,6 @@ NEU -MOZ -OFF @@ -2090,7 +2086,6 @@ .true. .false. .false. - .true. 0.075D0 0.100D0 @@ -2108,14 +2103,12 @@ .true. .true. .true. - .true. 0 1 1 1 - 1 0.01d0 0.001d0 @@ -2123,7 +2116,6 @@ .false. .true. - .true. .false. @@ -2333,10 +2325,8 @@ RK MG MG -SPCAM_m2005 -SPCAM_sam1mom -MG -MG +MG +MG 1 0 @@ -2462,8 +2452,6 @@ rk park CLUBB_SGS -SPCAM_sam1mom -SPCAM_m2005 @@ -2511,9 +2499,7 @@ 0.37D0 0.35D0 -0.35D0 0.45D0 -0.45D0 0.45D0 0.35D0 2.30D0 @@ -2523,7 +2509,6 @@ 2.30D0 0.45D0 2.30D0 -0.45D0 0.55D0 0.22D0 @@ -2552,7 +2537,6 @@ 2.30D0 0.70D0 2.300D0 -0.13D0 0.26D0 2.30D0 @@ -2576,7 +2560,6 @@ 1.00D0 1.50D0 1.10D0 -1.2D0 0.60D0 @@ -2591,9 +2574,6 @@ 0.4D0 1.0D0 -1.00D0 -1.00D0 - .false. .true. @@ -2656,16 +2636,12 @@ HB HBR CLUBB_SGS -SPCAM_m2005 -SPCAM_sam1mom ZM off UNICON NONE -SPCAM -SPCAM NONE UW @@ -2673,8 +2649,6 @@ Hack Hack CLUBB_SGS -SPCAM -SPCAM .true. @@ -2800,10 +2774,8 @@ 1.1D0 1.0D0 1.05D0 - 1.0D0 1.1D0 1.0D0 - 1.0D0 1.e-7 5.e-3 @@ -2960,19 +2932,14 @@ 4 4 4 - 4 42 -42 42 -42 42 -42 42 42 42 42 42 -42 1 2 @@ -3204,8 +3171,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 d07e4c403f..8458b6e42d 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -3611,16 +3611,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). @@ -3640,14 +3638,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 }}). @@ -5370,7 +5366,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'. @@ -6189,7 +6185,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 - - @@ -274,16 +265,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 @@ -360,16 +341,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 @@ -400,19 +371,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 - - - @@ -787,76 +745,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 d0789ac1f3..46117e6067 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -381,26 +381,6 @@ - - - - - - - - - - - - - - - - - - - - @@ -2156,70 +2136,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/doc/ChangeLog b/doc/ChangeLog index dde451cd76..cb0780103d 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,140 @@ =============================================================== +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 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/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/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 821b84695d..7b3297b67d 100644 --- a/src/physics/cam/cloud_fraction.F90 +++ b/src/physics/cam/cloud_fraction.F90 @@ -204,11 +204,10 @@ 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. @@ -217,7 +216,7 @@ subroutine cldfrc_init 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 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 e757e1eef4..9edd28c696 100644 --- a/src/physics/cam/convect_shallow.F90 +++ b/src/physics/cam/convect_shallow.F90 @@ -90,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 ) @@ -167,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 ! ! ------------------------------------------------- ! 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/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/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 c9822b18fc..5aa84b55a4 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 @@ -743,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 @@ -911,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() @@ -1069,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 @@ -1096,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') @@ -1150,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 ! @@ -1163,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/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 c5518f94fc..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) @@ -1010,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, & @@ -1026,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. @@ -1389,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/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