diff --git a/bld/build-namelist b/bld/build-namelist
index 3a4a574f2b..665b5767da 100755
--- a/bld/build-namelist
+++ b/bld/build-namelist
@@ -4079,27 +4079,6 @@ if ( $dyn eq 'fv3') {
}
-# EUL dycore
-if ($dyn eq 'eul') {
- add_default($nl, 'eul_dif2_coef');
- add_default($nl, 'eul_hdif_order');
- add_default($nl, 'eul_hdif_kmnhdn');
- add_default($nl, 'eul_hdif_coef');
- add_default($nl, 'eul_divdampn');
- add_default($nl, 'eul_tfilt_eps');
- add_default($nl, 'eul_kmxhdc');
- add_default($nl, 'eul_nsplit');
-}
-
-# SLD dycore
-if ($dyn eq 'sld') {
- add_default($nl, 'sld_dif2_coef');
- add_default($nl, 'sld_dif4_coef');
- add_default($nl, 'sld_divdampn');
- add_default($nl, 'sld_tfilt_eps');
- add_default($nl, 'sld_kmxhdc');
-}
-
# Single column model
if ($cfg->get('scam')) {
add_default($nl, 'iopfile');
diff --git a/bld/config_files/definition.xml b/bld/config_files/definition.xml
index f5731e289b..c3af153035 100644
--- a/bld/config_files/definition.xml
+++ b/bld/config_files/definition.xml
@@ -26,8 +26,8 @@ Switch specifies whether CAM is being built by the CCSM sequential scripts. 0 =
<entry id="cpl" valid_values="mct,nuopc" value="mct" >
Coupling framework: mct or nuopc. Default: mct.
</entry>
-<entry id="dyn" valid_values="eul,fv,fv3,se,mpas" value="">
-Dynamics package: eul, fv, fv3, se, or mpas.
+<entry id="dyn" valid_values="fv,fv3,se,mpas" value="">
+Dynamics package: fv, fv3, se, or mpas.
</entry>
<entry id="waccm_phys" valid_values="0,1" value="0">
Switch to turn on waccm physics: 0 => no, 1 => yes.
@@ -144,15 +144,15 @@ Modifications that allow perturbation growth testing: 0=off, 1=on.
</entry>
<entry id="scam" valid_values="0,1" value="0">
Configure CAM for single column mode and specify an IOP: 0=no, 1=yes.
-This option only supported for the Eulerian and SE dycores.
+This option only supported for the SE dycore.
</entry>
<entry id="scam_iop" valid_values="arm95,arm97,atex,bomex,cgilss11,cgilss12,cgilss6,dycomsrf01,dycomsrf02,gateiii,mpace,rico,sas,sparticus,togaii,twp06,camfrc,none" value="none">
Single column IOP
-Supported for Eulerian and SE dycores.
+Only supported for SE dycore.
</entry>
<entry id="camiop" valid_values="0,1" value="0">
Configure CAM to generate an IOP file that can be used to drive SCAM: 0=no, 1=yes.
-Supported for Eulerian and SE dycores.
+Only supported for SE dycore.
</entry>
<entry id="hgrid" value="">
Horizontal grid specifier. The recognized values depend on
@@ -191,15 +191,6 @@ Switch on (off) age of air tracers: 0=off, 1=on.
Maximum number of constituents that are radiatively active or in any one
diagnostic list.
</entry>
-<entry id="trm" value="1">
-Maximum Fourier wavenumber.
-</entry>
-<entry id="trn" value="1">
-Highest degree of the Legendre polynomials for m=0.
-</entry>
-<entry id="trk" value="1">
-Highest degree of the associated Legendre polynomials.
-</entry>
<entry id="pcols" value="16">
Maximum number of columns in a chunk (physics data structure).
</entry>
diff --git a/bld/config_files/horiz_grid.xml b/bld/config_files/horiz_grid.xml
index 1164009073..186adf4c6e 100644
--- a/bld/config_files/horiz_grid.xml
+++ b/bld/config_files/horiz_grid.xml
@@ -2,15 +2,6 @@
<config_horiz_grid>
-<horiz_grid dyn="eul" hgrid="512x1024" nlat="512" nlon="1024" m="341" n="341" k="341" />
-<horiz_grid dyn="eul" hgrid="256x512" nlat="256" nlon="512" m="170" n="170" k="170" />
-<horiz_grid dyn="eul" hgrid="128x256" nlat="128" nlon="256" m="85" n="85" k="85" />
-<horiz_grid dyn="eul" hgrid="64x128" nlat="64" nlon="128" m="42" n="42" k="42" />
-<horiz_grid dyn="eul" hgrid="48x96" nlat="48" nlon="96" m="31" n="31" k="31" />
-<horiz_grid dyn="eul" hgrid="32x64" nlat="32" nlon="64" m="21" n="21" k="21" />
-<horiz_grid dyn="eul" hgrid="8x16" nlat="8" nlon="16" m="5" n="5" k="5" />
-<horiz_grid dyn="eul" hgrid="1x1" nlat="1" nlon="1" m="1" n="1" k="1" />
-
<horiz_grid dyn="fv" hgrid="0.23x0.31" nlat="768" nlon="1152" />
<horiz_grid dyn="fv" hgrid="0.47x0.63" nlat="384" nlon="576" />
<horiz_grid dyn="fv" hgrid="0.5x0.625" nlat="361" nlon="576" />
diff --git a/bld/configure b/bld/configure
index 9b9b930284..138436315a 100755
--- a/bld/configure
+++ b/bld/configure
@@ -78,7 +78,7 @@ OPTIONS
-cppdefs <string> A string of user specified CPP defines. Appended to
Makefile defaults. E.g. -cppdefs '-DVAR1 -DVAR2'
-cpl Coupling framework [mct | nuopc]. Default: mct.
- -dyn <name> Dynamical core option: [eul | fv | se | fv3 | mpas]. Default: fv.
+ -dyn <name> Dynamical core option: [fv | se | fv3 | mpas]. Default: fv.
-edit_chem_mech Invokes CAMCHEM_EDITOR to allow the user to edit the chemistry mechanism file
-hgrid <name> Specify horizontal grid. Use nlatxnlon for spectral grids;
dlatxdlon for fv grids (dlat and dlon are the grid cell size
@@ -115,7 +115,6 @@ OPTIONS
Options relevent to SCAM mode:
-camiop Configure CAM to generate an IOP file that can be used to drive SCAM.
- This switch only works with the Eulerian dycore.
-scam <iopname> Compiles model in single column mode and configures for iop
[ arm95 | arm97 | atex | bomex | cgilsS11 | cgilsS12 | cgilsS6 | dycomsRF01 |
dycomsRF02 | gateIII | mpace | rico | sparticus | togaII | twp06 | SAS | camfrc ].
@@ -686,14 +685,6 @@ $waccm_phys = $cfg_ref->get('waccm_phys');
if ($print>=2) { print "WACCM physics: $waccm_phys$eol"; }
-
-# WACCM physics only runs with FV, SE and FV3 dycores
-if ( ($waccm_phys) and ($dyn_pkg eq 'eul') ) {
- die <<"EOF";
-** ERROR: WACCM physics does not run with the Eulerian spectral dycore.
-EOF
-}
-
# WACCM includes 4 age of air tracers by default
if ($chem_pkg =~ /waccm_ma/ or $chem_pkg =~ /waccm_tsmlt/) {
$cfg_ref->set('age_of_air_trcs', 1);
@@ -1107,10 +1098,10 @@ if (defined $opts{'scam'}) {
}
my $scam = $cfg_ref->get('scam') ? "ON" : "OFF";
-# The only dycores supported in SCAM mode are Eulerian and Spectral Elements
-if ($scam eq 'ON' and !($dyn_pkg eq 'eul' or $dyn_pkg eq 'se')) {
+# The only dycore supported in SCAM mode is the Spectral Element
+if ($scam eq 'ON' and !($dyn_pkg eq 'se')) {
die <<"EOF";
-** ERROR: SCAM mode only works with Eulerian or SE dycores.
+** ERROR: SCAM mode only works with SE dycore.
** Requested dycore is: $dyn_pkg
EOF
}
@@ -1124,10 +1115,10 @@ if (defined $opts{'camiop'}) {
}
my $camiop = $cfg_ref->get('camiop') ? "ON" : "OFF";
-# The only dycores supported in SCAM mode are Eulerian and Spectral Elements
-if ($camiop eq 'ON' and !($dyn_pkg eq 'eul' or $dyn_pkg eq 'se')) {
+# The only dycore supported in SCAM mode is the Spectral Element
+if ($camiop eq 'ON' and !($dyn_pkg eq 'se')) {
die <<"EOF";
-** ERROR: CAMIOP mode only works with the Eulerian or Spectral Element dycores.
+** ERROR: CAMIOP mode only works with the Spectral Element dycore.
** Requested dycore is: $dyn_pkg
EOF
}
@@ -1141,9 +1132,6 @@ my $hgrid;
if ($dyn_pkg eq 'fv') {
$hgrid = '1.9x2.5';
}
-elsif ($dyn_pkg eq 'eul') {
- $hgrid = '64x128';
-}
elsif ($dyn_pkg eq 'se') {
$hgrid = 'ne16np4';
}
@@ -1788,12 +1776,6 @@ $cfg_cppdefs .= " -DPLEV=$nlev -DPCNST=$nadv -DPCOLS=$pcols -DPSUBCOLS=$psubcols
# Radiatively active constituent number
$cfg_cppdefs .= " -DN_RAD_CNST=$max_n_rad_cnst";
-# Spectral truncation parameters
-my $trm = $cfg_ref->get('trm');
-my $trn = $cfg_ref->get('trn');
-my $trk = $cfg_ref->get('trk');
-$cfg_cppdefs .= " -DPTRM=$trm -DPTRN=$trn -DPTRK=$trk";
-
# offline driver for FV dycore
if ($offline_dyn) { $cfg_cppdefs .= ' -DOFFLINE_DYN'; }
@@ -2192,11 +2174,6 @@ sub write_filepath
print $fh "$camsrcdir/src/utils/pilgrim\n";
}
- # Advective transport
- if ($dyn eq 'eul') {
- print $fh "$camsrcdir/src/advection/slt\n";
- }
-
print $fh "$camsrcdir/src/cpl/$cpl\n";
print $fh "$camsrcdir/src/control\n";
print $fh "$camsrcdir/src/utils\n";
@@ -2373,9 +2350,9 @@ sub set_horiz_grid
$hgrid =~ m/C(\d+)/;
$cfg_ref->set('hgrid', $hgrid);
}
- elsif ($dyn_pkg =~ m/^eul$|^fv/) {
+ elsif ($dyn_pkg =~ m/^fv/) {
- # For EUL and FV dycores the parameters are read from an input file,
+ # For FV dycore the parameters are read from an input file,
# and if no dycore/grid matches are found then issue error message.
my $xml = XML::Lite->new( $hgrid_file );
@@ -2404,26 +2381,7 @@ sub set_horiz_grid
unless ($found) { die "set_horiz_grid: no match for dycore $dyn_pkg and hgrid $hgrid\n"; }
# Set parameter values -- dycore specific.
- if ( $dyn_pkg =~ m/eul/ ) {
- $cfg_ref->set('nlat', $a{'nlat'});
- $cfg_ref->set('nlon', $a{'nlon'});
- $cfg_ref->set('trm', $a{'m'});
- $cfg_ref->set('trn', $a{'n'});
- $cfg_ref->set('trk', $a{'k'});
-
- # Override resolution settings to configure for SCAM mode. The override is needed
- # because in SCAM mode the -hgrid option is used to specify the resolution of default
- # datasets from which single data columns are extracted.
- my $scam = $cfg_ref->get('scam');
- if ($scam) {
- $cfg_ref->set('nlat', 1);
- $cfg_ref->set('nlon', 1);
- $cfg_ref->set('trm', 1);
- $cfg_ref->set('trn', 1);
- $cfg_ref->set('trk', 1);
- }
- }
- elsif ( $dyn_pkg eq 'fv' ) {
+ if ( $dyn_pkg eq 'fv' ) {
$cfg_ref->set('nlat', $a{'nlat'});
$cfg_ref->set('nlon', $a{'nlon'});
}
diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml
index b2a84861cf..b84e2b6cf2 100644
--- a/bld/namelist_files/namelist_defaults_cam.xml
+++ b/bld/namelist_files/namelist_defaults_cam.xml
@@ -3,14 +3,6 @@
<namelist_defaults>
<!-- Timestep size (this is the atm coupling interval) -->
-<dtime dyn="eul" >1200</dtime>
-<dtime dyn="eul" hgrid="256x512" >300 </dtime>
-<dtime dyn="eul" hgrid="128x256" >600 </dtime>
-<dtime dyn="eul" hgrid="64x128" >1200</dtime>
-<dtime dyn="eul" hgrid="48x96" >1800</dtime>
-<dtime dyn="eul" hgrid="32x64" >1800</dtime>
-<dtime dyn="eul" hgrid="8x16" >1800</dtime>
-
<dtime dyn="fv" >1800</dtime>
<dtime dyn="fv" waccmx="1" >300 </dtime>
@@ -201,27 +193,6 @@
<ncdata dyn="fv3" hgrid="C48" nlev="70" ic_ymd="101" >atm/waccm/ic/f2000.waccm-mam3_C48_L70.cam2.i.0017-01-01_c200625.nc</ncdata>
<ncdata dyn="fv3" hgrid="C96" nlev="70" ic_ymd="101" >atm/waccm/ic/f2000.waccm-mam3_C96_L70.cam2.i.0017-01-01_c200625.nc</ncdata>
-<ncdata dyn="eul" hgrid="512x1024" nlev="26" ic_ymd="101" >atm/cam/inic/gaus/T341clim01.cam2.i.0024-01-01-00000.nc</ncdata>
-<ncdata dyn="eul" hgrid="256x512" nlev="26" ic_ymd="101" >atm/cam/inic/gaus/cami_0000-01-01_256x512_L26_c030918.nc</ncdata>
-
-<ncdata dyn="eul" hgrid="128x256" nlev="26" ic_ymd="101" >atm/cam/inic/gaus/cami_0000-01-01_128x256_L26_c030918.nc</ncdata>
-<ncdata dyn="eul" hgrid="128x256" nlev="26" ic_ymd="901" >atm/cam/inic/gaus/cami_0000-09-01_128x256_L26_c040422.nc</ncdata>
-
-<ncdata hgrid="64x128" nlev="26" ic_ymd="101" >atm/cam/inic/gaus/cami_0000-01-01_64x128_T42_L26_c031110.nc</ncdata>
-<ncdata hgrid="64x128" nlev="26" ic_ymd="901" >atm/cam/inic/gaus/cami_0000-09-01_64x128_L26_c030918.nc</ncdata>
-<ncdata hgrid="64x128" nlev="30" ic_ymd="101" >atm/cam/inic/gaus/cami_0000-01-01_64x128_L30_c090102.nc</ncdata>
-<ncdata hgrid="64x128" nlev="30" ic_ymd="901" >atm/cam/inic/gaus/cami_0000-09-01_64x128_L30_c031210.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" ic_ymd="101" >atm/cam/inic/gaus/cami_0000-01-01_64x128_L32_c170510.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" ic_ymd="901" >atm/cam/inic/gaus/cami_0000-01-01_64x128_L32_c170510.nc</ncdata>
-<ncdata hgrid="48x96" nlev="26" ic_ymd="101" >atm/cam/inic/gaus/cami_0000-01-01_48x96_L26_c091218.nc</ncdata>
-<ncdata dyn="eul" hgrid="48x96" nlev="26" ic_ymd="901" >atm/cam/inic/gaus/cami_0000-09-01_48x96_L26_c040420.nc</ncdata>
-<ncdata hgrid="48x96" nlev="30" ic_ymd="101" >atm/cam/inic/gaus/cami_0000-01-01_48x96_L30_c100426.nc</ncdata>
-<ncdata hgrid="32x64" nlev="26" ic_ymd="901" >atm/cam/inic/gaus/cami_0000-09-01_32x64_L26_c030918.nc</ncdata>
-<ncdata hgrid="32x64" nlev="30" ic_ymd="101" >atm/cam/inic/gaus/cami_0000-01-01_32x64_L30_c090107.nc</ncdata>
-<ncdata hgrid="8x16" nlev="26" ic_ymd="101" >atm/cam/inic/gaus/cami_0000-01-01_8x16_L26_c030228.nc</ncdata>
-<ncdata hgrid="8x16" nlev="26" ic_ymd="901" >atm/cam/inic/gaus/cami_0000-09-01_8x16_L26_c030918.nc</ncdata>
-<ncdata hgrid="8x16" nlev="30" ic_ymd="101" >atm/cam/inic/gaus/cami_0000-01-01_8x16_L30_c090102.nc</ncdata>
-
<ncdata dyn="se" hgrid="ne3np4" nlev="93" chem="trop_strat_mam5_ts4" >atm/cam/inic/se/FCts4MTHIST_ne3pg3_spinup02.cam.i.1980-01-01_c240702.nc</ncdata>
<ncdata dyn="se" hgrid="ne3np4" nlev="32" ic_ymd="101" >atm/cam/inic/se/cam6_QPC6_topo_ne3pg3_mg37_L32_01-01-31_c221214.nc</ncdata>
<ncdata dyn="se" hgrid="ne3np4" nlev="32" ic_ymd="901" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-09-01-00000.nc</ncdata>
@@ -292,13 +263,6 @@
<ncdata hgrid="mpasa120" nlev="93" >atm/cam/inic/mpas/cami_01-01-2000_00Z_mpasa120_L93_CFSR_c240814.nc</ncdata>
<!-- Topography -->
-<bnd_topo hgrid="256x512" >atm/cam/topo/topo-from-cami_0000-01-01_256x512_L26_c030918.nc</bnd_topo>
-<bnd_topo hgrid="128x256" >atm/cam/topo/USGS-gtopo30_128x256_c050520.nc</bnd_topo>
-<bnd_topo hgrid="64x128" >atm/cam/topo/T42_nc3000_Co060_Fi001_PF_nullRR_Nsw042_20180111.nc</bnd_topo>
-<bnd_topo hgrid="48x96" >atm/cam/topo/USGS-gtopo30_48x96_c050520.nc</bnd_topo>
-<bnd_topo hgrid="32x64" >atm/cam/topo/USGS-gtopo30_32x64_c050520.nc</bnd_topo>
-<bnd_topo hgrid="8x16" >atm/cam/topo/USGS-gtopo30_8x16_c050520.nc</bnd_topo>
-
<bnd_topo hgrid="0.23x0.31" >atm/cam/topo/USGS_gtopo30_0.23x0.31_remap_c061107.nc</bnd_topo>
<bnd_topo hgrid="0.47x0.63" >atm/cam/topo/USGS_gtopo30_0.47x0.63_remap_c061106.nc</bnd_topo>
<bnd_topo hgrid="0.47x0.63" phys="cam6">atm/cam/topo/fv_0.47x0.63_nc3000_Co030_Fi001_PF_nullRR_Nsw021_20171023.nc</bnd_topo>
@@ -714,24 +678,6 @@
<aircraft_co2_file hgrid="C48" >atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_175001-201512_fv_1.9x2.5_c20181011.nc</aircraft_co2_file>
<aircraft_co2_file hgrid="C24" >atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_175001-201512_fv_1.9x2.5_c20181011.nc</aircraft_co2_file>
-<!-- DMS surface emissions -->
-<bndtvdms hgrid="128x256" >atm/cam/scyc/DMS_emissions_128x256_clim_c040122.nc</bndtvdms>
-<bndtvdms hgrid="64x128" >atm/cam/scyc/DMS_emissions_64x128_c030722.nc</bndtvdms>
-<bndtvdms hgrid="32x64" >atm/cam/scyc/DMS_emissions_32x64_c030722.nc</bndtvdms>
-<bndtvdms dyn="fv" hgrid="4x5" >atm/cam/scyc/DMS_emissions_4x5_noncon_c050306.nc</bndtvdms>
-
-<!-- oxidant data for prognostic sulfur cycle -->
-<bndtvoxid hgrid="128x256" >atm/cam/scyc/oxid_128x256_L26_clim_c040112.nc</bndtvoxid>
-<bndtvoxid hgrid="64x128" >atm/cam/scyc/oxid_3d_64x128_L26_c030722.nc</bndtvoxid>
-<bndtvoxid hgrid="32x64" >atm/cam/scyc/oxid_3d_32x64_L26_c030722.nc</bndtvoxid>
-<bndtvoxid dyn="fv" hgrid="4x5" >atm/cam/scyc/oxid_4x5_L26_noncon_c050306.nc</bndtvoxid>
-
-<!-- SOx surface emissions -->
-<bndtvsox hgrid="128x256" >atm/cam/scyc/SOx_emissions_128x256_L2_1850-2000_c040321.nc</bndtvsox>
-<bndtvsox hgrid="64x128" >atm/cam/scyc/SOx_emissions_64x128_L2_c030722.nc</bndtvsox>
-<bndtvsox hgrid="32x64" >atm/cam/scyc/SOx_emissions_32x64_L2_c030722.nc</bndtvsox>
-<bndtvsox dyn="fv" hgrid="4x5" >atm/cam/scyc/SOx_emissions_4x5_noncon_c050306.nc</bndtvsox>
-
<!-- Greenhouse gas production/loss rates -->
<bndtvg>atm/cam/ggas/noaamisc.r8.nc</bndtvg>
@@ -2049,12 +1995,6 @@
<!-- Boundary data for Tropopheric Chemistry -->
<fstrat_file >atm/cam/chem/trop_mozart/ub/ubvals_b40.20th.track1_1996-2005_c110315.nc</fstrat_file>
-<!-- Fossil fuel carbon aerosol surface emissions-->
- <!-- standard 4 species carbon -->
-<caer_emis hgrid="64x128" >atm/cam/rad/carbon_penner_cooke_doubled_64x128_c021120.nc</caer_emis>
-<caer_emis hgrid="32x64" >atm/cam/rad/carbon_penner_cooke_doubled_32x64_c021120.nc</caer_emis>
-<caer_emis dyn="fv" hgrid="4x5" >atm/cam/rad/carbon_penner_cooke_doubled_4x5_c021120.nc</caer_emis>
-
<!-- soil erodibility factors -->
<soil_erod_file >atm/cam/dst/dst_source2x2tunedcam6-2x2-04062017.nc </soil_erod_file>
<soil_erod_file phys="cam5" >atm/cam/dst/dst_source2x2_cam5.4_c150327.nc</soil_erod_file>
@@ -2088,7 +2028,6 @@
<do_tms phys="cam7" > .false. </do_tms>
<tms_z0fac > 0.075D0 </tms_z0fac>
-<tms_z0fac hgrid="48x96" > 0.100D0 </tms_z0fac>
<tms_z0fac waccm_phys="1" phys="cam4" > 0.100D0 </tms_z0fac>
<tms_orocnst > 1.0D0 </tms_orocnst>
@@ -2688,9 +2627,6 @@
<cldfrc_rhminl hgrid="0.47x0.63" phys="cam4" > 0.920D0 </cldfrc_rhminl>
<!-- Note: the ocn attribute allows coupled and uncoupled configurations to have different tunings -->
<cldfrc_rhminl hgrid="0.47x0.63" phys="cam4" ocn="docn" > 0.913D0 </cldfrc_rhminl>
-<cldfrc_rhminl hgrid="512x1024" phys="cam4" > 0.903D0 </cldfrc_rhminl>
-<cldfrc_rhminl hgrid="128x256" phys="cam4" > 0.905D0 </cldfrc_rhminl>
-<cldfrc_rhminl hgrid="48x96" phys="cam4" > 0.880D0 </cldfrc_rhminl>
<cldfrc_rhminl dyn="se" phys="cam4" > 0.910D0 </cldfrc_rhminl>
<cldfrc_rhminl_adj_land > 0.100D0 </cldfrc_rhminl_adj_land>
@@ -2702,12 +2638,8 @@
<cldfrc_rhminh hgrid="0.23x0.31" phys="cam4" > 0.770D0 </cldfrc_rhminh>
<cldfrc_rhminh hgrid="0.47x0.63" phys="cam4" > 0.700D0 </cldfrc_rhminh>
<cldfrc_rhminh hgrid="0.9x1.25" phys="cam4" > 0.770D0 </cldfrc_rhminh>
-<cldfrc_rhminh hgrid="48x96" phys="cam4" > 0.500D0 </cldfrc_rhminh>
<cldfrc_rhminh hgrid="4x5" phys="cam4" waccm_phys="1" > 0.900D0 </cldfrc_rhminh>
<cldfrc_rhminh hgrid="10x15" phys="cam4" waccm_phys="1" > 0.900D0 </cldfrc_rhminh>
-<cldfrc_rhminh hgrid="128x256" > 0.680D0 </cldfrc_rhminh>
-<cldfrc_rhminh hgrid="128x256" > 0.680D0 </cldfrc_rhminh>
-<cldfrc_rhminh hgrid="512x1024" > 0.650D0 </cldfrc_rhminh>
<cldfrc_sh1 > 0.07D0 </cldfrc_sh1>
<cldfrc_sh1 dyn="fv" > 0.04D0 </cldfrc_sh1>
@@ -2729,16 +2661,10 @@
<cldfrc_premit dyn="fv" hgrid="0.23x0.31" > 25000.0D0 </cldfrc_premit>
<cldfrc_premit dyn="fv" hgrid="0.47x0.63" > 25000.0D0 </cldfrc_premit>
<cldfrc_premit dyn="fv" hgrid="0.5x0.625" > 25000.0D0 </cldfrc_premit>
-<cldfrc_premit dyn="eul" hgrid="128x256" > 25000.0D0 </cldfrc_premit>
-<cldfrc_premit dyn="eul" hgrid="256x512" > 25000.0D0 </cldfrc_premit>
-<cldfrc_premit dyn="eul" hgrid="512x1024" > 25000.0D0 </cldfrc_premit>
<cldfrc_premit pbl="uw" > 40000.0D0 </cldfrc_premit>
<cldfrc_premit dyn="fv" hgrid="0.23x0.31" pbl="uw" > 40000.0D0 </cldfrc_premit>
<cldfrc_premit dyn="fv" hgrid="0.47x0.63" pbl="uw" > 40000.0D0 </cldfrc_premit>
<cldfrc_premit dyn="fv" hgrid="0.5x0.625" pbl="uw" > 40000.0D0 </cldfrc_premit>
-<cldfrc_premit dyn="eul" hgrid="128x256" pbl="uw" > 40000.0D0 </cldfrc_premit>
-<cldfrc_premit dyn="eul" hgrid="256x512" pbl="uw" > 40000.0D0 </cldfrc_premit>
-<cldfrc_premit dyn="eul" hgrid="512x1024" pbl="uw" > 40000.0D0 </cldfrc_premit>
<cldfrc_premit dyn="se" pbl="uw" > 40000.0D0 </cldfrc_premit>
<cldfrc_premib > 750.0D2 </cldfrc_premib>
@@ -2801,10 +2727,6 @@
<rk_strat_icritc hgrid="4x5" > 9.5e-6 </rk_strat_icritc>
<rk_strat_icritc hgrid="10x15" > 9.5e-6 </rk_strat_icritc>
-<rk_strat_icritc hgrid="512x1024" > 30.0e-6 </rk_strat_icritc>
-<rk_strat_icritc hgrid="256x512" > 20.0e-6 </rk_strat_icritc>
-<rk_strat_icritc hgrid="128x256" > 16.0e-6 </rk_strat_icritc>
-<rk_strat_icritc hgrid="48x96" > 1.0e-6 </rk_strat_icritc>
<rk_strat_icritc dyn="se" > 18.0e-6 </rk_strat_icritc>
<rk_strat_icritw > 4.0e-4 </rk_strat_icritw>
@@ -2814,13 +2736,9 @@
<rk_strat_conke > 10.0e-6 </rk_strat_conke>
<rk_strat_conke dyn="fv" > 5.0e-6 </rk_strat_conke>
-<rk_strat_conke dyn="eul" hgrid="512x1024" > 5.0e-6 </rk_strat_conke>
-<rk_strat_conke dyn="eul" hgrid="256x512" > 5.0e-6 </rk_strat_conke>
-<rk_strat_conke dyn="eul" hgrid="128x256" > 5.0e-6 </rk_strat_conke>
<rk_strat_conke dyn="se" > 5.0e-6 </rk_strat_conke>
<rk_strat_r3lcrit > 10.0e-6 </rk_strat_r3lcrit>
-<rk_strat_r3lcrit hgrid="48x96" > 1.0e-6 </rk_strat_r3lcrit>
<!-- hkconv Moist Convection -->
<hkconv_cmftau> 1800.0D0 </hkconv_cmftau>
@@ -2831,10 +2749,6 @@
<hkconv_c0 dyn="fv" hgrid="4x5" > 2.0e-4 </hkconv_c0>
<hkconv_c0 > 2.0e-4 </hkconv_c0>
-<hkconv_c0 hgrid="512x1024" > 1.0e-5 </hkconv_c0>
-<hkconv_c0 hgrid="256x512" > 1.0e-5 </hkconv_c0>
-<hkconv_c0 hgrid="48x96" > 1.0e-4 </hkconv_c0>
-<hkconv_c0 hgrid="128x256" > 1.0e-4 </hkconv_c0>
<hkconv_c0 dyn="se" > 1.0e-4 </hkconv_c0>
<!-- uwshcu Moist Convection -->
@@ -2871,10 +2785,6 @@
<zmconv_c0_lnd microphys="mg3" clubb_sgs="1" phys="cam7" > 0.0075D0 </zmconv_c0_lnd>
<zmconv_c0_lnd dyn="fv" phys="cam4" > 0.0035D0 </zmconv_c0_lnd>
<zmconv_c0_lnd dyn="se" phys="cam4" > 0.0035D0 </zmconv_c0_lnd>
-<zmconv_c0_lnd hgrid="48x96" phys="cam4" > 0.0020D0 </zmconv_c0_lnd>
-<zmconv_c0_lnd hgrid="128x256" phys="cam4" > 0.0040D0 </zmconv_c0_lnd>
-<zmconv_c0_lnd hgrid="256x512" phys="cam4" > 0.0040D0 </zmconv_c0_lnd>
-<zmconv_c0_lnd hgrid="512x1024" phys="cam4" > 0.0040D0 </zmconv_c0_lnd>
<zmconv_c0_ocn > 0.0030D0 </zmconv_c0_ocn>
<zmconv_c0_ocn phys="cam5" > 0.0450D0 </zmconv_c0_ocn>
@@ -2892,10 +2802,6 @@
<zmconv_c0_ocn microphys="mg3" clubb_sgs="1" phys="cam7" > 0.0300D0 </zmconv_c0_ocn>
<zmconv_c0_ocn dyn="fv" phys="cam4" > 0.0035D0 </zmconv_c0_ocn>
<zmconv_c0_ocn dyn="se" phys="cam4" > 0.0035D0 </zmconv_c0_ocn>
-<zmconv_c0_ocn hgrid="48x96" phys="cam4" > 0.0020D0 </zmconv_c0_ocn>
-<zmconv_c0_ocn hgrid="128x256" phys="cam4" > 0.0040D0 </zmconv_c0_ocn>
-<zmconv_c0_ocn hgrid="256x512" phys="cam4" > 0.0040D0 </zmconv_c0_ocn>
-<zmconv_c0_ocn hgrid="512x1024" phys="cam4" > 0.0040D0 </zmconv_c0_ocn>
<zmconv_ke_lnd > 3.0E-6 </zmconv_ke_lnd>
<zmconv_ke_lnd clubb_sgs="1" microphys="mg2" > 1.0E-5 </zmconv_ke_lnd>
@@ -2904,9 +2810,6 @@
<zmconv_ke > 3.0E-6 </zmconv_ke>
<zmconv_ke dyn="fv" > 5.0E-6 </zmconv_ke>
<zmconv_ke dyn="se" > 5.0E-6 </zmconv_ke>
-<zmconv_ke hgrid="128x256" > 5.0E-6 </zmconv_ke>
-<zmconv_ke hgrid="256x512" > 5.0E-6 </zmconv_ke>
-<zmconv_ke hgrid="512x1024" > 5.0E-6 </zmconv_ke>
<zmconv_num_cin > 5 </zmconv_num_cin>
<zmconv_num_cin phys="cam6" > 1 </zmconv_num_cin>
@@ -3002,64 +2905,52 @@
<!-- IOP ARM95/ARM Southern Great Plains/lat:36/lon:263/Jul 1995/18d/M. Zhang et al. (2016)/Land convection -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="arm95" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="arm95" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc</ncdata>
<iopfile scam_iop="arm95" >atm/cam/scam/iop/ARM95_4scam.nc</iopfile>
<co2vmr scam_iop="arm95" > 368.9e-6 </co2vmr>
<!-- IOP ARM97/ARM Southern Great Plains/lat:36/lon:263/Jun 1997/30d/M. Zhang et al. (2016) Land convection -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="arm95" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="arm95" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc</ncdata>
<iopfile scam_iop="arm97" >atm/cam/scam/iop/ARM97_4scam.nc</iopfile>
<co2vmr scam_iop="arm97" > 368.9e-6 </co2vmr>
<!-- IOP ATEX/Atlantic Trade Wind Exp/lat:15/lon:345/Feb 1969/2d/Augstein et al. (1973) Shallow cumulus -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="atex" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-02-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="atex" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-02-01-00000.nc</ncdata>
<iopfile scam_iop="atex" >atm/cam/scam/iop/ATEX_48hr_4scam.nc</iopfile>
<!-- IOP BOMEX/Barbados Ocean and Met Exp/lat:15/lon:300/Jun 1969/5d/Holland and Rasmusson (1973) Shallow cumulus -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="bomex" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="bomex" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc</ncdata>
<iopfile scam_iop="bomex" >atm/cam/scam/iop/BOMEX_5day_4scam.nc</iopfile>
<!-- IOP CGILSS11/CFMIP-GASS SCM/LES Intercomparison/lat:32/lon:231/Jul 1997/30d/M. Zhang et al. (2013) Stratocumulus -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="cgilsS11" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="cgilsS11" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc</ncdata>
<iopfile scam_iop="cgilsS11" >atm/cam/scam/iop/S11_CTL_MixedLayerInit_reduced.nc</iopfile>
<!-- IOP CGILSS12/CFMIP-GASS SCM/LES Intercomparison/lat:35/lon:235/Jul 1997/30d/M. Zhang et al. (2013) Stratus -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="cgilsS12" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="cgilsS12" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc</ncdata>
<iopfile scam_iop="cgilsS12" >atm/cam/scam/iop/S12_CTL_MixedLayerInit_reduced.nc</iopfile>
<!-- IOP CGILSS6/CFMIP-GASS SCM/LES Intercomparison/lat:17/lon:211/Jul 1997/30d/M. Zhang et al. (2013) Shallow cumulus -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="cgilsS6" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="cgilsS6" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc</ncdata>
<iopfile scam_iop="cgilsS6" >atm/cam/scam/iop/S6_CTL_reduced.nc</iopfile>
<!-- IOP DYCOMSRF01/Dynamics of Marine StratoCu/lat:32/lon:239/Jul 15/2001/2d Stevens et al. (2003) Stratocumulus -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="dycomsRF01">atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="dycomsRF01" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc</ncdata>
<iopfile scam_iop="dycomsRF01">atm/cam/scam/iop/DYCOMSrf01_4day_4scam.nc</iopfile>
<!-- IOP DYCOMSRF02/Dynamics of Marine StratoCu/lat:32/lon:239/Jul 11/2001/2d Stevens et al. (2003) Stratocumulus -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="dycomsRF02">atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="dycomsRF02" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc</ncdata>
<iopfile scam_iop="dycomsRF02">atm/cam/scam/iop/DYCOMSrf02_48hr_4scam.nc</iopfile>
<!-- IOP GATEIII/GARP Atlantic Tropical Experiment Phase III/lat:9/lon:336/Aug 1974/20d/Thompson et al.(1979) Tropical convection -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="gateiii" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-08-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="gateIII" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-08-01-00000.nc</ncdata>
<iopfile scam_iop="gateiii" >atm/cam/scam/iop/GATEIII_4scam_c170809.nc</iopfile>
<!-- IOP MICRE/Macquarie Island Cloud Radiation Experiment/lat:-56/lon:141/2017/90d/Marchand R. 2020/Marine -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="micre2017" >atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.ne3np4.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="micre2017" >atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.Gaus_64x128.nc</ncdata>
<iopfile scam_iop="micre2017" >atm/cam/scam/iop/micre2017_3mo.macquarie2017.iop.nc</iopfile>
<!-- IOP MPACE/Mixed Phase Arctic Clouds Exp/lat:71/lon:206/Oct 2004/17d/Verlinde et al. (2007)/Arctic -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="mpace" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-10-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="mpace" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-10-01-00000.nc</ncdata>
<iopfile scam_iop="mpace" >atm/cam/scam/iop/MPACE_4scam.nc</iopfile>
<fincl1 scam_iop="mpace" >
'CLDST', 'CNVCLD',
@@ -3076,12 +2967,10 @@
<!-- IOP RICO/Rain and Cumulus over Oceans/lat:18/lon:299/Dec 2004/3d/Rauber et al. (2007)/Shallow cumulus -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="rico" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="rico" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc</ncdata>
<iopfile scam_iop="rico" >atm/cam/scam/iop/RICO_3day_4scam.nc</iopfile>
<!-- IOP SAS/The Southeast Atmosphere Study (SAS) campaign/lat:32/lon:272/June 2013/30d/Carlton (2018)/Southeast US Air Chemistry -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="SAS" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="SAS" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc</ncdata>
<iopfile scam_iop="SAS" >atm/cam/scam/iop/SAS_ideal_4scam.nc</iopfile>
<co2vmr scam_iop="SAS" > 368.9e-6 </co2vmr>
<use_gw_front scam_iop="SAS" > .false. </use_gw_front>
@@ -3089,56 +2978,23 @@
<!-- IOP SPARTICUS/Small Particles in Cirrus/lat:37/lon:263/Apr 2010/30d/Mace et al. (2009)/Cirrus, convection -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="sparticus" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-04-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="sparticus" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-04-01-00000.nc</ncdata>
<iopfile scam_iop="sparticus" >atm/cam/scam/iop/SPARTICUS_4scam.nc</iopfile>
<!-- IOP TOGAII/Tropical Ocean Global Atmosphere IOP2/lat:-2/lon:154/Dec 1992/21d/Webster and Lukas (1992)/Tropical convection -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="togaII" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-12-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="togaII" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-12-01-00000.nc</ncdata>
<iopfile scam_iop="togaII" >atm/cam/scam/iop/TOGAII_4scam.nc</iopfile>
<!-- IOP TWP06/Tropical W. Pacific Convection/lat:-12/lon:131/Jan 2006/26d/May et al. (2008)/Tropical convection -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="twp06" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-01-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="twp06" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-01-01-00000.nc</ncdata>
<iopfile scam_iop="twp06" >atm/cam/scam/iop/TWP06_4scam.nc</iopfile>
<iradlw scam_iop="twp06" > 1 </iradlw>
<iradsw scam_iop="twp06" > 1 </iradsw>
<!-- IOP USER/User specified IOP forcing/lat:yy/lon:xx/Date:Any/Length:Any/-These are just defaults and can be updated by the user via cime_config/usermods_dir -->
<ncdata hgrid="ne3np4" nlev="32" scam_iop="camfrc" >atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc</ncdata>
-<ncdata hgrid="64x128" nlev="32" scam_iop="camfrc" >atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc</ncdata>
<iopfile scam_iop="camfrc" >atm/cam/scam/iop/ARM97_4scam.nc</iopfile>
-<!-- Eulerian spectral dycore parameters -->
-
-<eul_dif2_coef > 2.5D5 </eul_dif2_coef>
-<eul_dif2_coef hgrid="8x16" > 2.5D7 </eul_dif2_coef>
-
-<!-- The Eulerian hdif coef defaults are for 4th order diffusion -->
-<eul_hdif_order> 4 </eul_hdif_order>
-
-<eul_hdif_kmnhdn> 4 </eul_hdif_kmnhdn>
-
-<eul_hdif_coef > 1.0D18 </eul_hdif_coef>
-<eul_hdif_coef hgrid="32x64" > 2.0D16 </eul_hdif_coef>
-<eul_hdif_coef hgrid="48x96" > 2.0D16 </eul_hdif_coef>
-<eul_hdif_coef hgrid="64x128" > 1.17D16 </eul_hdif_coef>
-<eul_hdif_coef hgrid="128x256" > 7.14D14 </eul_hdif_coef>
-<eul_hdif_coef hgrid="256x512" > 1.5D14 </eul_hdif_coef>
-<eul_hdif_coef hgrid="512x1024"> 1.5D13 </eul_hdif_coef>
-
-<eul_divdampn> 0.0D0 </eul_divdampn>
-<eul_tfilt_eps> 0.06D0 </eul_tfilt_eps>
-<eul_kmxhdc> 5 </eul_kmxhdc>
-
-<eul_nsplit > 1 </eul_nsplit>
-<eul_nsplit hgrid="512x1024"> 12 </eul_nsplit>
-
-<!-- iop dataset for SCAM mode -->
-<iopfile dyn="eul">atm/cam/scam/iop/ARM95_4scam.nc</iopfile>
-
<!-- physics loadbalance -->
-<phys_loadbalance dyn="eul"> 3 </phys_loadbalance>
<phys_loadbalance dyn="fv3"> 2 </phys_loadbalance>
<!-- Control output to history file(s) -->
diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml
index 8458b6e42d..38f643253d 100644
--- a/bld/namelist_files/namelist_definition.xml
+++ b/bld/namelist_files/namelist_definition.xml
@@ -1184,107 +1184,6 @@ If true nudge atmospheric temperature (T) from the meteorology.
Default: true
</entry>
-<!-- Dynamics: Eulerian Spectral -->
-
-<entry id="eul_dif2_coef" type="real" category="dyn_eul"
- group="dyn_eul_inparm" valid_values="" >
-del^2 horizontal diffusion coefficient. This is used above the Nth order
-diffusion.
-Default: set by build-namelist
-</entry>
-
-<entry id="eul_hdif_order" type="integer" category="dyn_eul"
- group="dyn_eul_inparm" valid_values="">
-Order (N) of horizontal diffusion operator used below the sponge layers.
-N must be a positive multiple of 2.
-Default: 4
-</entry>
-
-<entry id="eul_hdif_kmnhdn" type="integer" category="dyn_eul"
- group="dyn_eul_inparm" valid_values="">
-The order N horizontal diffusion operator will be used in and below the
-layer specified by this variable.
-Default: 4
-</entry>
-
-<entry id="eul_hdif_coef" type="real" category="dyn_eul"
- group="dyn_eul_inparm" valid_values="">
-Nth order horizontal diffusion coefficient.
-Default: set by build-namelist
-</entry>
-
-<entry id="eul_divdampn" type="real" category="dyn_eul"
- group="dyn_eul_inparm" valid_values="">
-Number of days (from timestep 0) to run divergence damper. Use only if spectral
-model becomes dynamicallly unstable during initialization. Suggested value:
-2. (Value must be >= 0.) Default: 0.
-</entry>
-
-<entry id="eul_tfilt_eps" type="real" category="dyn_eul"
- group="dyn_eul_inparm" valid_values="">
-Time filter coefficient. Default: 0.06
-</entry>
-
-<entry id="eul_kmxhdc" type="integer" category="dyn_eul"
- group="dyn_eul_inparm" valid_values="">
-Number of levels over which to apply Courant limiter, starting at top of
-model.
-Default: 5
-</entry>
-
-<entry id="eul_nsplit" type="integer" category="dyn_eul"
- group="dyn_eul_inparm" valid_values="" >
-Number of dynamics timesteps per physics timestep. If zero, a best-estimate
-will be automatically calculated.
-Default: 1
-</entry>
-
-<!-- MPI configuration for global spectral dycores (EUL and SLD) -->
-
-<entry id="dyn_allgather" type="integer" category="dyn_spectral_spmd"
- group="spmd_dyn_inparm" valid_values="">
-Spectral dynamics gather option.
- 0: use mpi_allgatherv
- 1: use point-to-point MPI-1 two-sided implementation
- 2: use point-to-point MPI-2 one-sided implementation if supported,
- otherwise use MPI-1 implementation
- 3: use Co-Array Fortran implementation if supported,
- otherwise use MPI-1 implementation
-Default: 0
-</entry>
-
-<entry id="dyn_alltoall" type="integer" category="dyn_spectral_spmd"
- group="spmd_dyn_inparm" valid_values="">
-Spectral dynamics transpose option.
- 0: use mpi_alltoallv
- 1: use point-to-point MPI-1 two-sided implementation
- 2: use point-to-point MPI-2 one-sided implementation if supported,
- otherwise use MPI-1 implementation
- 3: use Co-Array Fortran implementation if supported,
- otherwise use MPI-1 implementation
-Default: 0
-</entry>
-
-<entry id="dyn_equi_by_col" type="logical" category="dyn_spectral_spmd"
- group="spmd_dyn_inparm" valid_values="">
-Flag indicating whether to assign latitudes to equidistribute columns or
-latitudes. This only matters when using a reduced grid.
-Default: TRUE
-</entry>
-
-<entry id="dyn_npes" type="integer" category="dyn_spectral_spmd"
- group="spmd_dyn_inparm" valid_values="">
-Number of processes assigned to dynamics (SE, EUL and SLD dycores).
-Default: Total number of processes assigned to job.
-</entry>
-
-<entry id="dyn_npes_stride" type="integer" category="dyn_spectral_spmd"
- group="spmd_dyn_inparm" valid_values="">
-Stride for dynamics processes (EUL and SLD dycores).
-E.g., if stride=2, assign every second process to the dynamics.
-Default: 1
-</entry>
-
<!-- Gravity Wave Drag -->
<entry id="use_gw_oro" type="logical" category="gw_drag"
diff --git a/bld/namelist_files/use_cases/dabi_p2004.xml b/bld/namelist_files/use_cases/dabi_p2004.xml
deleted file mode 100644
index 113209a1aa..0000000000
--- a/bld/namelist_files/use_cases/dabi_p2004.xml
+++ /dev/null
@@ -1,40 +0,0 @@
-<?xml version="1.0"?>
-
-<namelist_defaults>
-
-<start_ymd> 10101 </start_ymd>
-
-<!-- Initial condition files -->
-<ncdata hgrid="128x256" nlev="30">atm/cam/inic/gaus/DABIp2004.128x256.L30.nc</ncdata>
-<ncdata hgrid="128x256" nlev="60">atm/cam/inic/gaus/DABIp2004.128x256.L60.nc</ncdata>
-<ncdata hgrid="64x128" nlev="30">atm/cam/inic/gaus/DABIp2004.64x128.L30.nc</ncdata>
-
-<!-- Force PHIS to be set to zero -->
-<use_topo_file>.false.</use_topo_file>
-
-<!-- Modified constants -->
-<gravit> 9.806D0 </gravit>
-<rearth> 6.371D6 </rearth>
-<!-- length of sideral day set to give rotation rate of 7.292D-5 sec^-1 -->
-<sday> 86165.45950602833D0 </sday>
-<!-- molec weight of dry air set to give gas const for dry air = 287. J/kg/K -->
-<mwdry> 28.97027035191638D0 </mwdry>
-<!-- Cp dry air set to R/kappa=287./(2./7.) -->
-<cpair> 1004.5D0 </cpair>
-
-<!-- Modified horizontal diffusion -->
-<eul_hdif_order> 2 </eul_hdif_order>
-<eul_hdif_kmnhdn> 1 </eul_hdif_kmnhdn>
-<eul_hdif_coef> 7.D5 </eul_hdif_coef>
-<eul_kmxhdc> 0 </eul_kmxhdc>
-
-<!-- history output customization -->
-<empty_htapes>.true.</empty_htapes>
-<avgflag_pertape>'I'</avgflag_pertape>
-<nhtfrq>-24</nhtfrq>
-<mfilt>30</mfilt>
-<fincl1>
- 'U','V','T','PS','OMEGA'
-</fincl1>
-
-</namelist_defaults>
diff --git a/bld/namelist_files/use_cases/held_suarez_1994.xml b/bld/namelist_files/use_cases/held_suarez_1994.xml
index 4f6ffe13a8..a8ae45148b 100644
--- a/bld/namelist_files/use_cases/held_suarez_1994.xml
+++ b/bld/namelist_files/use_cases/held_suarez_1994.xml
@@ -4,19 +4,9 @@
<start_ymd> 10101 </start_ymd>
-<!-- Initial condition files -->
-<ncdata hgrid="128x256" nlev="30">atm/cam/inic/gaus/HS1994.128x256.L30_c062216.nc</ncdata>
-<ncdata hgrid="128x256" nlev="60">atm/cam/inic/gaus/HS1994.128x256.L60_c061516.nc</ncdata>
-<ncdata hgrid="64x128" nlev="30">atm/cam/inic/gaus/HS1994.64x128.L30_c061616.nc</ncdata>
-
<!-- Perturb initial temperature -->
<pertlim> 1.0D-5 </pertlim>
-<!-- Modified horizontal diffusion -->
-<eul_hdif_order dyn="eul" > 4 </eul_hdif_order>
-<eul_hdif_coef hgrid="64x128" > 1.17D16 </eul_hdif_coef>
-<eul_hdif_coef hgrid="128x256" > 7.14D14 </eul_hdif_coef>
-
<!-- history output customization -->
<nhtfrq>0,-6</nhtfrq>
<fincl2>
diff --git a/bld/namelist_files/use_cases/hist_trop_strat_vbsfire_cam6.xml b/bld/namelist_files/use_cases/hist_trop_strat_vbsfire_cam6.xml
index 791b6f3737..51e3538f47 100644
--- a/bld/namelist_files/use_cases/hist_trop_strat_vbsfire_cam6.xml
+++ b/bld/namelist_files/use_cases/hist_trop_strat_vbsfire_cam6.xml
@@ -61,7 +61,7 @@
'IVOC = 0.033*C2H4 + 0.035*C2H6 + 0.049*C3H6 + 0.052*C3H8 + 0.066*BIGENE + 0.068*BIGALK + 0.068*CH3COCH3 + 0.085*MEK + 0.052*CH3CHO + 0.035*CH2O + 0.108*TOLUENE + 0.092*BENZENE + 0.125*XYLENE'
</fire_emis_specifier>
<fire_emis_elevated>.false.</fire_emis_elevated>
-<fire_emis_factors_file>lnd/clm2/firedata/fire_emission_factors_78PFTs_c20220111.nc</fire_emis_factors_file>
+<fire_emis_factors_file>lnd/clm2/firedata/fire_emission_factors_78PFTs_c20240624.nc</fire_emis_factors_file>
<ext_frc_type>INTERP_MISSING_MONTHS</ext_frc_type>
diff --git a/bld/scripts/remapfv2eul.ncl b/bld/scripts/remapfv2eul.ncl
deleted file mode 100644
index 884831789c..0000000000
--- a/bld/scripts/remapfv2eul.ncl
+++ /dev/null
@@ -1,392 +0,0 @@
-;***************************************************************
-; NCL script to copy or remap all variables of an FV netcdf file
-; to a rectilinear Gaus grid.
-; remapfv2eul.ncl
-; John Truesdale, May 2018
-;***************************************************************
-load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl"
-load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl"
-load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl"
-load "$NCARG_ROOT/lib/ncarg/nclscripts/esmf/ESMF_regridding.ncl"
-
-;*************************************************************
-; EX. USAGE
-;*************************************************************
-;env SRCFILE=/fs/cgd/csm/inputdata/atm/cam/inic/fv/cami-mam3_0000-01-01_0.9x1.25_L32_c141031.nc DSTLATLON=/fs/cgd/csm/inputdata/atm/cam/inic/gaus/cami_0000-01-01_128x256_L26_c030918.nc ncl < remapfv2eul.ncl
-;************************************************************
-
-begin
-;-----The FV source files to be converted
-srcFileName = getenv("SRCFILE")
-
-;-----The destination lat lon template file - any file that has lat lon coordinates
-latlontemp = getenv("DSTLATLON")
-
-outpth="./"
-
-;----- shouldnt have to modify below here -------------
-
-verbose=True ;False
-debug=False ;False
-
-;-----interplation method
-map_method=getenv("MAPMETHOD")
-if (ismissing(map_method)) then
-delete(map_method)
-map_method = "bilinear"
-end if
-
-;-----directory to store weights for regridding
-WGT_dir=getenv("MAPPATH")
-if (ismissing(WGT_dir)) then
-delete(WGT_dir)
-WGT_dir = systemfunc("pwd")
-end if
-
-src_file=addfile(srcFileName,"r")
-dstlatlon_file=addfile(latlontemp,"r")
-
-; Determine ingrid
-srcdnames = getvardims(src_file) ; get level info from source file
-srcdsizes = getfiledimsizes(src_file)
-srcnlat = srcdsizes(ind(srcdnames.eq."lat" ));
-srcnlon = srcdsizes(ind(srcdnames.eq."lon" ));
-ingrid="FV_"+tostring(srcnlat)+"x"+tostring(srcnlon)
-haveslat=False
-if (any(srcdnames.eq."slat")) then
- haveslat=True
- srcnslat = srcdsizes(ind(srcdnames.eq."slat" ));
- ingrid_us="FV_"+tostring(srcnslat)+"x"+tostring(srcnlon)
-else
- ingrid_us="SLAT_dimension_not_found"
-end if
-haveslon=False
-if (any(srcdnames.eq."slon")) then
- haveslon=True
- srcnslon = srcdsizes(ind(srcdnames.eq."slon" ));
- ingrid_vs="FV_"+tostring(srcnlat)+"x"+tostring(srcnslon)
-else
- ingrid_vs="SLON_dimension_not_found"
-end if
-
-; Determine outgrid
-dstdnames = getvardims(dstlatlon_file) ; get level info from source file
-dstdsizes = getfiledimsizes(dstlatlon_file)
-dstnlat = dstdsizes(ind(dstdnames.eq."lat" ));
-dstnlon = dstdsizes(ind(dstdnames.eq."lon" ));
-outgrid="Gaus_"+tostring(dstnlat)+"x"+tostring(dstnlon)
-
-srcFile=systemfunc("basename "+srcFileName)
-suffix = get_file_suffix(srcFile,0)
-srcbase= suffix@fBase
-dstFileName = outpth+srcbase+".regrid."+outgrid+".nc"
-currdate=systemfunc("date +%y%m%d")
-
- ; 0. Set the source/destination file names,
- ; open the source file for reading,
- ; create a destination file for regridded data.
- ;------------------------------------------------
-
- print(" ")
- print("Regridding: ")
- print("SRC File:"+srcFileName)
- print("DST File:"+dstFileName)
- if(fileexists(dstFileName)) then
- system("rm "+dstFileName)
- end if
-
- setfileoption("nc","Format","LargeFile")
- dst_file=addfile(dstFileName,"c")
-
-
-;
- ; 1. Generate a description file for the source grid (EUL).
- ;---------------------------------------------------
- srcGridName=WGT_dir+"/"+ingrid+"_SCRIP_desc.nc"
- srcGridName_us=WGT_dir+"/"+ingrid_us+"_US_SCRIP_desc.nc"
- srcGridName_vs=WGT_dir+"/"+ingrid_vs+"_VS_SCRIP_desc.nc"
- Opt =True
- Opt@ForceOverWrite=True
- Opt@Title ="FV Grid"
- Opt@Debug =False ; True
- Opt@PrintTimings =False ; True
- if(isfilepresent(srcGridName)) then
- if (verbose) then print("Found srcGrid description "+srcGridName) end if
- else
- if (verbose) then print("Creating srcGrid description "+srcGridName) end if
- rectilinear_to_SCRIP(srcGridName,src_file->lat,src_file->lon,Opt)
- end if
- if (haveslat) then
- if(isfilepresent(srcGridName_us)) then
- if (verbose) then print("Found srcGrid description "+srcGridName_us) end if
- else
- if (verbose) then print("Creating srcGrid description "+srcGridName_us) end if
- rectilinear_to_SCRIP(srcGridName_us,src_file->slat,src_file->lon,Opt)
- end if
- end if
- if (haveslon) then
- if(isfilepresent(srcGridName_vs)) then
- if (verbose) then print("Found srcGrid description "+srcGridName_vs) end if
- else
- if (verbose) then print("Creating srcGrid description "+srcGridName_vs) end if
- rectilinear_to_SCRIP(srcGridName_vs,src_file->lat,src_file->slon,Opt)
- end if
- end if
- delete(Opt)
-
- ;
- ; 2. Generate a description file for the destination grid (EUL).
- ;-----------------------------------------------------
- dstGridName = WGT_dir+"/"+outgrid+"_SCRIP_desc.nc"
-
- if(isfilepresent(dstGridName)) then
- if (verbose) then print("Found dstGrid description "+dstGridName) end if
- else
- if (verbose) then print("Creating dstGrid description "+dstGridName) end if
- Opt =True
- Opt@ForceOverWrite=True
- Opt@Debug =False ; True
- Opt@PrintTimings =False ; True
- rectilinear_to_SCRIP(dstGridName,dstlatlon_file->lat,dstlatlon_file->lon,Opt)
- delete(Opt)
- end if
-
- ;
- ; 3. Generate the weights file, using the source and
- ; destination files created in #1 and #2.
- ;-----------------------------------------------------
- wgtFileName = WGT_dir+"/map_"+ingrid+"_to_"+outgrid+"_"+map_method+".nc"
- wgtFileName_us2u = WGT_dir+"/map_"+ingrid_us+"_US_to_"+outgrid+"_U_"+map_method+".nc"
- wgtFileName_vs2v = WGT_dir+"/map_"+ingrid_vs+"_VS_to_"+outgrid+"_V_"+map_method+".nc"
-
- Opt = True
- Opt@InterpMethod =map_method ;"bilinear" "patch", "conserve"
- Opt@ForceOverWrite=True
- Opt@OverWrite=True
- Opt@SrcESMF =False
- Opt@DstESMF =False
- Opt@Debug =False ; True
- Opt@PrintTimings =False ; True
-
- if(isfilepresent(wgtFileName)) then
- if (verbose) then print("Found WeightFiles "+wgtFileName) end if
- else
- if (verbose) then print("Creating WeightFiles "+wgtFileName) end if
- ESMF_regrid_gen_weights(srcGridName,dstGridName,wgtFileName,Opt)
- end if
- if (haveslat) then
- if(isfilepresent(wgtFileName_us2u)) then
- if (verbose) then print("Found WeightFiles "+wgtFileName_us2u) end if
- else
- if (verbose) then print("Creating WeightFile "+wgtFileName_us2u) end if
- ESMF_regrid_gen_weights(srcGridName_us,dstGridName,wgtFileName_us2u,Opt)
- end if
- end if
- if (haveslon) then
- if(isfilepresent(wgtFileName_vs2v)) then
- if (verbose) then print("Found WeightFiles "+wgtFileName_vs2v) end if
- else
- if (verbose) then print("Creating WeightFile "+wgtFileName_vs2v) end if
- ESMF_regrid_gen_weights(srcGridName_vs,dstGridName,wgtFileName_vs2v,Opt)
- end if
- end if
- delete(Opt)
-
-
- ;--- Specify a list of 1D variables on the *source file* that should NOT be copied
- var_in_exclude = (/"lat", "lon", "w_stag", "gw", "slat","slon", "area", "date_written", "time_written"/)
-
- ;--- Specify a list of variables on the source file that should be directly copied
- var_in_copy = (/"time_bnds"/)
-
- ;--- Specify a list of variables to be regridded
- var_out = "All_Variables" ; to be regridded
-
- ;---Read from the weight file the method used to derive the remap weights
- wgt_file = addfile(wgtFileName, "r")
- dst_grid_dims = wgt_file->dst_grid_dims
- dst_mlon = dst_grid_dims(0)
- dst_nlat = dst_grid_dims(1)
- dst_lat = wgt_file->yc_b(::dst_mlon)
- dst_lon = wgt_file->xc_b(:dst_mlon-1)
-
- ;---Use the destination (EUL) grid info on the weight file to create lat/lon
- lat = dst_lat ; get from weight file
- lat@long_name = "latitude"
- lat!0 = "lat"
- lat@units = "degrees_north"
- lat&lat = lat
- nlat = dimsizes(lat) ; same as dst_nlat
-
- lon = dst_lon
- lon@long_name = "longitude"
- lon!0 = "lon"
- lon@units = "degrees_east"
- lon&lon = lon
- mlon = dimsizes(lon) ; same as dst_mlon
-
-
-;---Get all variables on the FV file
- var_in = getfilevarnames( src_file )
- nvar_in = dimsizes(var_in)
- Opt_RGRD = True
-
- if (verbose) then print("creating new file by copying variable meta data from "+srcFile) end if
-
-;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-; PREDEFINE MODE
-;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- setfileoption(dst_file,"DefineMode",True)
-
-;===================================================================
-; create global attributes of the netCDF file containing regridded data
-;===================================================================
- global = True
- global@separator2= "---------------------------------------"
- copy_VarAtts(src_file, global)
- global@separator1= "------- SOURCE FILE ATTRIBUTES --------"
-
- if (isatt(src_file,"title")) then
- global@TITLE = "REMAPPED: "+src_file@title
- end if
-
- global@remap = "NCL: ESMF_regrid_with_weights"
- global@map_method = map_method
- global@creation_date = systemfunc("date")
-
- fileattdef( dst_file, global ) ; copy file attributes to netCDF file
-
-;===================================================================
-; predefine the coordinate dimension names and their sizes
-;===================================================================
- dNames = getvardims(src_file) ; get level info from source file
- dSizes = getfiledimsizes(src_file)
- ia = ind(dNames.eq."lev" ) ; # of levels
- ib = ind(dNames.eq."ilev")
- klev = dSizes(ia)
- klevi = dSizes(ib)
- ; standard CAM dimensions
- dimNames = (/"time", "lat", "lon", "lev", "ilev", "nbnd", "chars", "scalar"/)
- dimSizes = (/ -1 , nlat , mlon , klev, klevi , 2 , 8 , 1 /)
- dimUnlim = (/ True , False, False, False , False , False,False ,False /)
- filedimdef(dst_file,dimNames,dimSizes,dimUnlim)
-
-;--- The following are explicitly added because they are 'special'
-
- filevardef(dst_file, "lat", typeof(lat), getvardims(lat))
- filevarattdef(dst_file,"lat" ,lat)
-
- filevardef(dst_file, "lon", typeof(lon), getvardims(lon))
- filevarattdef(dst_file,"lon" ,lon)
-
-; filevardef(dst_file, "gw", typeof(gw), getvardims(gw))
-; filevarattdef(dst_file,"gw" ,gw)
-
-;--- Loop over all variables and predfine meta data
-; do nv=0,nvar_in-1
- do nv=0,nvar_in-1
- if (.not.any(var_in(nv).eq.var_in_exclude)) then
- if(var_out(0).eq."All_Variables" .or. \
- any(var_in(nv).eq.var_out) .or. \
- any(var_in(nv).eq.var_in_copy) ) then
-
- rank_in = dimsizes(getfilevardimsizes(src_file, var_in(nv)))
- if (debug) then print(rank_in+var_in(nv)) end if
- if (rank_in .eq.1 .or. any(var_in(nv).eq.var_in_copy) ) then
- if (debug) then print(var_in(nv)+" rank 1") end if
- filevardef(dst_file, var_in(nv), getfilevartypes(src_file,var_in(nv)) \
- , getfilevardims(src_file,var_in(nv)) )
- end if
- if (rank_in .eq.2 .and. .not.any(var_in(nv).eq.var_in_copy)) then
- if (debug) then print(var_in(nv)+" rank 2 lat lon") end if
- filevardef(dst_file, var_in(nv), getfilevartypes(src_file,var_in(nv)) \
- , (/"lat", "lon" /) )
- end if
- if (rank_in .eq.3 .and. .not.any(var_in(nv).eq.var_in_copy)) then
- if (debug) then print(var_in(nv)+" rank 3 time lat lon") end if
- filevardef(dst_file, var_in(nv), getfilevartypes(src_file,var_in(nv)) \
- , (/"time","lat", "lon" /) )
- end if
- if (rank_in .eq.4.) then
- vdims = getfilevardims(src_file, var_in(nv))
- if (debug) then print(var_in(nv)+" rank 4 time lev lat lon") end if
- if (var_in(nv).eq."US") then
- if (debug) then print("U rank 4 time lev lat lon") end if
- filevardef(dst_file, "U", getfilevartypes(src_file,var_in(nv)) \
- , (/ "time", vdims(1), "lat", "lon" /) )
- else if (var_in(nv).eq."VS") then
- if (debug) then print("V rank 4 time lev lat lon") end if
- filevardef(dst_file, "V", getfilevartypes(src_file,var_in(nv)) \
- , (/ "time", vdims(1), "lat", "lon" /) )
- else
- if (debug) then print(var_in(nv)+" rank 4 time lev lat lon") end if
- filevardef(dst_file, var_in(nv), getfilevartypes(src_file,var_in(nv)) \
- , (/ "time", vdims(1), "lat", "lon" /) )
- end if
- end if
- delete(vdims)
- end if
- dumAtts = new( 1, getfilevartypes(src_file,var_in(nv)))
- varAtts = getfilevaratts(src_file, var_in(nv))
- if (.not.ismissing(varAtts(0))) then
- nAtts = dimsizes(varAtts)
- do na=0,nAtts-1
- dumAtts@$varAtts(na)$ = src_file->$var_in(nv)$@$varAtts(na)$
- end do
- if (var_in(nv).eq."US") then
- filevarattdef(dst_file, "U" , dumAtts)
- else if (var_in(nv).eq."VS") then
- filevarattdef(dst_file, "V" , dumAtts)
- else
- filevarattdef(dst_file, var_in(nv) , dumAtts)
- end if
- end if
- end if
- delete([/varAtts, dumAtts/]) ; may change size next iteration
- end if
- end if
- end do ; nv
-
-;===================================================================
-; explicitly exit file definition mode. **NOT REQUIRED in NCL**
-;===================================================================
- setfileoption(dst_file,"DefineMode",False)
-
-;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-; Write the basic and regridded data values to the predefined structures
-;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- if (verbose) then print("regridding all variables ... ") end if
-
- dst_file->lat = (/ lat /)
- dst_file->lon = (/ lon /)
-; dst_file->gw = (/ gw /)
-
- do nv=0,nvar_in-1
-
- if (.not.any(var_in(nv).eq.var_in_exclude)) then
- if(var_out(0).eq."All_Variables" .or. \
- any(var_in(nv).eq.var_out) .or. \
- any(var_in(nv).eq.var_in_copy) ) then
-
- rank_in = dimsizes(getfilevardimsizes(src_file, var_in(nv)))
-
- if (rank_in .eq.1 .or. any(var_in(nv).eq.var_in_copy) ) then
- dst_file->$var_in(nv)$ = (/ src_file->$var_in(nv)$ /)
- end if
- if (rank_in .ge.2 .and. .not.any(var_in(nv).eq.var_in_copy)) then
- if (debug) then print(var_in(nv)) end if
- if (var_in(nv).eq."VS") then
- dst_file->V = (/ ESMF_regrid_with_weights(src_file->$var_in(nv)$,wgtFileName_vs2v,Opt_RGRD) /)
- else if (var_in(nv).eq."US") then
- dst_file->U = (/ ESMF_regrid_with_weights(src_file->$var_in(nv)$,wgtFileName_us2u,Opt_RGRD) /)
- else
- dst_file->$var_in(nv)$ = (/ ESMF_regrid_with_weights(src_file->$var_in(nv)$,wgtFileName,Opt_RGRD) /)
- end if
- end if
- end if
- end if
- end if
- if (nv.ne.nvar_in-1) then system("echo -n .") else system("echo .") end if
- end do ; nv
- if (verbose) then print("Finished!!") end if
-end
diff --git a/cime_config/buildcpp b/cime_config/buildcpp
index a5016f95f2..fac7dcbf68 100644
--- a/cime_config/buildcpp
+++ b/cime_config/buildcpp
@@ -49,21 +49,6 @@ def buildcpp(case):
atm_grid = match.groups()[0]
nlev = match.groups()[1]
- # The following translations are hard-wired to support the differences
- # between how the CESM scripts specify the grid and how it is specified
- # by CAM's build and run system.
-
- if atm_grid == 'T5':
- atm_grid = '8x16'
- if atm_grid == 'T31':
- atm_grid = '48x96'
- if atm_grid == 'T42':
- atm_grid = '64x128'
- if atm_grid == 'T85':
- atm_grid = '128x256'
- if atm_grid == 'T341':
- atm_grid = '512x1024'
-
# Need to relax this error tolerance for the SE variable resolution grids
if atm_grid[0:3] == 'ne0':
case.set_value("EPS_AAREA", "1.0e-04")
diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml
index f2bca766ce..d0bdf4cafc 100644
--- a/cime_config/config_component.xml
+++ b/cime_config/config_component.xml
@@ -12,7 +12,7 @@
<desc atm="CAM60[%1PCT][%4xCO2][%CT1S][%CT2S][%CFIRE][%CVBSX][%NUDG][%PORT][%RCO2][%SCAM][%SDYN][%WCCM][%WCMD][%WCSC][%WCTS][%WXIE][%WXIED][%HEMCO][%GEOSCHEM][%SCAMARM95][%SCAMARM97][%SCAMATEX][%SCAMBOMEX][%SCAMCGILSS11][%SCAMCGILSS12][%SCAMCGILSS6][%SCAMDYCOMSRF01][%SCAMDYCOMSRF02][%SCAMGATE3][%SCAMMPACE][%SCAMRICO][%SCAMSPARTICUS][%SCAMTOGA2][%SCAMTWP06][%SCAMCAMFRC]" >CAM cam6 physics:</desc>
<desc atm="CAM50[%CT1S][%CLB][%PORT][%RCO2][%MAM7][%SCAM][%SDYN][%WCSC][%WCTS][%SCAMARM95][%SCAMARM97][%SCAMATEX][%SCAMBOMEX][%SCAMCGILSS11][%SCAMCGILSS12][%SCAMCGILSS6][%SCAMDYCOMSRF01][%SCAMDYCOMSRF02][%SCAMGATE3][%SCAMMPACE][%SCAMRICO][%SCAMSPARTICUS][%SCAMTOGA2][%SCAMTWP06][%SCAMCAMFRC]" >CAM cam5 physics:</desc>
<desc atm="CAM40[%PORT][%RCO2][%SCAM][%SDYN][%TMOZ][%WX][%WXIE][%WXIED][%WCCM][%WCMD][%SCAMARM95][%SCAMARM97][%SCAMATEX][%SCAMBOMEX][%SCAMCGILSS11][%SCAMCGILSS12][%SCAMCGILSS6][%SCAMDYCOMSRF01][%SCAMDYCOMSRF02][%SCAMGATE3][%SCAMMPACE][%SCAMRICO][%SCAMSPARTICUS][%SCAMTOGA2][%SCAMTWP06][%SCAMCAMFRC]" >CAM cam4 physics:</desc>
- <desc atm="CAM[%ADIAB][%DABIP04][%TJ16][%GRAYRAD][%HS94][%KESSLER][%RCO2]" >CAM simplified and non-versioned physics :</desc>
+ <desc atm="CAM[%ADIAB][%TJ16][%GRAYRAD][%HS94][%KESSLER][%RCO2]" >CAM simplified and non-versioned physics :</desc>
<!--
===============
@@ -73,7 +73,6 @@
===============
-->
<desc option="ADIAB" >CAM dry adiabatic configurarion (no physics forcing):</desc>
- <desc option="DABIP04" >CAM dry adiabatic baroclinic instability (Polvani et al., 2004):</desc>
<desc option="TJ16" >CAM moist Held-Suarez forcing (Thatcher and Jablonowski, 2016):</desc>
<desc option="GRAYRAD" >CAM moist simple model (Frierson, 2006):</desc>
<desc option="HS94" >CAM dry Held-Suarez forcing (Held and Suarez (1994)):</desc>
@@ -107,10 +106,9 @@
<entry id="CAM_DYCORE">
<type>char</type>
- <valid_values>eul,fv,fv3,se,mpas</valid_values>
+ <valid_values>fv,fv3,se,mpas</valid_values>
<default_value>fv</default_value>
<values match="last">
- <value grid="a%T[1-9]" >eul</value>
<value grid="a%ne[0-9]">se</value>
<value grid="a%C[0-9]" >fv3</value>
<value grid="a%mpasa[0-9]">mpas</value>
@@ -187,7 +185,6 @@
<!-- Simple models -->
<value compset="_CAM%ADIAB">-phys adiabatic</value>
- <value compset="_CAM%DABIP04">-phys adiabatic</value>
<value compset="_CAM%TJ16">-phys tj2016 -analytic_ic</value>
<value compset="_CAM%GRAYRAD">-phys grayrad -analytic_ic</value>
<value compset="_CAM%HS94">-phys held_suarez -analytic_ic</value>
@@ -308,7 +305,6 @@
<value compset="_CAM60%.*CT2S%SDYN" >sd_trop_strat2_cam6</value>
<value compset="_CAM60%SDYN_CLM50" >sd_cam6</value>
- <value compset="2000_CAM%DABIP04" >dabi_p2004</value>
<value compset="CAM%HS94" >held_suarez_1994</value>
<value compset="CAM%TJ16" >dctest_tj2016</value>
<value compset="CAM%GRAYRAD" >dctest_frierson</value>
diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml
index 80fda94f43..91301d47dc 100644
--- a/cime_config/config_compsets.xml
+++ b/cime_config/config_compsets.xml
@@ -80,20 +80,9 @@
<!-- CAM simpler model compsets -->
- <compset>
- <alias>FDABIP04</alias>
- <lname>2000_CAM%DABIP04_SLND_SICE_SOCN_SROF_SGLC_SWAV</lname>
- <science_support grid="T42z30_T42_mg17"/>
- <science_support grid="T85z30_T85_mg17"/>
- <science_support grid="T85z60_T85_mg17"/>
- </compset>
-
<compset>
<alias>FHS94</alias>
<lname>2000_CAM%HS94_SLND_SICE_SOCN_SROF_SGLC_SWAV</lname>
- <science_support grid="T42z30_T42_mg17"/>
- <science_support grid="T85z30_T85_mg17"/>
- <science_support grid="T85z60_T85_mg17"/>
</compset>
<compset>
@@ -114,103 +103,86 @@
<compset>
<alias>FSCAMARM95</alias>
<lname>2000_CAM60%FSCAMARM95_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMARM97</alias>
<lname>2000_CAM60%SCAMARM97_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMATEX</alias>
<lname>2000_CAM60%SCAMATEX_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMBOMEX</alias>
<lname>2000_CAM60%SCAMBOMEX_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMCGILSS11</alias>
<lname>2000_CAM60%SCAMCGILSS11_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMCGILSS12</alias>
<lname>2000_CAM60%SCAMCGILSS12_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMCGILSS6</alias>
<lname>2000_CAM60%SCAMCGILSS6_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMDYCOMSRF01</alias>
<lname>2000_CAM60%SCAMDYCOMSRF01_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMDYCOMSRF02</alias>
<lname>2000_CAM60%SCAMDYCOMSRF02_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMGATE3</alias>
<lname>2000_CAM60%SCAMGATE3_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMMPACE</alias>
<lname>2000_CAM60%SCAMMPACE_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMRICO</alias>
<lname>2000_CAM60%SCAMRICO_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMSPARTICUS</alias>
<lname>2000_CAM60%SCAMSPARTICUS_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMTOGA2</alias>
<lname>2000_CAM60%SCAMTOGA2_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMTWP06</alias>
<lname>2000_CAM60%SCAMTWP06_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FSCAMCAMFRC</alias>
<lname>2000_CAM60%SCAMCAMFRC_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
<alias>FCSCAM</alias>
<lname>2000_CAM60%SCAM%CT1S_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV</lname>
- <science_support grid="T42_T42"/>
</compset>
<compset>
diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml
index 46117e6067..7b57d05162 100644
--- a/cime_config/testdefs/testlist_cam.xml
+++ b/cime_config/testdefs/testlist_cam.xml
@@ -350,37 +350,6 @@
<option name="wallclock">00:30:00</option>
</options>
</test>
-<!-- 111 tmc -->
- <test compset="QPC5" grid="T5_T5_mg37" name="TMC_D" testmods="cam/ghgrmp_e8">
- <machines>
- <machine name="izumi" compiler="nag" category="aux_cam"/>
- <machine name="izumi" compiler="nag" category="prealpha"/>
- </machines>
- <options>
- <option name="comment" >111 tmc</option>
- <option name="wallclock">00:30:00</option>
- </options>
- </test>
-<!-- 113 tsm, ter, T8 -->
- <test compset="QPC4" grid="T5_T5_mg37" name="ERC_D_Ln9" testmods="cam/outfrq3s_usecase">
- <machines>
- <machine name="izumi" compiler="nag" category="aux_cam"/>
- </machines>
- <options>
- <option name="comment" >113 tsm, ter</option>
- <option name="wallclock">00:30:00</option>
- </options>
- </test>
-<!-- 114 tsm, ter, tbr, tbl -->
- <test compset="QPC4" grid="T5_T5_mg37" name="ERI_D_Ln18" testmods="cam/co2rmp">
- <machines>
- <machine name="izumi" compiler="gnu" category="aux_cam"/>
- </machines>
- <options>
- <option name="comment" >114 tsm, ter, tbr</option>
- <option name="wallclock">00:30:00</option>
- </options>
- </test>
<!-- 311 -->
<test compset="QPC5" grid="f10_f10_mg37" name="ERI_D_Ln18" testmods="cam/outfrq3s_eoyttrac">
<machines>
@@ -1252,17 +1221,6 @@
<option name="wallclock">00:30:00</option>
</options>
</test>
-<!-- 002 tsc -->
- <test compset="QPC4" grid="T42_T42_mg17" name="SCT_D_Ln7" testmods="cam/scm_prep">
- <machines>
- <machine name="izumi" compiler="gnu" category="aux_cam"/>
- <machine name="izumi" compiler="gnu" category="test_scam"/>
- </machines>
- <options>
- <option name="comment" >002 tsc</option>
- <option name="wallclock">00:30:00</option>
- </options>
- </test>
<test compset="QPC6" grid="ne3_ne3_mg37" name="SCT_D_Ln7" testmods="cam/scm_prep_c6">
<machines>
<machine name="izumi" compiler="gnu" category="aux_cam"/>
@@ -1273,17 +1231,6 @@
<option name="wallclock">00:30:00</option>
</options>
</test>
-<!-- sc004 tsc -->
- <test compset="QPC6" grid="T42_T42_mg17" name="SCT_D_Ln7" testmods="cam/scm_prep_c6">
- <machines>
- <machine name="izumi" compiler="gnu" category="aux_cam"/>
- <machine name="izumi" compiler="gnu" category="test_scam"/>
- </machines>
- <options>
- <option name="comment" >004 tsc</option>
- <option name="wallclock">00:30:00</option>
- </options>
- </test>
<test compset="QPC6" grid="f10_f10_mg37" name="SMS_D_Ln9" testmods="cam/outfrq3s_ba">
<machines>
<machine name="izumi" compiler="nag" category="aux_cam"/>
@@ -1293,37 +1240,6 @@
<option name="wallclock">00:30:00</option>
</options>
</test>
-<!-- 003 -->
- <test compset="QPSCAMC5" grid="T42_T42_mg17" name="SMS_D_Ln7" testmods="cam/scmarm">
- <machines>
- <machine name="izumi" compiler="nag" category="aux_cam"/>
- <machine name="izumi" compiler="nag" category="test_scam"/>
- </machines>
- <options>
- <option name="comment" >003 tsm</option>
- <option name="wallclock">00:30:00</option>
- </options>
- </test>
-<!-- 150 -->
- <test compset="FDABIP04" grid="T42_T42_mg17" name="ERC_D_Ln9" testmods="cam/outfrq3s_usecase">
- <machines>
- <machine name="derecho" compiler="intel" category="aux_cam"/>
- </machines>
- <options>
- <option name="comment" >150 tsm, ter</option>
- <option name="wallclock">00:30:00</option>
- </options>
- </test>
-<!-- 151 -->
- <test compset="FHS94" grid="T42_T42_mg17" name="ERC_D_Ln9" testmods="cam/outfrq3s_usecase">
- <machines>
- <machine name="derecho" compiler="intel" category="aux_cam"/>
- </machines>
- <options>
- <option name="comment" >151 tsm, ter</option>
- <option name="wallclock">00:30:00</option>
- </options>
- </test>
<!-- 331 -->
<test compset="QPC41850" grid="f45_f45_mg37" name="ERI_D_Ln18" testmods="cam/co2rmp_usecase">
<machines>
@@ -1469,18 +1385,6 @@
<option name="comment" >Derecho Spectral Element SCAM BFB test with CAM (Intel)</option>
</options>
</test>
-<!-- 001 -->
- <test compset="QPC5" grid="T42_T42_mg17" name="SCT_D_Ln7" testmods="cam/scm_prep">
- <machines>
- <machine name="derecho" compiler="intel" category="aux_cam"/>
- <machine name="derecho" compiler="intel" category="test_scam"/>
- <machine name="derecho" compiler="intel" category="prealpha"/>
- </machines>
- <options>
- <option name="comment" >001 tsc</option>
- <option name="wallclock">00:30:00</option>
- </options>
- </test>
<test compset="F2000climo" grid="mpasa120_mpasa120" name="ERS_Ln9_P288x1" testmods="cam/outfrq9s_mpasa120">
<machines>
@@ -1530,36 +1434,6 @@
<!-- CAM Simple Models -->
- <test compset="FDABIP04" grid="T42z30_T42_mg17" name="ERP_D_Ln9" testmods="cam/outfrq9s">
- <machines>
- <machine name="izumi" compiler="nag" category="prealpha"/>
- </machines>
- </test>
- <test compset="FDABIP04" grid="T85z30_T85_mg17" name="ERP_D_Ln9" testmods="cam/outfrq9s">
- <machines>
- <machine name="izumi" compiler="nag" category="prebeta"/>
- </machines>
- </test>
- <test compset="FDABIP04" grid="T85z60_T85_mg17" name="ERP_D_Ln9" testmods="cam/outfrq9s">
- <machines>
- <machine name="izumi" compiler="nag" category="prebeta"/>
- </machines>
- </test>
- <test compset="FHS94" grid="T42_T42_mg17" name="ERP_D_Ln9" testmods="cam/outfrq9s">
- <machines>
- <machine name="izumi" compiler="nag" category="prealpha"/>
- </machines>
- </test>
- <test compset="FHS94" grid="T85z30_T85_mg17" name="ERP_D_Ln9" testmods="cam/outfrq9s">
- <machines>
- <machine name="izumi" compiler="nag" category="prebeta"/>
- </machines>
- </test>
- <test compset="FHS94" grid="T85z60_T85_mg17" name="ERP_D_Ln9" testmods="cam/outfrq9s">
- <machines>
- <machine name="izumi" compiler="nag" category="prebeta"/>
- </machines>
- </test>
<test compset="FKESSLER" grid="f19_f19_mg17" name="ERP_D_Ln9" testmods="cam/outfrq9s">
<machines>
<machine name="izumi" compiler="nag" category="prealpha"/>
@@ -1576,28 +1450,6 @@
</options>
</test>
-<!-- CAM SCAM runs -->
- <test compset="FSCAMARM97" grid="T42_T42" name="SMS_D_Ln9" testmods="cam/outfrq9s">
- <machines>
- <machine name="derecho" compiler="intel" category="aux_cam"/>
- <machine name="derecho" compiler="intel" category="test_scam"/>
- </machines>
- <options>
- <option name="comment" >Eulerian ARM97 IOP SCAM Smoke test</option>
- <option name="wallclock">00:10:00</option>
- </options>
- </test>
- <test compset="FSCAMMPACE" grid="T42_T42" name="SMS_D_Ln9" testmods="cam/outfrq9s">
- <machines>
- <machine name="derecho" compiler="intel" category="prealpha"/>
- <machine name="derecho" compiler="intel" category="test_scam"/>
- </machines>
- <options>
- <option name="comment" >pre_alpha Eulerian MPACE IPO SCAM Smoke test</option>
- <option name="wallclock">00:10:00</option>
- </options>
- </test>
-
<!-- @@@@@@@@@@@@@@@@@@@@@@@@@@@ -->
<!-- CAM COMPSETS for testing only -->
<!-- (unsupported) -->
diff --git a/cime_config/testdefs/testmods_dirs/cam/ghgrmp_e8/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/ghgrmp_e8/user_nl_cam
index a7ccd4decc..579aff2cbc 100644
--- a/cime_config/testdefs/testmods_dirs/cam/ghgrmp_e8/user_nl_cam
+++ b/cime_config/testdefs/testmods_dirs/cam/ghgrmp_e8/user_nl_cam
@@ -26,5 +26,3 @@ FINCL4 = 'T:I ','U:I ','V:I ','Q:I ','DTCOND:I ',
'PS:I ','PHIS:I ','FU ','FV ','RELHUM:I ',
collect_column_output = .false.,.false.,.true.,.true.
-
-eul_divdampn=1.
diff --git a/doc/ChangeLog b/doc/ChangeLog
index cb0780103d..1f5f6feb7c 100644
--- a/doc/ChangeLog
+++ b/doc/ChangeLog
@@ -1,5 +1,195 @@
===============================================================
+Tag name: cam6_4_068
+Originator(s): eaton
+Date: 19 February 2025
+One-line Summary: remove Eulerian dycore; fix fire emissions
+Github PR URL: https://github.com/ESCOMP/CAM/pull/1215
+
+Purpose of changes (include the issue number and title text for each relevant GitHub issue):
+
+Resolve issue #1170 - Remove Eulerian dycore from cam_development
+
+Resolve issue #1148 - Update fire_emissions_factors in hist_trop_strat_vbsfire_cam6 usecase
+
+Describe any changes made to build system:
+. remove option to build 'eul' dycore
+
+Describe any changes made to the namelist: none
+
+List any changes to the defaults for the boundary datasets:
+. change value of fire_emis_factors_file to
+ lnd/clm2/firedata/fire_emission_factors_78PFTs_c20240624.nc
+
+Describe any substantial timing or memory changes: none
+
+Code reviewed by: cacraig
+
+List all files eliminated:
+
+bld/namelist_files/use_cases/dabi_p2004.xml
+. only set up for Eul dycore.
+
+bld/scripts/remapfv2eul.ncl
+. only used by SCAM w/ Eulerian dycore.
+
+src/advection/*
+. The SLT advection code was only being used by the Eulerian dycore.
+
+src/dynamics/eul/*
+. remove Eulerian dycore code.
+
+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 code specific to eul dycore
+
+bld/configure
+. remove eul as a valid value for -dyn.
+. remove code specific to the eul dycore.
+. remove src/advection/slt/ and src/dynamics/eul/ from Filepath
+. remove setting cpp macros PTRM, PTRN, PTRK
+
+bld/config_files/definition.xml
+. remove eul as valid value for dyn
+. remove definitions for trm, trn, trk
+
+bld/config_files/horiz_grid.xml
+. remove eul grid specifications
+
+bld/namelist_files/namelist_definition.xml
+. remove variables eul_*
+. remove variables in group spmd_dyn_inparm
+
+bld/namelist_files/namelist_defaults_cam.xml
+. remove defaults for eul dycore
+. remove unused vars: bndtvdms, bndtvoxid, bndtvsox, caer_emis
+
+bld/namelist_files/use_cases/held_suarez_1994.xml
+. remove eul specific settings
+
+bld/namelist_files/use_cases/hist_trop_strat_vbsfire_cam6.xml
+. change value of fire_emis_factors_file to
+ lnd/clm2/firedata/fire_emission_factors_78PFTs_c20240624.nc
+
+cime_config/buildcpp
+. remove the translations for the Eulerian atm_grid values, e.g., CESM
+ specified T5 but CAM's configure expected 8x16.
+
+cime_config/config_compsets.xml
+. remove science_support for Gaus grids from FDABIP04, FHS94, and
+ all FSCAM* compsets
+. remove FDABIP04 (_CAM%DABIP04_)
+. In the future new tests will be added for FSCAM* compsets using SE
+ dycore.
+
+cime_config/config_component.xml
+. remove eul as valid value for CAM_DYCORE
+. remove modifier %DABIP04 used for FDABIP04 compset
+
+cime_config/testdefs/testlist_cam.xml
+. remove all tests for FDABIP04. They are all set up for Gaussian grids.
+. remove all tests on a Gaussian grid.
+
+cime_config/testdefs/testmods_dirs/cam/ghgrmp_e8/user_nl_cam
+. remove setting for eul_divdampn=1.
+
+src/control/cam_budget.F90
+src/control/history_scam.F90
+src/control/scamMod.F90
+. remove dycore_is('EUL') from conditionals
+
+src/control/cam_history_support.F90
+. adjust comment to indicate that the Gauss grid is no longer supported.
+
+src/control/ncdio_atm.F90
+. remove comment about eulerian dycore.
+
+src/control/cam_control_mod.F90
+. update comment (all dycores are now non-Eulerian).
+
+src/dynamics/se/dycore/interpolate_mod.F90
+. remove old comment
+
+src/physics/cam/cam_diagnostics.F90
+src/physics/cam/physpkg.F90
+src/physics/cam7/physpkg.F90
+. remove dycore_is('EUL') from conditional(s)
+
+src/physics/cam/geopotential.F90
+src/physics/cam/physics_types.F90
+src/physics/camrt/radiation.F90
+ . remove old comment(s) for EUL
+
+src/physics/cam/gw_movmtn.F90
+. add missing _r8 at line 488
+
+src/physics/simple/physpkg.F90
+. remove old comment
+. remove dycore_is('EUL') from conditional
+
+src/utils/cam_grid_support.F90
+. remove 'EUL' case and remove old comment
+
+src/utils/cam_pio_utils.F90
+src/utils/spmd_utils.F90
+. remove old comment(s)
+
+test/system/TR8.sh
+. remove filepaths for eul dycore and advection.
+. fix expression at line 33 which should be incrementing rc, not just
+ setting it with the current value from the carma directory.
+
+tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_Create_field_Master_List.ncl
+tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_ERAI.csh
+tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90-EXTEND
+tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90-ORIG
+tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_procedures.ncl
+tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.stub
+tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC.ncl
+tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90
+tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_extract_analyses_info.ncl
+tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_Create_field_Master_List.ncl
+tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_se_procedures.ncl
+tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/MAKEIC.stub
+tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/MAKEIC.f90
+tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_extract_analyses_info.ncl
+. remove references to EUL dycore
+
+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:
+
+ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: NLFAIL)
+- missing namelist dyn_eul_inparm
+
+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. Compset FCfireHIST has answer
+ changes due to updating fire_emis_factors_file. This compset isn't tested
+ in aux_cam.
+
+===============================================================
+===============================================================
+
Tag name: cam6_4_067
Originator(s): eaton
Date: 15 February 2025
diff --git a/src/advection/slt/bandij.F90 b/src/advection/slt/bandij.F90
deleted file mode 100644
index 5e0fa303f2..0000000000
--- a/src/advection/slt/bandij.F90
+++ /dev/null
@@ -1,85 +0,0 @@
-
-subroutine bandij(dlam ,phib ,lamp ,phip ,iband , &
- jband ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Calculate longitude and latitude indices that identify the
-! intervals on the extended grid that contain the departure points.
-! Upon entry, all dep. points should be within jintmx intervals of the
-! Northern- and Southern-most model latitudes. Note: the algorithm
-! relies on certain relationships of the intervals in the Gaussian grid.
-!
-! Method:
-! dlam Length of increment in equally spaced longitude grid (rad.)
-! phib Latitude values for the extended grid.
-! lamp Longitude coordinates of the points. It is assumed that
-! 0.0 .le. lamp(i) .lt. 2*pi .
-! phip Latitude coordinates of the points.
-! iband Longitude index of the points. This index points into
-! the extended arrays, e.g.,
-! lam(iband(i)) .le. lamp(i) .lt. lam(iband(i)+1) .
-! jband Latitude index of the points. This index points into
-! the extended arrays, e.g.,
-! phib(jband(i)) .le. phip(i) .lt. phib(jband(i)+1) .
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
- use scanslt, only: platd, i1
-
- implicit none
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: dlam(platd) ! longitude increment
- real(r8), intent(in) :: phib(platd) ! latitude coordinates of model grid
- real(r8), intent(in) :: lamp(plon,plev) ! longitude coordinates of dep. points
- real(r8), intent(in) :: phip(plon,plev) ! latitude coordinates of dep. points
- integer , intent(in) :: nlon ! number of longitudes
- integer , intent(out) :: iband(plon,plev,4) ! longitude index of dep. points
- integer , intent(out) :: jband(plon,plev) ! latitude index of dep. points
-!-----------------------------------------------------------------------
-!
-!---------------------------Local workspace-----------------------------
-!
- integer i,j,k ! indices
- real(r8) dphibr ! reciprocal of an approximate del phi
- real(r8) phibs ! latitude of southern-most latitude
- real(r8) rdlam(platd) ! reciprocal of longitude increment
-!
-!-----------------------------------------------------------------------
-!
- dphibr = 1._r8/( phib(platd/2+1) - phib(platd/2) )
- phibs = phib(1)
- do j = 1,platd
- rdlam(j) = 1._r8/dlam(j)
- end do
-!
-! Loop over level and longitude
-
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i = 1,nlon
-!
-! Latitude indices.
-!
- jband(i,k) = int ( (phip(i,k) - phibs)*dphibr + 1._r8 )
- if( phip(i,k) >= phib(jband(i,k)+1) ) then
- jband(i,k) = jband(i,k) + 1
- end if
-!
-! Longitude indices.
-!
- iband(i,k,1) = i1 + int( lamp(i,k)*rdlam(jband(i,k)-1))
- iband(i,k,2) = iband(i,k,1)
- iband(i,k,3) = iband(i,k,1)
- iband(i,k,4) = iband(i,k,1)
- end do
- end do
-
- return
-end subroutine bandij
diff --git a/src/advection/slt/basdy.F90 b/src/advection/slt/basdy.F90
deleted file mode 100644
index f5a9a235f6..0000000000
--- a/src/advection/slt/basdy.F90
+++ /dev/null
@@ -1,55 +0,0 @@
-
-subroutine basdy(phi ,lbasdy )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute weights for the calculation of derivative estimates at the two
-! center points of the four point stencil for each interval in the
-! unequally spaced latitude grid. Estimates are from differentiating
-! a Lagrange cubic polynomial through the four point stencil.
-!
-! Method:
-! phi Latitude values in the extended grid.
-! lbasdy Weights for derivative estimates based on Lagrange cubic
-! polynomial on the unequally spaced latitude grid.
-! If grid interval j (in extended grid) is surrounded by
-! a 4 point stencil, then the derivative at the "bottom"
-! of the interval uses the weights lbasdy(1,1,j),
-! lbasdy(2,1,j), lbasdy(3,1,j), and lbasdy(4,1,j).
-! The derivative at the "top" of the interval
-! uses lbasdy(1,2,j), lbasdy(2,2,j), lbasdy(3,2,j),
-! and lbasdy(4,2,j).
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use scanslt, only: nxpt, platd
- implicit none
-
-!------------------------------Parameters-------------------------------
- integer, parameter :: jfirst = nxpt + 1 ! first index to be computed
- integer, parameter :: jlast = platd - nxpt - 1 ! last index to be computed
-!-----------------------------------------------------------------------
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: phi(platd) ! latitude coordinates of model grid
- real(r8), intent(out) :: lbasdy(4,2,platd) ! derivative estimate weights
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer jj ! index
-!-----------------------------------------------------------------------
-!
- do jj = jfirst,jlast
- call lcdbas( phi(jj-1), lbasdy(1,1,jj), lbasdy(1,2,jj) )
- end do
-!
- return
-end subroutine basdy
-
diff --git a/src/advection/slt/basdz.F90 b/src/advection/slt/basdz.F90
deleted file mode 100644
index cd6ee79343..0000000000
--- a/src/advection/slt/basdz.F90
+++ /dev/null
@@ -1,53 +0,0 @@
-
-subroutine basdz(pkdim ,sig ,lbasdz )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute weights for the calculation of derivative estimates at two
-! center points of the four point stencil for each interval in the
-! unequally spaced vertical grid (as defined by the array sig).
-! Estimates are from differentiating a Lagrange cubic polynomial
-! through the four point stencil.
-!
-! Method:
-! pkdim Number of grid points in vertical grid.
-! sig Sigma values in the vertical grid.
-! lbasdz Weights for derivative estimates based on Lagrange cubic
-! polynomial on the unequally spaced vertical grid.
-! If grid interval j is surrounded by a 4 point stencil,
-! then the derivative at the "top" of the interval (smaller
-! sigma value) uses the weights lbasdz(1,1,j),lbasdz(2,1,j),
-! lbasdz(3,1,j), and lbasdz(4,1,j). The derivative at the
-! "bottom" of the interval uses lbasdz(1,2,j), lbasdz(2,2,j),
-! lbasdz(3,2,j), and lbasdz(4,2,j). (Recall the vertical
-! level indices increase from the top of the atmosphere
-! towards the bottom.)
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: pkdim ! vertical dimension
- real(r8), intent(in) :: sig(pkdim) ! sigma levels (actually a generic vert. coord)
- real(r8), intent(out):: lbasdz(4,2,pkdim) ! vertical interpolation weights
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer kk ! index
-!-----------------------------------------------------------------------
-!
- do kk = 2,pkdim-2
- call lcdbas( sig(kk-1), lbasdz(1,1,kk), lbasdz(1,2,kk) )
- end do
-!
- return
-end subroutine basdz
-
diff --git a/src/advection/slt/basiy.F90 b/src/advection/slt/basiy.F90
deleted file mode 100644
index c3036bfd3c..0000000000
--- a/src/advection/slt/basiy.F90
+++ /dev/null
@@ -1,44 +0,0 @@
-
-subroutine basiy(phi ,lbasiy )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute weights used in Lagrange cubic polynomial interpolation in
-! the central interval of a four point stencil. Done for each interval
-! in the unequally spaced latitude grid.
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use scanslt, only: nxpt, platd
- implicit none
-
-!------------------------------Parameters-------------------------------
- integer, parameter :: jfirst = nxpt + 1 ! first index to be computed
- integer, parameter :: jlast = platd - nxpt - 1 ! last index to be computed
-!-----------------------------------------------------------------------
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: phi(platd) ! grid values in extended grid
- real(r8), intent(out) :: lbasiy(4,2,platd) ! Weights for Lagrange cubic interp
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer jj ! index
-!-----------------------------------------------------------------------
-!
- do jj = jfirst,jlast
- call lcbas( phi(jj-1),lbasiy(1,1,jj),lbasiy(1,2,jj) )
- end do
-!
- return
-end subroutine basiy
-
diff --git a/src/advection/slt/difcor.F90 b/src/advection/slt/difcor.F90
deleted file mode 100644
index f0c9bdb501..0000000000
--- a/src/advection/slt/difcor.F90
+++ /dev/null
@@ -1,115 +0,0 @@
-
-subroutine difcor(klev ,ztodt ,delps ,u ,v , &
- qsave ,pdel ,pint ,t ,tdif , &
- udif ,vdif ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Add correction term to t and q horizontal diffusions and
-! determine the implied heating rate due to momentum diffusion.
-!
-! Method:
-! 1. Add correction term to t and q horizontal diffusions. This term
-! provides a partial correction of horizontal diffusion on hybrid (sigma)
-! surfaces to horizontal diffusion on pressure surfaces. The appropriate
-! function of surface pressure (delps, which already contains the diffusion
-! coefficient and the time step) is computed during the transform
-! from spherical harmonic coefficients to grid point values. This term
-! can only be applied in the portion of the vertical domain in which
-! biharmonic horizontal diffusion is employed. In addition, the term is
-! unnecessary on pure pressure levels.
-!
-! 2. Determine the implied heating rate due to momentum diffusion in order
-! to conserve total energy and add it to the temperature.
-! Reduce complex matrix (ac) to upper Hessenburg matrix (ac)
-!
-! Author: D. Williamson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plevp, plon
- use physconst, only: cpair, cpvir
- use hycoef, only: hybi
- use cam_control_mod, only : ideal_phys, adiabatic
- implicit none
-
-!------------------------------Arguments--------------------------------
-
- integer , intent(in) :: klev ! k-index of top hybrid level
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(in) :: ztodt ! twice time step unless nstep = 0
- real(r8), intent(in) :: delps(plon) ! srf press function for correction
- real(r8), intent(in) :: u(plon,plev) ! u-wind
- real(r8), intent(in) :: v(plon,plev) ! v-wind
- real(r8), intent(in) :: qsave(plon,plev) ! moisture fm prv fcst
- real(r8), intent(in) :: pdel(plon,plev) ! pdel(k) = pint(k+1) - pint(k)
- real(r8), intent(in) :: pint(plon,plevp) ! pressure at model interfaces
- real(r8), intent(inout) :: t(plon,plev) ! temperature
- real(r8), intent(inout) :: tdif(plon,plev) ! initial/final temperature diffusion
- real(r8), intent(inout) :: udif(plon,plev) ! initial/final u-momentum diffusion
- real(r8), intent(inout) :: vdif(plon,plev) ! initial/final v-momentum diffusion
-
-!---------------------------Local workspace-----------------------------
-
- integer i,k ! longitude, level indices
- real(r8) tcor(plon,plev) ! temperature correction term
-!-----------------------------------------------------------------------
-!
-! Compute the pressure surface correction term for horizontal diffusion of
-! temperature.
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=klev,plev
- if (k==1) then
- do i=1,nlon
- tcor(i,k) = delps(i)*0.5_r8/pdel(i,k)*(hybi(k+1)*(t(i,k+1)-t(i,k)))*pint(i,plevp)
- end do
- else if (k==plev) then
- do i=1,nlon
- tcor(i,k) = delps(i)*0.5_r8/pdel(i,k)*(hybi(k)*(t(i,k)-t(i,k-1)))*pint(i,plevp)
- end do
- else
- do i=1,nlon
- tcor(i,k) = delps(i)*0.5_r8/pdel(i,k)*(hybi(k+1)*(t(i,k+1)-t(i,k)) + &
- hybi(k )*(t(i,k)-t(i,k-1)))*pint(i,plevp)
- end do
- end if
- end do
-!
-! Add the temperture diffusion correction to the diffusive heating term
-! and to the temperature.
-!
- if (.not.adiabatic .and. .not.ideal_phys) then
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=klev,plev
- do i=1,nlon
- tdif(i,k) = tdif(i,k) + tcor(i,k)/ztodt
- t(i,k) = t(i,k) + tcor(i,k)
- end do
- end do
-!
-! Convert momentum diffusion tendencies to heating rates in order to
-! conserve internal energy. Add the heating to the temperature and to
-! diffusive heating term.
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- t(i,k) = t(i,k) - ztodt * (u(i,k)*udif(i,k) + v(i,k)*vdif(i,k)) / &
- (cpair*(1._r8 + cpvir*qsave(i,k)))
- tdif(i,k) = tdif(i,k) - (u(i,k)*udif(i,k) + v(i,k)*vdif(i,k)) / &
- (cpair*(1._r8 + cpvir*qsave(i,k)))
- end do
- end do
- end if
-
- return
-end subroutine difcor
-
diff --git a/src/advection/slt/engy_tdif.F90 b/src/advection/slt/engy_tdif.F90
deleted file mode 100644
index a3826b19cb..0000000000
--- a/src/advection/slt/engy_tdif.F90
+++ /dev/null
@@ -1,58 +0,0 @@
-
-subroutine engy_tdif(cwava ,w ,t ,tm1 ,pdel , &
- difft ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Calculate contribution of current latitude to del-T integral
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plon
- implicit none
-!
-!------------------------------Arguments--------------------------------
-!
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(in) :: cwava ! normalization factor l/(g*plon)
- real(r8), intent(in) :: w ! gaussian weight this latitude
- real(r8), intent(in) :: t (plon,plev) ! temperature
- real(r8), intent(in) :: tm1 (plon,plev) ! temperature (previous timestep)
- real(r8), intent(in) :: pdel(plon,plev) ! pressure diff between interfaces
- real(r8), intent(out) :: difft ! accumulator
-!
-!---------------------------Local variables-----------------------------
-!
- integer i,k ! longitude, level indices
- real(r8) const ! temporary constant
-!
-!-----------------------------------------------------------------------
-!
-! Integration factor (the 0.5 factor arises because gaussian weights sum to 2)
-!
- const = cwava*w*0.5_r8
- difft = 0._r8
-!
-! Compute mass integral
-!
- do k=1,plev
- do i=1,nlon
- difft = difft + pdel(i,k)
- end do
- end do
-
- difft = difft*const
-
- return
-end subroutine engy_tdif
diff --git a/src/advection/slt/engy_te.F90 b/src/advection/slt/engy_te.F90
deleted file mode 100644
index 138f4acb9c..0000000000
--- a/src/advection/slt/engy_te.F90
+++ /dev/null
@@ -1,64 +0,0 @@
-
-subroutine engy_te(cwava ,w ,t ,u ,v , &
- phis ,pdel ,ps ,engy , nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Calculate contribution of current latitude to total energy
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plon
- use physconst, only: cpair
-
- implicit none
-!
-!------------------------------Arguments--------------------------------
-!
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(in) :: cwava ! normalization factor l/(g*plon)
- real(r8), intent(in) :: w ! gaussian weight this latitude
- real(r8), intent(in) :: t (plon,plev) ! temperature
- real(r8), intent(in) :: u (plon,plev) ! u-component
- real(r8), intent(in) :: v (plon,plev) ! v-component
- real(r8), intent(in) :: phis(plon) ! Geopotential
- real(r8), intent(in) :: pdel(plon,plev) ! pressure diff between interfaces
- real(r8), intent(in) :: ps (plon ) ! Surface pressure
- real(r8), intent(out) :: engy ! accumulator
-!
-!---------------------------Local variables-----------------------------
-!
- integer i,k ! longitude, level indices
- real(r8) const ! temporary constant
-!
-!-----------------------------------------------------------------------
-!
-! Integration factor (the 0.5 factor arises because gaussian weights sum to 2)
-!
- const = cwava*w*0.5_r8
- engy = 0._r8
-!
- do k=1,plev
- do i=1,nlon
- engy = engy + ( cpair*t(i,k) + 0.5_r8*( u(i,k)*u(i,k) + v(i,k)*v(i,k) ) )*pdel(i,k)
- end do
- end do
- do i=1,nlon
- engy = engy + phis(i)*ps(i)
- end do
-
- engy = engy*const
-
- return
-end subroutine engy_te
diff --git a/src/advection/slt/extx.F90 b/src/advection/slt/extx.F90
deleted file mode 100644
index c76eee27b9..0000000000
--- a/src/advection/slt/extx.F90
+++ /dev/null
@@ -1,66 +0,0 @@
-
-subroutine extx (pkcnst, pkdim, fb, kloop)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Copy data to the longitude extensions of the extended array
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use scanslt, only: plond, beglatex, endlatex, nxpt, nlonex
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: pkcnst ! dimension construct for 3-D arrays
- integer , intent(in) :: pkdim ! vertical dimension
- real(r8), intent(inout) :: fb(plond,pkdim*pkcnst,beglatex:endlatex) ! constituents
- integer, intent(in) :: kloop ! Limit extent of loop of pkcnst
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i ! longitude index
- integer j ! latitude index
- integer k ! vertical index
- integer nlond ! extended longitude dim
- integer i2pi ! start of eastern long. extension
- integer pk ! k extent to loop over
-!-----------------------------------------------------------------------
-!
-! Fill west edge points.
-!
- pk = pkdim*kloop
- if(nxpt >= 1) then
- do j=beglatex,endlatex
- do i=1,nxpt
- do k=1,pk
- fb(i,k,j) = fb(i+nlonex(j),k,j)
- end do
- end do
- end do
- end if
-!
-! Fill east edge points
-!
- do j=beglatex,endlatex
- i2pi = nxpt + nlonex(j) + 1
- nlond = nlonex(j) + 1 + 2*nxpt
- do i=i2pi,nlond
- do k=1,pk
- fb(i,k,j) = fb(i-nlonex(j),k,j)
- end do
- end do
- end do
-
- return
-end subroutine extx
diff --git a/src/advection/slt/extys.F90 b/src/advection/slt/extys.F90
deleted file mode 100644
index 3a99920c0c..0000000000
--- a/src/advection/slt/extys.F90
+++ /dev/null
@@ -1,137 +0,0 @@
-
-subroutine extys(pkcnst ,pkdim ,fb ,kloop)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Fill latitude extensions of a scalar extended array and
-! Copy data to the longitude extensions of the extended array
-!
-! Method:
-! This is done in 2 steps:
-! 1) interpolate to the pole points; use the mean field value on the
-! Gaussian latitude closest to the pole.
-! 2) add latitude lines beyond the poles.
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plat
- use scanslt, only: nxpt, plond, beglatex, endlatex, platd, nlonex, &
- jintmx
- implicit none
-
-!------------------------------Parameters-------------------------------
- integer, parameter :: istart = nxpt+1 ! index to start computation
- integer, parameter :: js = 1 + nxpt + jintmx ! index of southernmost model lat
- integer, parameter :: jn = plat + nxpt + jintmx ! index of northernmost model lat
-!-----------------------------------------------------------------------
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: pkcnst ! dimensioning construct for 3-D arrays
- integer , intent(in) :: pkdim ! vertical dimension
- real(r8), intent(inout) :: fb(plond,pkdim*pkcnst,beglatex:endlatex) ! Output is same as on entry
- !except with the pole latitude and extensions beyond it filled.
- integer, intent(in) :: kloop ! If you want to limit the extent of looping over pcnst
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i,j,k ! indices
- integer istop ! index to stop computation
- integer nlon2 ! half the number of real longitudes
- real(r8) zave ! accumulator for zonal averaging
- integer pk ! dimension to loop over
-!-----------------------------------------------------------------------
-!
-! Fill north pole line.
-!
- pk = pkdim*kloop
-#if ( defined SPMD )
- if (jn+1<=endlatex) then
-#endif
- do k=1,pkdim*pkcnst
- zave = 0.0_r8
- istop = nxpt + nlonex(jn)
- do i=istart,istop
- zave = zave + fb(i,k,jn )
- end do
- zave = zave/nlonex(jn)
- istop = nxpt + nlonex(jn+1)
- do i=istart,istop
- fb(i,k,jn+1) = zave
- end do
- end do
-#if ( defined SPMD )
- end if
-#endif
-!
-! Fill northern lines beyond pole line.
-!
- if( jn+2 <= platd )then
- do j=jn+2,platd
-#if ( defined SPMD )
- if (j<=endlatex) then
-#endif
- nlon2 = nlonex(j)/2
- do k=1,pk
- do i=istart,istart+nlon2-1
- fb( i,k,j) = fb(nlon2+i,k,2*jn+2-j)
- fb(nlon2+i,k,j) = fb( i,k,2*jn+2-j)
- end do
- end do
-#if ( defined SPMD )
- end if
-#endif
- end do
- end if
-!
-! Fill south pole line.
-!
-#if ( defined SPMD )
- if (js-1>=beglatex) then
-#endif
- do k=1,pk
- zave = 0.0_r8
- istop = nxpt + nlonex(js)
- do i = istart,istop
- zave = zave + fb(i,k,js )
- end do
- zave = zave/nlonex(js)
- istop = nxpt + nlonex(js-1)
- do i=istart,istop
- fb(i,k,js-1) = zave
- end do
- end do
-#if ( defined SPMD )
- end if
-#endif
-!
-! Fill southern lines beyond pole line.
-!
- if( js-2 >= 1 )then
- do j=1,js-2
-#if ( defined SPMD )
- if (j>=beglatex) then
-#endif
- nlon2 = nlonex(j)/2
- do k=1,pk
- do i=istart,istart+nlon2-1
- fb( i,k,j) = fb(nlon2+i,k,2*js-2-j)
- fb(nlon2+i,k,j) = fb( i,k,2*js-2-j)
- end do
- end do
-#if ( defined SPMD )
- end if
-#endif
- end do
- end if
-
- return
-end subroutine extys
diff --git a/src/advection/slt/extyv.F90 b/src/advection/slt/extyv.F90
deleted file mode 100644
index e60125c6d5..0000000000
--- a/src/advection/slt/extyv.F90
+++ /dev/null
@@ -1,177 +0,0 @@
-
-subroutine extyv(pkcnst ,pkdim ,coslam ,sinlam ,ub , &
- vb )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Fill latitude extensions of a vector component extended array.
-!
-! Method:
-! This is done in 2 steps:
-! 1) interpolate to the pole points;
-! use coefficients for zonal wave number 1 on the Gaussian
-! latitude closest to the pole.
-! 2) add latitude lines beyond the poles.
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plat
- use scanslt, only: nxpt, platd, nlonex, beglatex, endlatex, plond, &
- jintmx
- implicit none
-
-!------------------------------Parameters-------------------------------
- integer, parameter :: istart = nxpt+1 ! index to start computation
- integer, parameter :: js = 1 + nxpt + jintmx ! index of southernmost model lat
- integer, parameter :: jn = plat + nxpt + jintmx ! index of northernmost model lat
-!-----------------------------------------------------------------------
-
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer , intent(in) :: pkcnst ! dimensioning construct for 3-D arrays
- integer , intent(in) :: pkdim ! vertical dimension
- real(r8), intent(in) :: coslam(plond,platd) ! Cos of long at x-grid points (global grid)
- real(r8), intent(in) :: sinlam(plond,platd) ! Sin of long at x-grid points (global grid)
- real(r8), intent(inout):: ub(plond,pkdim*pkcnst,beglatex:endlatex) ! U-wind with extents
- real(r8), intent(inout):: vb(plond,pkdim*pkcnst,beglatex:endlatex) ! V-wind with extents
-!
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i ! index
- integer ig ! index
- integer j ! index
- integer k ! index
- integer nlon2 ! half the number of real longitudes
- integer istop ! index to stop computation
- real(r8) zavecv ! accumulator for wavenumber 1 of v
- real(r8) zavesv ! accumulator for wavenumber 1 of v
- real(r8) zavecu ! accumulator for wavenumber 1 of u
- real(r8) zavesu ! accumulator for wavenumber 1 of u
- real(r8) zaucvs ! used to couple u and v (wavenumber 1)
- real(r8) zavcus ! used to couple u and v (wavenumber 1)
-!-----------------------------------------------------------------------
-!
-! Fill north pole line.
-!
-#if ( defined SPMD )
- if (jn+1<=endlatex) then ! north pole is on-processor
-#endif
- do k = 1,pkdim
- zavecv = 0.0_r8
- zavesv = 0.0_r8
- zavecu = 0.0_r8
- zavesu = 0.0_r8
- ig = 0
- istop = nxpt + nlonex(jn)
- do i = istart,istop
- ig = ig + 1
- zavecv = zavecv + vb(i,k,jn )*coslam(ig,jn)
- zavesv = zavesv + vb(i,k,jn )*sinlam(ig,jn)
- zavecu = zavecu + ub(i,k,jn )*coslam(ig,jn)
- zavesu = zavesu + ub(i,k,jn )*sinlam(ig,jn)
- end do
- zavcus = (zavecv + zavesu)/nlonex(jn)
- zaucvs = (zavecu - zavesv)/nlonex(jn)
- ig = 0
- istop = nxpt + nlonex(jn+1)
- do i = istart,istop
- ig = ig + 1
- vb(i,k,jn+1) = zavcus*coslam(ig,jn+1) - zaucvs*sinlam(ig,jn+1)
- ub(i,k,jn+1) = zaucvs*coslam(ig,jn+1) + zavcus*sinlam(ig,jn+1)
- end do
- end do
-#if ( defined SPMD )
- end if
-#endif
-!
-! Fill northern lines beyond pole line.
-!
- if( jn+2 <= platd )then
- do j = jn+2,platd
-#if ( defined SPMD )
- if (j<=endlatex) then
-#endif
- nlon2 = nlonex(j)/2
- do k = 1,pkdim
- do i = istart,istart+nlon2-1
- vb( i,k,j) = -vb(nlon2+i,k,2*jn+2-j)
- vb(nlon2+i,k,j) = -vb( i,k,2*jn+2-j)
- ub( i,k,j) = -ub(nlon2+i,k,2*jn+2-j)
- ub(nlon2+i,k,j) = -ub( i,k,2*jn+2-j)
- end do
- end do
-#if ( defined SPMD )
- end if
-#endif
- end do
- end if
-!
-! Fill south pole line.
-!
-#if ( defined SPMD )
- if (js-1>=beglatex) then ! south pole is on-processor
-#endif
- do k = 1,pkdim
- zavecv = 0.0_r8
- zavesv = 0.0_r8
- zavecu = 0.0_r8
- zavesu = 0.0_r8
- ig = 0
- istop = nxpt + nlonex(js)
- do i = istart,istop
- ig = ig + 1
- zavecv = zavecv + vb(i,k,js )*coslam(ig,js)
- zavesv = zavesv + vb(i,k,js )*sinlam(ig,js)
- zavecu = zavecu + ub(i,k,js )*coslam(ig,js)
- zavesu = zavesu + ub(i,k,js )*sinlam(ig,js)
- end do
- zavcus = (zavecv - zavesu)/nlonex(js)
- zaucvs = (zavecu + zavesv)/nlonex(js)
- ig = 0
- istop = nxpt + nlonex(js-1)
- do i = istart,istop
- ig = ig + 1
- vb(i,k,js-1) = zavcus*coslam(ig,js-1) + zaucvs*sinlam(ig,js-1)
- ub(i,k,js-1) = zaucvs*coslam(ig,js-1) - zavcus*sinlam(ig,js-1)
- end do
- end do
-#if ( defined SPMD )
- end if
-#endif
-!
-! Fill southern lines beyond pole line.
-!
- if( js-2 >= 1 )then
- do j = 1,js-2
-#if ( defined SPMD )
- if (j>=beglatex) then
-#endif
- nlon2 = nlonex(j)/2
- do k = 1,pkdim
- do i = istart,istart+nlon2-1
- vb( i,k,j) = -vb(nlon2+i,k,2*js-2-j)
- vb(nlon2+i,k,j) = -vb( i,k,2*js-2-j)
- ub( i,k,j) = -ub(nlon2+i,k,2*js-2-j)
- ub(nlon2+i,k,j) = -ub( i,k,2*js-2-j)
- end do
- end do
-#if ( defined SPMD )
- end if
-#endif
- end do
- end if
-!
- return
-end subroutine extyv
diff --git a/src/advection/slt/flxint.F90 b/src/advection/slt/flxint.F90
deleted file mode 100644
index 804824f96f..0000000000
--- a/src/advection/slt/flxint.F90
+++ /dev/null
@@ -1,45 +0,0 @@
-
-subroutine flxint (w ,flx ,flxlat ,nlon )
-!-----------------------------------------------------------------------
-!
-! Purpose: Calculate contribution of current latitude to energy flux integral
-!
-! Method:
-!
-! Author: Jerry Olson
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-!
-! Arguments
-!
- real(r8), intent(in) :: w ! gaussian weight this latitude
- real(r8), intent(in) :: flx(plon) ! energy field
-
- integer, intent(in) :: nlon ! number of longitudes
-
- real(r8), intent(out) :: flxlat ! accumulator for given latitude
-!
-! Local variables
-!
- integer :: i ! longitude index
-!
-!-----------------------------------------------------------------------
-!
- flxlat = 0._r8
-!
- do i=1,nlon
- flxlat = flxlat + flx(i)
- end do
-!
-! Integration factor (the 0.5 factor arises because gaussian weights
-! sum to 2)
-!
- flxlat = flxlat*w*0.5_r8/real(nlon,r8)
-!
- return
-end subroutine flxint
diff --git a/src/advection/slt/grdxy.F90 b/src/advection/slt/grdxy.F90
deleted file mode 100644
index 4ab40cb3db..0000000000
--- a/src/advection/slt/grdxy.F90
+++ /dev/null
@@ -1,124 +0,0 @@
-
-subroutine grdxy(dlam ,lam ,phi ,w ,sinlam , &
- coslam )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Define the "extended" grid used in the semi-Lagrangian transport
-! scheme. The longitudes are equally spaced and the latitudes are
-! Gaussian. The global grid is extended to include "wraparound" points
-! on all sides.
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plat
- use scanslt, only: nxpt, jintmx, plond, platd, nlonex
- use gauaw_mod, only: gauaw
- implicit none
-
-!------------------------------Parameters-------------------------------
- integer, parameter :: istart = nxpt+1 ! index for first model long.
- integer, parameter :: jstart = nxpt+jintmx+1 ! index for first model lat.
- integer, parameter :: jstop = jstart-1+plat ! index for last model lat.
-!-----------------------------------------------------------------------
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(out) :: dlam(platd) ! longitudinal increment
- real(r8), intent(out) :: lam (plond,platd) ! long. coords. in extended grid
- real(r8), intent(out) :: phi (platd) ! lat. coords. in extended grid
- real(r8), intent(out) :: w (plat) ! Gaussian weights
- real(r8), intent(out) :: sinlam(plond,platd) ! sin(lam)
- real(r8), intent(out) :: coslam(plond,platd) ! cos(lam)
-!
-! dlam Length of increment in longitude grid.
-! lam Longitude values in the extended grid.
-! phi Latitude values in the extended grid.
-! w Gauss weights for latitudes in the global grid. (These sum
-! to 2.0 like the ones in CCM1.)
-! sinlam Sine of longitudes in global grid (no extension points).
-! coslam Cosine of longitudes in global grid (no extension points).
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i,j,ig ! indices
- integer nlond ! extended long dim
- real(r8) lam0 ! lamda = 0
- real(r8) pi ! 3.14...
- real(r8) wrk(platd) ! work space
-!-----------------------------------------------------------------------
-!
- lam0 = 0.0_r8
- pi = 4._r8*atan(1._r8)
-!
-! Interval length in equally spaced longitude grid.
-!
- do j=1,platd
- dlam(j) = 2._r8*pi/real(nlonex(j),r8)
-!
-! Longitude values on extended grid.
-!
- nlond = nlonex(j) + 1 + 2*nxpt
- do i = 1,nlond
- lam(i,j) = real(i-istart,r8)*dlam(j) + lam0
- end do
- end do
-!
-! Compute Gauss latitudes and weights. On return; phi contains the
-! sine of the latitudes starting closest to the north pole and going
-! toward the south; w contains the corresponding Gauss weights.
-!
- call gauaw(phi ,w ,plat )
-!
-! Reorder and compute latitude values.
-!
- do j = jstart,jstop
- wrk(j) = asin( phi(jstop-j+1) )
- end do
- phi(jstart:jstop) = wrk(jstart:jstop)
-!
-! North and south poles.
-!
- phi(jstart-1) = -pi/2.0_r8
- phi(jstop +1) = pi/2.0_r8
-!
-! Extend Gauss latitudes below south pole so that the spacing above
-! the pole is symmetric, and phi is decreasing, i.e., phi < -pi/2
-!
- if( jstart > 2 )then
- do j = 1,jstart-2
- phi(j) = -pi - phi(2*jstart-2-j)
- end do
- end if
-!
-! Analogously for Northern Hemisphere
-!
- if( platd > jstop+1 )then
- do j = jstop+2,platd
- phi(j) = pi - phi(2*jstop+2-j)
- end do
- end if
-!
-! Sine and cosine of longitude.
-!
- do j=1,platd
- ig = 0
- do i = istart,nlonex(j)+nxpt
- ig = ig + 1
- sinlam(ig,j) = sin( lam(i,j) )
- coslam(ig,j) = cos( lam(i,j) )
- end do
- end do
-
- return
-end subroutine grdxy
diff --git a/src/advection/slt/hadvtest.h b/src/advection/slt/hadvtest.h
deleted file mode 100644
index 9cd2534a6a..0000000000
--- a/src/advection/slt/hadvtest.h
+++ /dev/null
@@ -1,2 +0,0 @@
-common/savit/usave(plon,plev,plat), vsave(plon,plev,plat), pssave(plon,plat)
-real(r8) usave, vsave, pssave
diff --git a/src/advection/slt/hordif1.F90 b/src/advection/slt/hordif1.F90
deleted file mode 100644
index fad8996807..0000000000
--- a/src/advection/slt/hordif1.F90
+++ /dev/null
@@ -1,92 +0,0 @@
-
-subroutine hordif1(rearth,phi)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Horizontal diffusion of z,d,t,q
-!
-! Method:
-! 1. implicit del**2 form above level kmnhd4
-! 2. implicit del**4 form at level kmnhd4 and below
-! 3. courant number based truncation at level kmxhdc and above
-! 4. increased del**2 coefficient at level kmxhd2 and above
-!
-! Computational note: this routine is multitasked by level, hence it
-! is called once for each k
-!
-! Author:
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8, i8 => shr_kind_i8
- use pspect
- use comspe
- implicit none
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: rearth ! radius of earth
- real(r8), intent(inout) :: phi(psp) ! used in spectral truncation of phis
-!-----------------------------------------------------------------------
-
-!---------------------------Local workspace-----------------------------
- integer ir,ii ! spectral indices
- integer mr,mc ! spectral indices
- real(r8) k42 ! Nominal Del^4 diffusion coeff at T42
- real(r8) k63 ! Nominal Del^4 diffusion coeff at T63
- real(r8) knn ! Computed Del^4 diffusion coeff at TNN
- real(r8) tmp ! temp space
- real(r8) hdfst4(pnmax)
- integer expon
- integer m ! spectral indices
- integer(i8) n ! spectral indices
-!-----------------------------------------------------------------------
-!
-! Compute Del^4 diffusion coefficient
-!
- k42 = 1.e+16_r8
- k63 = 5.e+15_r8
- expon = 25
-
- if(pmax-1 <= 42) then
- knn = k42
- elseif(pmax-1 == 63) then
- knn = k63
- else
- if(pmax-1 < 63) then
- tmp = log(k42/k63)/log(63._r8*64._r8/42._r8/43._r8)
- else
- tmp = 2._r8
- endif
- knn = k63*(63._r8*64._r8/real(pmax,r8)/real(pmax-1,r8))**tmp
- endif
-!
-! Set the Del^4 diffusion coefficients for each wavenumber
-!
- hdfst4(1) = 0._r8
- do n=2,pnmax
- hdfst4(n) = knn * (n*(n-1)*n*(n-1) ) / rearth**4
- end do
-!
-! Set the horizontal diffusion factors for each wavenumer at this level
-! del^4 diffusion is to be applied and compute time-split implicit
-! factors.
-!
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=1,nlen(m)
- ir = mc + 2*n - 1
- ii = ir + 1
- phi(ir) = phi(ir)/(1._r8 + 3600._r8*hdfst4(n+m-1))**expon
- phi(ii) = phi(ii)/(1._r8 + 3600._r8*hdfst4(n+m-1))**expon
- end do
- end do
-
- return
-end subroutine hordif1
diff --git a/src/advection/slt/kdpfnd.F90 b/src/advection/slt/kdpfnd.F90
deleted file mode 100644
index 24e229b359..0000000000
--- a/src/advection/slt/kdpfnd.F90
+++ /dev/null
@@ -1,66 +0,0 @@
-
-subroutine kdpfnd(pkdim ,pmap ,sig ,sigdp ,kdpmap , &
- kdp ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Determine vertical departure point indices that point into a grid
-! containing the full or half sigma levels. Use an artificial evenly
-! spaced vertical grid to map into the true model levels.
-!
-! Method:
-! Indices are computed assuming the the sigdp values have
-! been constrained so that sig(1) .le. sigdp(i,j) .lt. sig(pkdim).
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: pkdim ! dimension of "sig"
- integer , intent(in) :: pmap ! dimension of "kdpmap"
- real(r8), intent(in) :: sig (pkdim) ! vertical grid coordinates
- integer , intent(in) :: kdpmap(pmap) ! array of model grid indices which
- real(r8), intent(in) :: sigdp(plon,plev) ! vertical coords. of departure points
- integer , intent(out):: kdp(plon,plev) ! vertical index for each dep. pt.
- integer , intent(in) :: nlon ! longitude dimensio
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i,k,ii ! indices
- real(r8) rdel ! recip. of interval in artificial grid
- real(r8) sig1ln ! ln (sig(1))
-!-----------------------------------------------------------------------
-!
- rdel = real(pmap,r8)/( log(sig(pkdim)) - log(sig(1)) )
- sig1ln = log( sig(1) )
-!
-!$OMP PARALLEL DO PRIVATE (K, I, II)
- do k=1,plev
- do i=1,nlon
-!
-! First guess of the departure point's location in the model grid
-!
- ii = max0(1,min0(pmap,int((log(sigdp(i,k))-sig1ln)*rdel+1._r8)))
- kdp(i,k) = kdpmap(ii)
-!
-! Determine if location is in next interval
-!
- if(sigdp(i,k) >= sig(kdp(i,k)+1)) then
- kdp(i,k) = kdp(i,k) + 1
- end if
- end do
- end do
-
- return
-end subroutine kdpfnd
diff --git a/src/advection/slt/lcbas.F90 b/src/advection/slt/lcbas.F90
deleted file mode 100644
index 93848804ed..0000000000
--- a/src/advection/slt/lcbas.F90
+++ /dev/null
@@ -1,58 +0,0 @@
-
-subroutine lcbas (grd, bas1, bas2)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Evaluate the partial Lagrangian cubic basis functions (denominator
-! only ) for the grid points and gather grid values
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: grd(4) ! grid stencil
- real(r8), intent(out):: bas1(4) ! grid values on stencil
- real(r8), intent(out):: bas2(4) ! lagrangian basis functions
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- real(r8) x0mx1 ! |
- real(r8) x0mx2 ! |
- real(r8) x0mx3 ! |- grid value differences used in weights
- real(r8) x1mx2 ! |
- real(r8) x1mx3 ! |
- real(r8) x2mx3 ! |
-!-----------------------------------------------------------------------
-!
- x0mx1 = grd(1) - grd(2)
- x0mx2 = grd(1) - grd(3)
- x0mx3 = grd(1) - grd(4)
- x1mx2 = grd(2) - grd(3)
- x1mx3 = grd(2) - grd(4)
- x2mx3 = grd(3) - grd(4)
-
- bas1(1) = grd(1)
- bas1(2) = grd(2)
- bas1(3) = grd(3)
- bas1(4) = grd(4)
-
- bas2(1) = 1._r8/ ( x0mx1 * x0mx2 * x0mx3 )
- bas2(2) = -1._r8/ ( x0mx1 * x1mx2 * x1mx3 )
- bas2(3) = 1._r8/ ( x0mx2 * x1mx2 * x2mx3 )
- bas2(4) = -1._r8/ ( x0mx3 * x1mx3 * x2mx3 )
-
- return
-end subroutine lcbas
-
diff --git a/src/advection/slt/lcdbas.F90 b/src/advection/slt/lcdbas.F90
deleted file mode 100644
index d3fd1d3f01..0000000000
--- a/src/advection/slt/lcdbas.F90
+++ /dev/null
@@ -1,71 +0,0 @@
-
-subroutine lcdbas(grd ,dbas2 ,dbas3 )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Calculate weights used to evaluate derivative estimates at the
-! inner grid points of a four point stencil based on Lagrange
-! cubic polynomial through four unequally spaced points.
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: grd(4) ! grid stencil
- real(r8), intent(out):: dbas2(4) ! derivatives at grid point 2.
- real(r8), intent(out):: dbas3(4) ! derivatives at grid point 3.
-!
-! grd Coordinate values of four points in stencil.
-! dbas2 Derivatives of the four basis functions at grid point 2.
-! dbas3 Derivatives of the four basis functions at grid point 3.
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- real(r8) x1 ! |
- real(r8) x2 ! |- grid values
- real(r8) x3 ! |
- real(r8) x4 ! |
- real(r8) x1mx2 ! |
- real(r8) x1mx3 ! |
- real(r8) x1mx4 ! |- differences of grid values
- real(r8) x2mx3 ! |
- real(r8) x2mx4 ! |
- real(r8) x3mx4 ! |
-!-----------------------------------------------------------------------
-!
- x1 = grd(1)
- x2 = grd(2)
- x3 = grd(3)
- x4 = grd(4)
- x1mx2 = x1 - x2
- x1mx3 = x1 - x3
- x1mx4 = x1 - x4
- x2mx3 = x2 - x3
- x2mx4 = x2 - x4
- x3mx4 = x3 - x4
-
- dbas2(1) = x2mx3 * x2mx4 / ( x1mx2 * x1mx3 * x1mx4 )
- dbas2(2) = -1._r8/x1mx2 + 1._r8/x2mx3 + 1._r8/x2mx4
- dbas2(3) = - x1mx2 * x2mx4 / ( x1mx3 * x2mx3 * x3mx4 )
- dbas2(4) = x1mx2 * x2mx3 / ( x1mx4 * x2mx4 * x3mx4 )
-
- dbas3(1) = - x2mx3 * x3mx4 / ( x1mx2 * x1mx3 * x1mx4 )
- dbas3(2) = x1mx3 * x3mx4 / ( x1mx2 * x2mx3 * x2mx4 )
- dbas3(3) = -1._r8/x1mx3 - 1._r8/x2mx3 + 1._r8/x3mx4
- dbas3(4) = - x1mx3 * x2mx3 / ( x1mx4 * x2mx4 * x3mx4 )
-
- return
-end subroutine lcdbas
-
diff --git a/src/advection/slt/omcalc.F90 b/src/advection/slt/omcalc.F90
deleted file mode 100644
index c785fa730c..0000000000
--- a/src/advection/slt/omcalc.F90
+++ /dev/null
@@ -1,146 +0,0 @@
-
-subroutine omcalc(rcoslat ,d ,u ,v ,dpsl , &
- dpsm ,pmid ,pdel ,rpmid ,pbot , &
- omga ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Calculate vertical pressure velocity (omga = dp/dt)
-!
-! Method:
-! First evaluate the expressions for omega/p, then rescale to omega at
-! the end.
-!
-! Author: CCM1
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plon, plevp
- use pspect
- use hycoef, only: hybm, hybd, nprlev
- implicit none
-
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nlon ! lonitude dimension
- real(r8), intent(in) :: rcoslat(nlon) ! 1 / cos(lat)
- real(r8), intent(in) :: d(plon,plev) ! divergence
- real(r8), intent(in) :: u(plon,plev) ! zonal wind * cos(lat)
- real(r8), intent(in) :: v(plon,plev) ! meridional wind * cos(lat)
- real(r8), intent(in) :: dpsl(plon) ! longitudinal component of grad ln(ps)
- real(r8), intent(in) :: dpsm(plon) ! latitudinal component of grad ln(ps)
- real(r8), intent(in) :: pmid(plon,plev) ! mid-level pressures
- real(r8), intent(in) :: pdel(plon,plev) ! layer thicknesses (pressure)
- real(r8), intent(in) :: rpmid(plon,plev) ! 1./pmid
- real(r8), intent(in) :: pbot(plon) ! bottom interface pressure
- real(r8), intent(out):: omga(plon,plev) ! vertical pressure velocity
-!-----------------------------------------------------------------------
-
-!---------------------------Local workspace-----------------------------
- integer i,k ! longitude, level indices
- real(r8) d_i(plev) ! divergence (single colummn)
- real(r8) u_i(plev) ! zonal wind * cos(lat) (single colummn)
- real(r8) v_i(plev) ! meridional wind * cos(lat) (single colummn)
- real(r8) pmid_i(plev) ! mid-level pressures (single colummn)
- real(r8) pdel_i(plev) ! layer thicknesses (pressure) (single colummn)
- real(r8) rpmid_i(plev) ! 1./pmid (single colummn)
- real(r8) omga_i(plev) ! vertical pressure velocity (single colummn)
- real(r8) hkk ! diagonal element of hydrostatic matrix
- real(r8) hlk ! super diagonal element
- real(r8) suml ! partial sum over l = (1, k-1)
- real(r8) vgpk ! v dot grad ps
- real(r8) tmp ! vector temporary
-!-----------------------------------------------------------------------
-!
-!$OMP PARALLEL DO PRIVATE (I, SUML, D_I, U_I, V_I, PMID_I, PDEL_I, RPMID_I, &
-!$OMP OMGA_I, HKK, VGPK, TMP, HLK)
- do i=1,nlon
-!
-! Zero partial sum
-!
- suml = 0._r8
-!
-! Collect column data
-!
- d_i = d(i,:)
- u_i = u(i,:)
- v_i = v(i,:)
- pmid_i = pmid(i,:)
- pdel_i = pdel(i,:)
- rpmid_i = rpmid(i,:)
-!
-! Pure pressure part: top level
-!
- hkk = 0.5_r8*rpmid_i(1)
- omga_i(1) = -hkk*d_i(1)*pdel_i(1)
- suml = suml + d_i(1)*pdel_i(1)
-!
-! sum(k)(v(j)*ps*grad(lnps)*db(j)) part. Not normally invoked since
-! the top layer is normally a pure pressure layer.
-!
- if (1>=nprlev) then
- vgpk = rcoslat(i)*(u_i(1)*dpsl(i) + v_i(1)*dpsm(i))*pbot(i)
- tmp = vgpk*hybd(1)
- omga_i(1) = omga_i(1) + hybm(1)*rpmid_i(1)*vgpk - hkk*tmp
- suml = suml + tmp
- end if
-!
-! Integrals to level above bottom
-!
- do k=2,plev-1
-!
-! Pure pressure part
-!
- hkk = 0.5_r8*rpmid_i(k)
- hlk = rpmid_i(k)
- omga_i(k) = -hkk*d_i(k)*pdel_i(k) - hlk*suml
- suml = suml + d_i(k)*pdel_i(k)
-!
-! v(j)*grad(lnps) part
-!
- if (k>=nprlev) then
- vgpk = rcoslat(i)*(u_i(k)*dpsl(i) + v_i(k)*dpsm(i))*pbot(i)
- tmp = vgpk*hybd(k)
- omga_i(k) = omga_i(k) + hybm(k)*rpmid_i(k)*vgpk - hkk*tmp
- suml = suml + tmp
- end if
- end do
-!
-! Pure pressure part: bottom level
-!
- hkk = 0.5_r8*rpmid_i(plev)
- hlk = rpmid_i(plev)
- omga_i(plev) = -hkk*d_i(plev)*pdel_i(plev) - hlk*suml
-!
-! v(j)*grad(lnps) part. Normally invoked, but omitted if the model is
-! running in pure pressure coordinates throughout (e.g. stratospheric
-! mechanistic model).
-!
- if (plev>=nprlev) then
- vgpk = rcoslat(i)*(u_i(plev)*dpsl(i) + v_i(plev)*dpsm(i))* pbot(i)
- omga_i(plev) = omga_i(plev) + hybm(plev)*rpmid_i(plev)*vgpk - &
- hkk*vgpk*hybd(plev)
- end if
-!
-! The above expressions give omega/p. Rescale to omega.
-!
- do k=1,plev
- omga_i(k) = omga_i(k)*pmid_i(k)
- end do
-!
-! Save results
-!
- omga(i,:) = omga_i(:)
-!
- end do
-!
- return
-end subroutine omcalc
-
diff --git a/src/advection/slt/pdelb0.F90 b/src/advection/slt/pdelb0.F90
deleted file mode 100644
index b378430127..0000000000
--- a/src/advection/slt/pdelb0.F90
+++ /dev/null
@@ -1,49 +0,0 @@
-
-subroutine pdelb0(ps ,pdelb ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute the pressure intervals between the interfaces for the "B"
-! (surface pressure dependent) portion of the hybrid grid only.
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plon
- use hycoef, only: hybd
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(in) :: ps(plon) ! surface Pressure
- real(r8), intent(out):: pdelb(plon,plev) ! pressure difference between interfaces
- ! (pressure defined using the "B" part
- ! of the hybrid grid only)
-!-----------------------------------------------------------------------
-
-!---------------------------Local workspace-----------------------------
- integer i,k ! longitude, level indices
-!-----------------------------------------------------------------------
-!
-! Compute del P(B)
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k = 1,plev
- do i = 1,nlon
- pdelb(i,k) = hybd(k)*ps(i)
- end do
- end do
-
- return
-end subroutine pdelb0
-
diff --git a/src/advection/slt/phcs.F90 b/src/advection/slt/phcs.F90
deleted file mode 100644
index 41e72b1c92..0000000000
--- a/src/advection/slt/phcs.F90
+++ /dev/null
@@ -1,238 +0,0 @@
-
-subroutine phcs(pmn ,hmn ,ix ,x1)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute associated Legendre functions of the first kind of order m and
-! degree n, and the associated derivatives for arg x1.
-
-! Method:
-! Compute associated Legendre functions of the first kind of order m and
-! degree n, and the associated derivatives for arg x1. The associated
-! Legendre functions are evaluated using relationships contained in
-! "Tables of Normalized Associated Legendre Polynomials",
-! S. L. Belousov (1962). Both the functions and their derivatives are
-! ordered in a linear stored rectangular array (with a large enough
-! domain to contain the particular wavenumber truncation defined in the
-! pspect common block) by column. m = 0->ptrm, and n = m->ptrn + m
-! m
-! The functions P (x) are normalized such that
-! n
-! / m 2
-! | [P (x)] dx = 1/2
-! / n
-! __
-! and must be multiplied by |2 to match Belousov tables.
-! \|
-! m
-! The derivatives H (x) are defined as
-! n m 2 m
-! H (x) = -(1-x ) dP (x)/dx
-! n n
-!
-! and are evaluated using the recurrence relationship
-! _________________________
-! m m | 2 2 m
-! H (x) = nx P (x) - |(n - m )(2n + 1)/(2n - 1) P (x)
-! n n \| n-1
-!
-! Modified 1/23/97 by Jim Rosinski to use real*16 arithmetic in order to
-! achieve (nearly) identical values on all machines.
-!
-! Author: CCM1
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8, i8 => shr_kind_i8
- use pspect
- implicit none
-
-#ifdef NO_R16
- integer,parameter :: r16= selected_real_kind(12) ! 8 byte real
-#else
- integer,parameter :: r16= selected_real_kind(24) ! 16 byte real
-#endif
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: ix ! Dimension of Legendre funct arrays
- real(r8), intent(in) :: x1 ! sin of latitude, [sin(phi), or mu]
- real(r8), intent(out) :: pmn(ix) ! Legendre function array
- real(r8), intent(out) :: hmn(ix) ! Derivative array
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer jmax ! Loop limit (N+1=> 2D wavenumber limit +1)
- integer nmax ! Large enough n to envelope truncation
- integer(i8) n ! 2-D wavenumber index (up/down column)
- integer ml ! intermediate scratch variable
- integer k ! counter on terms in trig series expansion
- integer(i8) n2 ! 2*n
- integer m ! zonal wavenumber index
- integer nto ! intermediate scratch variable
- integer mto ! intermediate scratch variable
- integer j ! 2-D wavenumber index in recurrence evaluation
- integer nmaxm ! loop limit in recurrence evaluation
-
- real(r16) xtemp(3,pmmax+ptrn+1) ! Workspace for evaluating recurrence
-! ! relation where xtemp(m-2,n) and
-! ! xtemp(m-1,n) contain Pmn's required
-! ! to evaluate xtemp(m,n) (i.e.,always
-! ! contains three adjacent columns of
-! ! the Pmn data structure)
-!
- real(r16) xx1 ! x1 in extended precision
- real(r16) xte ! cosine latitude [cos(phi)]
- real(r16) teta ! pi/2 - latitute (colatitude)
- real(r16) an ! coefficient on trig. series expansion
- real(r16) sinpar ! accumulator in trig. series expansion
- real(r16) cospar ! accumulator in trig. series expansion
- real(r16) p ! 2-D wavenumber (series expansion)
- real(r16) q ! intermediate variable in series expansion
- real(r16) r ! zonal wavenumber (recurrence evaluation)
- real(r16) p2 ! intermediate variable in series expansion
- real(r16) rr ! twice the zonal wavenumber (recurrence)
- real(r16) sqp ! intermediate variable in series expansion
- real(r16) cosfak ! coef. on cos term in series expansion
- real(r16) sinfak ! coef. on sin term in series expansion
- real(r16) ateta ! intermediate variable in series expansion
- real(r16) costet ! cos term in trigonometric series expansion
- real(r16) sintet ! sin term in trigonometric series expansion
-!
- real(r16) t ! intermediate variable (recurrence evaluation)
- real(r16) wm2 ! intermediate variable (recurrence evaluation)
- real(r16) wmq2 ! intermediate variable (recurrence evaluation)
- real(r16) w ! intermediate variable (recurrence evaluation)
- real(r16) wq ! intermediate variable (recurrence evaluation)
- real(r16) q2 ! intermediate variable (recurrence evaluation)
- real(r16) wt ! intermediate variable (recurrence evaluation)
- real(r16) q2d ! intermediate variable (recurrence evaluation)
- real(r16) cmn ! cmn recurrence coefficient (see Belousov)
- real(r16) xdmn ! dmn recurrence coefficient (see Belousov)
- real(r16) emn ! emn recurrence coefficient (see Belousov)
- real(r16) n2m1 ! n2 - 1 in extended precision
- real(r16) n2m3 ! n2 - 3 in extended precision
- real(r16) n2p1nnm1 ! (n2+1)*(n*n-1) in extended precision
- real(r16) twopmq ! p + p - q in extended precision
-!-----------------------------------------------------------------------
-!
-! Begin procedure by evaluating the first two columns of the Legendre
-! function matrix (i.e., all n for m=0,1) via a trigonometric series
-! expansion (see eqs. 19 and 21 in Belousov, 1962). Note that indexing
-! is offset by one (e.g., m index for wavenumber m=0 is 1 and so on)
-! Setup first ...
-!
- xx1 = x1
- jmax = ptrn + 1
- nmax = pmmax + jmax
- xte = (1._r16-xx1*xx1)**0.5_r16
- teta = acos(xx1)
- an = 1._r16
- xtemp(1,1) = 0.5_r16 ! P00
-!
-! begin loop over n (2D wavenumber, or degree of associated Legendre
-! function) beginning with n=1 (i.e., P00 was assigned above)
-! note n odd/even distinction yielding 2 results per n cycle
-!
- do n=2,nmax
- sinpar = 0._r16
- cospar = 0._r16
- ml = n
- p = n - 1
- p2 = p*p
- sqp = 1._r16/(p2+p)**0.5_r16
- an = an*(1._r16 - 1._r16/(4._r16*p2))**0.5_r16
- cosfak = 1._r16
- sinfak = p*sqp
- do k=1,ml,2
- q = k - 1
- twopmq = p + p - q
- ateta = (p-q)*teta
- costet = cos(ateta)
- sintet = sin(ateta)
- if (n==k) costet = costet*0.5_r16
- if (k/=1) then
- cosfak = (q-1._r16)/q*(twopmq+2._r16)/(twopmq+1._r16)*cosfak
- sinfak = cosfak*(p-q)*sqp
- end if
- cospar = cospar + costet*cosfak
- sinpar = sinpar + sintet*sinfak
- end do
- xtemp(1,n) = an*cospar ! P0n vector
- xtemp(2,n-1) = an*sinpar ! P1n vector
- end do
-!
-! Assign Legendre functions and evaluate derivatives for all n and m=0,1
-!
- pmn(1) = 0.5_r16
- pmn(1+jmax) = xtemp(2,1)
- hmn(1) = 0._r16
- hmn(1+jmax) = xx1*xtemp(2,1)
- do n=2,jmax
- pmn(n) = xtemp(1,n)
- pmn(n+jmax) = xtemp(2,n)
- n2 = n + n
- n2m1 = n2 - 1
- n2m3 = n2 - 3
- n2p1nnm1 = (n2+1)*(n*n-1)
- hmn(n) = (n-1)*(xx1*xtemp(1,n)-(n2m1/n2m3)**0.5_r16*xtemp(1,n-1))
- hmn(n+jmax) = n*xx1*xtemp(2,n)-(n2p1nnm1/n2m1)**0.5_r16*xtemp(2,n-1)
- end do
-!
-! Evaluate recurrence relationship for remaining Legendre functions
-! (i.e., m=2 ... PTRM) and associated derivatives (see eq 17, Belousov)
-!
- do m=3,pmmax
- r = m - 1
- rr = r + r
- xtemp(3,1) = (1._r16+1._r16/rr)**0.5_r16*xte*xtemp(2,1)
- nto = (m-1)*jmax
- pmn(nto+1) = xtemp(3,1)
- hmn(nto+1) = r*xx1*xtemp(3,1)
- nmaxm = nmax - m
-!
-! Loop over 2-D wavenumber (i.e., degree of Legendre function)
-! Pmn's and Hmn's for current zonal wavenumber, r
-!
- do j=2,nmaxm
- mto = nto + j
- t = j - 1
- q = rr + t - 1
- wm2 = q + t
- w = wm2 + 2
- wq = w*q
- q2 = q*q - 1
- wmq2 = wm2*q2
- wt = w*t
- q2d = q2 + q2
- cmn = ((wq*(q-2._r16))/(wmq2-q2d))**0.5_r16
- xdmn = ((wq*(t+1._r16))/wmq2)**0.5_r16
- emn = (wt/((q+1._r16)*wm2))**0.5_r16
- xtemp(3,j) = cmn*xtemp(1,j) - xx1*(xdmn*xtemp(1,j+1)-emn*xtemp(3,j-1))
- pmn(mto) = xtemp(3,j)
- hmn(mto) = (r+t)*xx1*xtemp(3,j) - (wt*(q+1._r16)/wm2)**0.5_r16*xtemp(3,j-1)
- end do
-!
-! shift Pmn's to left in workspace (setup for next recurrence pass)
-!
-!++pjr
-! not initialized above
- xtemp(2,nmax) = 0._r16
- do j=nmaxm,nmax
- xtemp(3,j) = 0._r16
- end do
-!--pjr
- do n=1,nmax
- xtemp(1,n) = xtemp(2,n)
- xtemp(2,n) = xtemp(3,n)
- end do
- end do
-
- return
-end subroutine phcs
-
diff --git a/src/advection/slt/plevs0.F90 b/src/advection/slt/plevs0.F90
deleted file mode 100644
index f43df7587e..0000000000
--- a/src/advection/slt/plevs0.F90
+++ /dev/null
@@ -1,63 +0,0 @@
-
-subroutine plevs0 (ncol , ncold ,nver ,ps ,pint , &
- pmid ,pdel)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Define the pressures of the interfaces and midpoints from the
-! coordinate definitions and the surface pressure.
-!
-! Method:
-!
-! Author: B. Boville
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plevp
- use hycoef, only: hyai, hybi, ps0, hyam, hybm
- implicit none
-
-
-!-----------------------------------------------------------------------
- integer , intent(in) :: ncol ! Longitude dimension
- integer , intent(in) :: ncold ! Declared longitude dimension
- integer , intent(in) :: nver ! vertical dimension
- real(r8), intent(in) :: ps(ncold) ! Surface pressure (pascals)
- real(r8), intent(out) :: pint(ncold,nver+1) ! Pressure at model interfaces
- real(r8), intent(out) :: pmid(ncold,nver) ! Pressure at model levels
- real(r8), intent(out) :: pdel(ncold,nver) ! Layer thickness (pint(k+1) - pint(k))
-!-----------------------------------------------------------------------
-
-!---------------------------Local workspace-----------------------------
- integer i,k ! Longitude, level indices
-!-----------------------------------------------------------------------
-!
-! Set interface pressures
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,nver+1
- do i=1,ncol
- pint(i,k) = hyai(k)*ps0 + hybi(k)*ps(i)
- end do
- end do
-!
-! Set midpoint pressures and layer thicknesses
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,nver
- do i=1,ncol
- pmid(i,k) = hyam(k)*ps0 + hybm(k)*ps(i)
- pdel(i,k) = pint(i,k+1) - pint(i,k)
- end do
- end do
-
- return
-end subroutine plevs0
-
diff --git a/src/advection/slt/qmassa.F90 b/src/advection/slt/qmassa.F90
deleted file mode 100644
index dc6055c47b..0000000000
--- a/src/advection/slt/qmassa.F90
+++ /dev/null
@@ -1,111 +0,0 @@
-module qmassa
-
-
-contains
-
-subroutine qmassarun(cwava ,w ,q3 ,pdel ,hw1lat , &
- nlon ,q0 ,lat ,pdeld )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Calculate contribution of current latitude to mass of constituents
-! being advected by slt.
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plon
- use constituents, only: pcnst, cnst_get_type_byind
- use dycore, only: dycore_is
- use cam_abortutils, only: endrun
-
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(in) :: cwava ! normalization factor l/(g*plon)
- real(r8), intent(in) :: w ! gaussian weight this latitude
- real(r8), intent(in) :: q3(plon,plev,pcnst) ! constituents
- real(r8), intent(in) :: q0(plon,plev,pcnst) ! constituents at begining of time step
- real(r8), intent(in) :: pdel(plon,plev) ! pressure diff between interfaces
- real(r8), intent(out) :: hw1lat(pcnst) ! accumulator
- real(r8), intent(in),optional :: pdeld(:,:) ! dry pressure difference for dry-type constituents
- ! only used when called from eularian dynamics
-
-
- integer lat
-!-----------------------------------------------------------------------
-!
-!---------------------------Local variables-----------------------------
- integer i,k,m ! longitude, level, constituent indices
- real(r8) const ! temporary constant
-!-----------------------------------------------------------------------
-!
-! Integration factor (the 0.5 factor arises because gaussian weights sum to 2)
-!
- const = cwava*w*0.5_r8
- do m=1,pcnst
- hw1lat(m) = 0._r8
- end do
-
-!$OMP PARALLEL DO PRIVATE (M, K, I)
- do m=1,pcnst
- if (m == 1) then
-!
-! Compute mass integral for water
-!
- do k=1,plev
- do i=1,nlon
- hw1lat(1) = hw1lat(1) + q3(i,k,1)*pdel(i,k)
- end do
- end do
-!
-! Compute mass integral for non-water constituents (on either WET or DRY basis)
-!
- elseif (cnst_get_type_byind(m).eq.'dry' ) then ! dry type constituents
- if ( dycore_is ('EUL') ) then ! EUL dycore computes pdeld in time filter
- if ( .not. present(pdeld) ) &
- call endrun('for dry type cnst with eul dycore, qmassa requires pdeld argument')
- do k=1,plev
- do i=1,nlon
- hw1lat(m) = hw1lat(m) + q3(i,k,m)*pdeld(i,k)
- end do
- end do
- else !dycore SLD
- do k=1,plev
- do i=1,nlon
- hw1lat(m) = hw1lat(m) + q3(i,k,m)*(1._r8 - q0(i,k,1))*pdel(i,k)
- end do
- end do
- endif ! dycore
- else !wet type constituents
- do k=1,plev
- do i=1,nlon
- hw1lat(m) = hw1lat(m) + q3(i,k,m)*(1._r8 - q3(i,k,1))*pdel(i,k)
- end do
- end do
- end if !dry or wet
- end do
-
- do m = 1,pcnst
- hw1lat(m) = hw1lat(m)*const
- end do
-
- return
-end subroutine qmassarun
-
-end module qmassa
-
-
-
-
diff --git a/src/advection/slt/qmassd.F90 b/src/advection/slt/qmassd.F90
deleted file mode 100644
index b8650270b2..0000000000
--- a/src/advection/slt/qmassd.F90
+++ /dev/null
@@ -1,69 +0,0 @@
-
-subroutine qmassd(cwava ,etamid ,w ,q1 ,q2 , &
- pdel ,hwn ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute comtribution of current latitude to global integral of
-! q2*|q2 - q1|*eta
-! This is a measure of the difference between the fields before and
-! after the SLT "forecast" weighted by the approximate mass of the tracer.
-! It is used in the "fixer" which enforces conservation in constituent
-! fields transport via SLT.
-!
-! Method:
-! Reference Rasch and Williamson, 1991, Rasch, Boville and Brasseur, 1995
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plon
- use constituents, only: pcnst
-
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(in) :: cwava ! normalization factor
- real(r8), intent(in) :: etamid(plev) ! vertical coords at midpoints
- real(r8), intent(in) :: w ! gaussian weight this latitude
- real(r8), intent(in) :: q1(plon,plev) ! constituents (pre -SLT)
- real(r8), intent(in) :: q2(plon,plev) ! constituents (post-SLT)
- real(r8), intent(in) :: pdel(plon,plev) ! pressure diff between interfaces
- real(r8), intent(inout) :: hwn(pcnst) ! accumulator for global integrals
-!
-! cwava l/(g*plon)
-! w Gaussian weight.
-! q1 Untransported q-field.
-! q2 Transported q-field.
-! pdel array of pressure differences between layer interfaces (used for mass weighting)
-! hwn Mass averaged constituent in units of kg/m**2.
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i,k ! longitude and level indices
- real(r8) hwava ! accumulator
-!-----------------------------------------------------------------------
-!
- hwava = 0.0_r8
- do k=1,plev
- do i=1,nlon
- hwava = hwava + (q2(i,k)* etamid(k)*(abs(q1(i,k) - q2(i,k))))*pdel(i,k)
- end do
- end do
-!
-! The 0.5 factor arises because gaussian weights sum to 2
-!
- hwn(1) = hwn(1) + cwava*w*hwava*0.5_r8
-
- return
-end subroutine qmassd
-
diff --git a/src/advection/slt/reordp.F90 b/src/advection/slt/reordp.F90
deleted file mode 100644
index a830a9f5e1..0000000000
--- a/src/advection/slt/reordp.F90
+++ /dev/null
@@ -1,57 +0,0 @@
-
-subroutine reordp(irow ,iy ,zalp ,zdalp )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Renormalize associated Legendre polynomials and their derivatives.
-!
-! Method:
-! Reorder associated Legendre polynomials and their derivatives from
-! column rectangular storage to diagonal pentagonal storage. The
-! reordered polynomials and derivatives are returned via common/comspe/
-!
-! Author: CCM1
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pspect
- use comspe
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: irow ! latitude pair index
- integer , intent(in) :: iy ! dimension of input polynomials
- real(r8), intent(in) :: zalp(iy) ! Legendre polynomial
- real(r8), intent(in) :: zdalp(iy) ! Legendre polynomial derivative
-!-----------------------------------------------------------------------
-
-!---------------------------Local workspace-----------------------------
- integer mr ! spectral index
- integer m ! index along diagonal and row
- integer n ! index of diagonal
- real(r8) sqrt2 ! sqrt(2)
-!-----------------------------------------------------------------------
-!
-! Multiply ALP and DALP by SQRT(2.) in order to get proper
-! normalization. DALP is multiplied by -1 to correct for - sign
-! in Copenhagen definition.
-!
- sqrt2 = sqrt(2._r8)
- do m=1,pmmax
- mr = nstart(m)
- do n=1,nlen(m)
- alp(mr+n,irow) = zalp((m-1)*pmax + n)*sqrt2
- dalp(mr+n,irow) = -zdalp((m-1)*pmax + n)*sqrt2
- end do
- end do
-
- return
-end subroutine reordp
-
diff --git a/src/advection/slt/scm0.F90 b/src/advection/slt/scm0.F90
deleted file mode 100644
index 8810c180dc..0000000000
--- a/src/advection/slt/scm0.F90
+++ /dev/null
@@ -1,57 +0,0 @@
-
-subroutine scm0(n ,deli ,df1 ,df2 )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Apply SCM0 limiter to derivative estimates.
-! See Rasch and Williamson (1990)
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: n ! length of vectors
- real(r8), intent(in) :: deli(n) ! discrete derivative
- real(r8), intent(inout) :: df1(n) ! limited left -edge derivative
- real(r8), intent(inout) :: df2(n) ! limited right-edge derivative
-!
-! n Dimension of input arrays.
-! deli deli(i) is the discrete derivative on interval i, i.e.,
-! deli(i) = ( f(i+1) - f(i) )/( x(i+1) - x(i) ).
-! df1 df1(i) is the limited derivative at the left edge of interval
-! df2 df2(i) is the limited derivative at the right edge of interval
-!-----------------------------------------------------------------------
-
-
-!---------------------------Local variables-----------------------------
- integer i ! index
- real(r8) fac ! factor applied in limiter
- real(r8) tmp1 ! derivative factor
- real(r8) tmp2 ! abs(tmp1)
-!-----------------------------------------------------------------------
-!
- fac = 3._r8*(1._r8 - 10._r8*epsilon(fac))
- do i = 1,n
- tmp1 = fac*deli(i)
- tmp2 = abs( tmp1 )
- if( deli(i)*df1(i) <= 0.0_r8 ) df1(i) = 0._r8
- if( deli(i)*df2(i) <= 0.0_r8 ) df2(i) = 0._r8
- if( abs( df1(i) ) > tmp2 ) df1(i) = tmp1
- if( abs( df2(i) ) > tmp2 ) df2(i) = tmp1
- end do
-
- return
-end subroutine scm0
-
diff --git a/src/advection/slt/xqmass.F90 b/src/advection/slt/xqmass.F90
deleted file mode 100644
index 5db28ff606..0000000000
--- a/src/advection/slt/xqmass.F90
+++ /dev/null
@@ -1,150 +0,0 @@
-
-subroutine xqmass(cwava ,etamid ,w ,qo ,qn , &
- xo ,xn ,pdela ,pdelb ,hwxal , &
- hwxbl ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute comtribution of current latitude to global integrals necessary
-! to compute the fixer for the non-water constituents.
-!
-! Method:
-!
-! Author: J. Olson, March 1994
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plon
- use constituents, only: pcnst, cnst_get_type_byind
-
- implicit none
-
-!---------------------------Arguments-----------------------------------
- real(r8), intent(in) :: cwava ! normalization factor
- real(r8), intent(in) :: etamid(plev) ! vertical coords at midpoints
- real(r8), intent(in) :: w ! gaussian weight this latitude
- real(r8), intent(in) :: qo(plon,plev ) ! q old (pre -SLT)
- real(r8), intent(in) :: qn(plon,plev ) ! q new (post-SLT)
- real(r8), intent(in) :: xo(plon,plev,pcnst) ! old constituents (pre -SLT)
- real(r8), intent(in) :: xn(plon,plev,pcnst) ! new constituents (post-SLT)
- real(r8), intent(in) :: pdela(plon,plev) ! pressure diff between interfaces
- integer , intent(in) :: nlon ! number of longitudes
- ! based pure pressure part of hybrid grid
- real(r8), intent(in) :: pdelb(plon,plev) ! pressure diff between interfaces
- ! based sigma part of hybrid grid
- real(r8), intent(inout) :: hwxal(pcnst,4) ! partial integrals (weighted by pure
- ! pressure part of hybrid pressures)
- real(r8), intent(inout) :: hwxbl(pcnst,4) ! partial integrals (weighted by sigma
- ! part of hybrid pressures)
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i ! longitude index
- integer k ! level index
- integer m ! constituent index
- integer n ! index for partial integral
- real(r8) a ! integral constant
- real(r8) xdx,xq1,xqdq,xdxq1 ! work elements
- real(r8) xdxqdq ! work elements
- real(r8) hwak(4),hwbk(4) ! work arrays
- real(r8) q1 (plon,plev) ! work array
- real(r8) qdq(plon,plev) ! work array
- real(r8) hwalat(4) ! partial integrals (weighted by pure
-! ! pressure part of hybrid pressures)
- real(r8) hwblat(4) ! partial integrals (weighted by sigma
-! ! part of hybrid pressures)
- real(r8) etamsq(plev) ! etamid*etamid
- real(r8) xnt(plon) ! temp version of xn
- character*3 cnst_type ! 'dry' or 'wet' mixing ratio
-!-----------------------------------------------------------------------
-!
- a = cwava*w*0.5_r8
- do k = 1,plev
- etamsq(k) = etamid(k)*etamid(k)
- end do
-!
-! Compute terms involving water vapor mixing ratio
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k = 1,plev
- do i = 1,nlon
- q1 (i,k) = 1._r8 - qn(i,k)
- qdq(i,k) = qn(i,k)*abs(qn(i,k) - qo(i,k))
- end do
- end do
-!
-! Compute partial integrals for non-water constituents
-!
-!$OMP PARALLEL DO PRIVATE (M, CNST_TYPE, N, HWALAT, HWBLAT, K, HWAK, HWBK, &
-!$OMP I, XNT, XDX, XQ1, XQDQ, XDXQ1, XDXQDQ)
- do m = 2,pcnst
- cnst_type = cnst_get_type_byind(m)
- do n = 1,4
- hwalat(n) = 0._r8
- hwblat(n) = 0._r8
- end do
- do k = 1,plev
- do n = 1,4
- hwak(n) = 0._r8
- hwbk(n) = 0._r8
- end do
-
- if (cnst_type.eq.'dry' ) then
- do i = 1, nlon
- if (abs(xn(i,k,m) - xo(i,k,m)) &
- .lt.1.0e-13_r8 * max(abs(xn(i,k,m)), abs(xo(i,k,m)))) then
- xnt(i) = xo(i,k,m)
- else
- xnt(i) = xn(i,k,m)
- end if
- end do
- else
- do i = 1, nlon
- xnt(i) = xn(i,k,m)
- end do
- end if
-
- do i = 1,nlon
- xdx = xnt(i)*abs(xn(i,k,m) - xo(i,k,m))
- xq1 = xnt(i)*q1 (i,k)
- xqdq = xnt(i)*qdq(i,k)
- xdxq1 = xdx *q1 (i,k)
- xdxqdq = xdx *qdq(i,k)
-
- hwak(1) = hwak(1) + xq1 *pdela(i,k)
- hwbk(1) = hwbk(1) + xq1 *pdelb(i,k)
- hwak(2) = hwak(2) + xqdq *pdela(i,k)
- hwbk(2) = hwbk(2) + xqdq *pdelb(i,k)
- hwak(3) = hwak(3) + xdxq1 *pdela(i,k)
- hwbk(3) = hwbk(3) + xdxq1 *pdelb(i,k)
- hwak(4) = hwak(4) + xdxqdq*pdela(i,k)
- hwbk(4) = hwbk(4) + xdxqdq*pdelb(i,k)
- end do
-
- hwalat(1) = hwalat(1) + hwak(1)
- hwblat(1) = hwblat(1) + hwbk(1)
- hwalat(2) = hwalat(2) + hwak(2)*etamid(k)
- hwblat(2) = hwblat(2) + hwbk(2)*etamid(k)
- hwalat(3) = hwalat(3) + hwak(3)*etamid(k)
- hwblat(3) = hwblat(3) + hwbk(3)*etamid(k)
- hwalat(4) = hwalat(4) + hwak(4)*etamsq(k)
- hwblat(4) = hwblat(4) + hwbk(4)*etamsq(k)
- end do
-!
-! The 0.5 factor arises because Gaussian weights sum to 2
-!
- do n = 1,4
- hwxal(m,n) = hwxal(m,n) + hwalat(n)*a
- hwxbl(m,n) = hwxbl(m,n) + hwblat(n)*a
- end do
- end do
-
- return
-end subroutine xqmass
diff --git a/src/control/cam_budget.F90 b/src/control/cam_budget.F90
index 1ae7fd20f4..016875ff63 100644
--- a/src/control/cam_budget.F90
+++ b/src/control/cam_budget.F90
@@ -98,7 +98,7 @@ subroutine cam_budget_readnl(nlfile)
! Write out thermo_budget options
if (masterproc) then
if (thermo_budget_history) then
- if (dycore_is('EUL').or.dycore_is('FV').or.dycore_is('FV3')) then
+ if (dycore_is('FV') .or. dycore_is('FV3')) then
call endrun(subname//'ERROR thermodynamic budgets not implemented for this dycore')
else
write(iulog,*)'Thermo budgets will be written to the log file and diagnostics saved to history file:',&
diff --git a/src/control/cam_control_mod.F90 b/src/control/cam_control_mod.F90
index 3d954f68ce..02789f4537 100644
--- a/src/control/cam_control_mod.F90
+++ b/src/control/cam_control_mod.F90
@@ -149,7 +149,7 @@ subroutine cam_ctrl_set_physics_type(phys_package)
if (masterproc) then
if (adiabatic) then
write(iulog,*) 'Run model ADIABATICALLY (i.e. no physics)'
- write(iulog,*) ' Global energy fixer is on for non-Eulerian dycores.'
+ write(iulog,*) ' Global energy fixer is on.'
else if (ideal_phys) then
write(iulog,*) 'Run model with Held-Suarez physics forcing'
else if (kessler_phys) then
diff --git a/src/control/cam_history_support.F90 b/src/control/cam_history_support.F90
index 5e5983e784..6dbc04fb14 100644
--- a/src/control/cam_history_support.F90
+++ b/src/control/cam_history_support.F90
@@ -301,7 +301,7 @@ module cam_history_support
character(len=28) :: gridname = ''
integer :: grid_id = -1
! gridtype = 1 equally spaced, including poles (FV scalars output grid)
- ! gridtype = 2 Gauss grid (CAM Eulerian)
+ ! gridtype = 2 Gauss grid (not implemented)
! gridtype = 3 equally spaced, no poles (FV staggered velocity)
integer :: interp_gridtype = interp_gridtype_equal_poles
! interpolate_type = 0: native high order interpolation
diff --git a/src/control/history_scam.F90 b/src/control/history_scam.F90
index e171fcee96..a961fc502e 100644
--- a/src/control/history_scam.F90
+++ b/src/control/history_scam.F90
@@ -49,8 +49,6 @@ subroutine scm_intht()
else
outgrid = 'physgrid'
end if
- else if (dycore_is('EUL')) then
- outgrid = 'gauss_grid'
else
outgrid = 'unknown'
end if
@@ -139,9 +137,7 @@ subroutine initialize_iop_history()
if (dycore_is('SE')) then
outgrid = 'GLL'
- else if (dycore_is('EUL')) then
- outgrid = 'gauss_grid'
- else if (dycore_is('EUL')) then
+ else
outgrid = 'unknown'
end if
diff --git a/src/control/ncdio_atm.F90 b/src/control/ncdio_atm.F90
index f727fc8f25..f25039d97c 100644
--- a/src/control/ncdio_atm.F90
+++ b/src/control/ncdio_atm.F90
@@ -398,7 +398,7 @@ subroutine infld_real_2d_2d(varname, ncid, dimname1, dimname2, &
cnt = arraydimsize
call shr_scam_getCloseLatLon(ncid,scmlat,scmlon,closelat,closelon,latidx,lonidx)
if (trim(field_dnames(1)) == 'lon') then
- strt(1) = lonidx ! First dim always lon for Eulerian dycore
+ strt(1) = lonidx
else
call endrun(trim(subname)//': lon should be first dimension for '//trim(varname))
end if
@@ -831,7 +831,7 @@ subroutine infld_real_3d_3d(varname, ncid, dimname1, dimname2, dimname3, &
cnt = arraydimsize
call shr_scam_getCloseLatLon(ncid,scmlat,scmlon,closelat,closelon,latidx,lonidx)
if (trim(field_dnames(1)) == 'lon') then
- strt(1) = lonidx ! First dim always lon for Eulerian dycore
+ strt(1) = lonidx
else
call endrun(trim(subname)//': lon should be first dimension for '//trim(varname))
end if
diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90
index e26a2e63b9..65cc4e8e80 100644
--- a/src/control/scamMod.F90
+++ b/src/control/scamMod.F90
@@ -290,7 +290,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in)
if( single_column ) then
if( npes>1) call endrun('SCAM_READNL: SCAM doesnt support using more than 1 pe.')
- if ( .not. (dycore_is('EUL') .or. dycore_is('SE')) .or. plon /= 1 .or. plat /=1 ) then
+ if ( .not. dycore_is('SE') .or. plon /= 1 .or. plat /=1 ) then
call endrun('SCAM_SETOPTS: must compile model for SCAM mode when namelist parameter single_column is .true.')
endif
diff --git a/src/dynamics/eul/bndexch.F90 b/src/dynamics/eul/bndexch.F90
deleted file mode 100644
index 95b6a04cb5..0000000000
--- a/src/dynamics/eul/bndexch.F90
+++ /dev/null
@@ -1,248 +0,0 @@
-
-subroutine bndexch( adv_state )
-
-!-----------------------------------------------------------------------
-!
-! Purpose: Pack and Exchange initial prognostic information among all the
-! processors
-!
-! Method:
-!
-! Author:
-!
-!-----------------------------------------------------------------------
-! $Id$
-! $Author$
-!
-!----------------------------Parameters---------------------------------
-
-#ifdef SPMD
- use spmd_dyn, only: cut, cutex, neighs, neighs_proc, &
- neighn, neighn_proc, dyn_npes
- use spmd_utils, only: iam
-#endif
- use scanslt, only: advection_state
-
- implicit none
-!
-! Arguments
-!
- type(advection_state), intent(inout) :: adv_state ! Advection state data
-!
-! Local workspace
-!
-#ifdef SPMD
- integer ns, nn
- integer inreg( 2 )
- integer outreg( 2 )
- integer others,othern ! Other node
-!
-! Return if number of processors is less than 2
-!
- if (dyn_npes .lt. 2) return
-!
-! For each partition (south and north) communicate boundaries
-! on each side of partition among however many neighbors necessary
-!
-! send south, receive north
-!
- ns = 1
- nn = 1
- do while (ns .le. neighs .or. nn .le. neighn)
- if (ns .le. neighs) then
- others = neighs_proc(ns)
-!
-! Intersection of my cuts and neighbor processor's extended
-! cuts tells if this node needs to send data to neighbor
-!
- call intersct(cut(1,iam),cutex(1,others),outreg)
- ns = ns + 1
- else
- others = -1
- outreg(1) = 0
- outreg(2) = 0
- end if
-
- if (nn .le. neighn) then
- othern = neighn_proc(nn)
-!
-! Intersection of neighbor cuts and this node's extended
-! cut tells if this node receives data from neighbor
-!
- call intersct(cut(1,othern),cutex(1,iam),inreg)
- nn = nn + 1
- else
- othern = -1
- inreg(1) = 0
- inreg(2) = 0
- end if
-
- call bndexch_mpi(others,outreg,othern,inreg,adv_state)
- end do
-
-!
-! send north, receive south
-!
- ns = 1
- nn = 1
- do while (ns .le. neighs .or. nn .le. neighn)
- if (nn .le. neighn) then
- othern = neighn_proc(nn)
-!
-! Intersection of my cuts and neighbor processor's extended
-! cuts tells if this node needs to send data to neighbor
-!
- call intersct(cut(1,iam),cutex(1,othern),outreg)
- nn = nn + 1
- else
- othern = -1
- outreg(1) = 0
- outreg(2) = 0
- end if
-
- if (ns .le. neighs) then
- others = neighs_proc(ns)
-!
-! Intersection of neighbor cuts and this node's extended
-! cut tells if this node receives data from neighbor
-!
- call intersct(cut(1,others),cutex(1,iam),inreg)
- ns = ns + 1
- else
- others = -1
- inreg(1) = 0
- inreg(2) = 0
- end if
-
- call bndexch_mpi(othern,outreg,others,inreg, adv_state)
- end do
-#endif
- return
-end subroutine bndexch
-
-#ifdef SPMD
-subroutine bndexch_mpi(othero,outreg,otheri,inreg, adv_state)
-!-----------------------------------------------------------------------
-! Send initial prognostic information to my peer process
-!-----------------------------------------------------------------------
- use scanslt, only: plndlv, j1
- use pmgrid, only: plat
- use constituents, only: pcnst
- use scanslt, only: advection_state
- use mpishorthand
-
- implicit none
-!
-! Arguments
-!
- integer othero,outreg(2),otheri,inreg(2)
- type(advection_state), intent(inout) :: adv_state ! Advection state data
-!
-! Local variables
-!
- integer, parameter :: msgtype = 6000
- integer, parameter :: j1m = j1 - 1
- integer, parameter :: siz = (2 + pcnst)*plndlv
- integer num
- integer msg
-
- integer reqs(3*(plat+1))
- integer stats(MPI_STATUS_SIZE, 3*(plat+1))
-
- integer reqr(3*(plat+1))
- integer statr(MPI_STATUS_SIZE, 3*(plat+1))
-
- integer i,j
- integer reqs_i,reqr_i
-
- reqr_i = 0
- if (otheri .ne. -1) then
- do i = inreg(1), inreg(2)
- j = 3*(i-inreg(1))
- msg = msgtype + j
- reqr_i = reqr_i + 1
- call mpiirecv (adv_state%u3(1,1,j1m+i),plndlv,mpir8, otheri,msg,mpicom,reqr(reqr_i))
-
- msg = msgtype + j + 1
- reqr_i = reqr_i + 1
- call mpiirecv (adv_state%v3(1,1,j1m+i),plndlv,mpir8, otheri,msg,mpicom,reqr(reqr_i))
-
- msg = msgtype + j + 2
- reqr_i = reqr_i + 1
- num = pcnst*plndlv
- call mpiirecv (adv_state%qminus(1,1,1,j1m+i),num,mpir8, otheri,msg,mpicom,reqr(reqr_i))
-
- end do
- end if
-
- reqs_i = 0
- if (othero .ne. -1) then
- do i = outreg(1), outreg(2)
- j = 3*(i-outreg(1))
-
- msg = msgtype + j
- reqs_i = reqs_i + 1
- call mpiisend (adv_state%u3(1,1,j1m+i),plndlv,mpir8, othero,msg,mpicom,reqs(reqs_i))
-
- msg = msgtype + j + 1
- reqs_i = reqs_i + 1
- call mpiisend (adv_state%v3(1,1,j1m+i),plndlv,mpir8, othero,msg,mpicom,reqs(reqs_i))
-
- msg = msgtype + j + 2
- reqs_i = reqs_i + 1
- num = pcnst*plndlv
- call mpiisend (adv_state%qminus(1,1,1,j1m+i),num,mpir8, othero,msg,mpicom,reqs(reqs_i))
-
- end do
- end if
-
- if (reqs_i .ne. 0) then
- call mpiwaitall(reqs_i,reqs,stats)
- end if
-
- if (reqr_i .ne. 0) then
- call mpiwaitall(reqr_i,reqr,statr)
- end if
-
- return
-end subroutine bndexch_mpi
-
-subroutine intersct (regiona, regionb, regionc)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-!
-! Method:
-! Given two regions (a,b) output the intersection (common latitudes)
-! of these two sets. The routine is used in bndexch to determine which
-! latitudes need to be communicated to neighboring processors. Typically
-! this routine is invoked as the intersection of the set of resident
-! latitudes on processor A with the set of extended latitudes (needed for
-! the SLT) of processor B. Any common latitudes will need to be
-! communicated to B to complete SLT processing.
-!
-! Author:
-! Original version: CCM2
-! Standardized: J. Rosinski, Oct 1995
-! J. Truesdale, Feb. 1996
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!----------------------------Commons------------------------------------
- implicit none
-!
-!---------------------------Local workspace-----------------------------
-!
- integer regiona( 2 ),regionb( 2 ),regionc( 2 )
-!
-!-----------------------------------------------------------------------
-!
- regionc( 1 ) = max( regiona( 1 ), regionb( 1 ) )
- regionc( 2 ) = min( regiona( 2 ), regionb( 2 ) )
-
- return
-end subroutine intersct
-#endif
diff --git a/src/dynamics/eul/commap.F90 b/src/dynamics/eul/commap.F90
deleted file mode 100644
index a47acecbb5..0000000000
--- a/src/dynamics/eul/commap.F90
+++ /dev/null
@@ -1,23 +0,0 @@
-module commap
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plat, plon
- use pspect, only: pmmax, pnmax
-
- real(r8) :: bps(plev) ! coefficient for ln(ps) term in divergence eqn
- real(r8) :: sq(pnmax) ! n(n+1)/a^2 (del^2 response function)
- real(r8) :: rsq(pnmax) ! a^2/(n(n+1))
- real(r8) :: slat((plat+1)/2) ! |sine latitude| (hemisphere)
- real(r8), target :: w(plat) ! gaussian weights (hemisphere)
- real(r8) :: cs((plat+1)/2) ! cosine squared latitude (hemisphere)
- real(r8) :: href(plev,plev) ! reference hydrostatic equation matrix
- real(r8) :: ecref(plev,plev) ! reference energy conversion matrix
- real(r8), target :: clat(plat) ! model latitudes (radians)
- real(r8), target :: clon(plon,plat) ! model longitudes (radians)
- real(r8), target :: latdeg(plat) ! model latitudes (degrees)
- real(r8) :: bm1(plev,plev,pnmax) ! transpose of right eigenvectors of semi-implicit matrix
- real(r8) :: tau(plev,plev ) ! matrix for reference d term in thermodynamic eqn
- real(r8), target :: londeg(plon,plat) ! model longitudes (degrees)
- real(r8) :: t0(plev) ! Reference temperature for t-prime computations
- real(r8) :: xm(pmmax) ! m (longitudinal wave number)
-end module commap
diff --git a/src/dynamics/eul/comspe.F90 b/src/dynamics/eul/comspe.F90
deleted file mode 100644
index f33933d445..0000000000
--- a/src/dynamics/eul/comspe.F90
+++ /dev/null
@@ -1,43 +0,0 @@
-module comspe
-
-! Spectral space arrays
-
-use shr_kind_mod, only: r8 => shr_kind_r8
-use pmgrid, only: plev, plat
-use pspect, only: pmmax, pspt
-
-implicit none
-
-real(r8), dimension(:,:), allocatable :: vz ! Vorticity spectral coefficients
-real(r8), dimension(:,:), allocatable :: d ! Divergence spectral coefficients
-real(r8), dimension(:,:), allocatable :: t ! Temperature spectral coefficients
-real(r8), dimension(:), allocatable :: alps ! Log-pressure spectral coefficients
-
-#if ( defined SPMD )
-integer :: maxm = huge(1) ! max number of Fourier wavenumbers per MPI task
-integer :: lpspt = huge(1) ! number of local spectral coefficients
-integer, dimension(:), allocatable :: numm
- ! number of Fourier wavenumbers owned per task
-integer, dimension(:,:), allocatable :: locm, locrm
- ! assignment of wavenumbers to MPI tasks
-integer, dimension(:), allocatable :: lnstart
- ! Starting indices for local spectral arrays (real)
-#else
-integer :: numm(0:0) = pmmax
-integer :: maxm = pmmax
-integer :: lpspt = pspt
-integer :: locm(1:pmmax, 0:0) = huge(1)
-integer :: locrm(1:2*pmmax, 0:0) = huge(1)
-integer :: lnstart(1:pmmax) = huge(1)
-#endif
-
-integer :: nstart(pmmax) = huge(1) ! Starting indices for spectral arrays (real)
-integer :: nlen(pmmax) = huge(1) ! Length vectors for spectral arrays
-
-real(r8), dimension(:,:), allocatable :: alp ! Legendre polynomials (pspt,plat/2)
-real(r8), dimension(:,:), allocatable :: dalp ! Legendre polynomial derivatives (pspt,plat/2)
-
-real(r8), dimension(:,:), allocatable :: lalp ! local Legendre polynomials
-real(r8), dimension(:,:), allocatable :: ldalp ! local Legendre polynomial derivatives
-
-end module comspe
diff --git a/src/dynamics/eul/comsta.h b/src/dynamics/eul/comsta.h
deleted file mode 100644
index 70393bcc47..0000000000
--- a/src/dynamics/eul/comsta.h
+++ /dev/null
@@ -1,15 +0,0 @@
-!
-! $Id$
-! $Author$
-!
-!
-! Diagnostic statistics integrals
-!
- common/comsta/rmsz(plat) ,rmsd(plat) ,rmst(plat) ,stq(plat), &
- psurf(plat)
-!
- real(r8) rmsz ! lambda/p sum of w*dp/ps times square vorticity
- real(r8) rmsd ! lambda/p sum of w*dp/ps times square divergence
- real(r8) rmst ! lambda/p sum of w*dp/ps times square temperature
- real(r8) stq ! lambda/p sum of w*dp/ps times square moisture
- real(r8) psurf ! lambda/p sum of w*dp/ps times square surface press
diff --git a/src/dynamics/eul/courlim.F90 b/src/dynamics/eul/courlim.F90
deleted file mode 100644
index f1a84853f2..0000000000
--- a/src/dynamics/eul/courlim.F90
+++ /dev/null
@@ -1,170 +0,0 @@
-
-subroutine courlim (vmax2d, vmax2dt, vcour)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Find out whether Courant limiter needs to be applied
-!
-! Method:
-!
-! Author:
-! Original version: CCM2
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use physconst, only: rga
- use time_manager, only: get_nstep, is_first_step
- use eul_control_mod
-#ifdef SPMD
- use mpishorthand
-#endif
- use spmd_utils, only: masterproc
- use perf_mod
- use cam_logfile, only: iulog
-
- implicit none
-
-#include <comsta.h>
-
-!
-! Arguments
-!
- real(r8), intent(inout) :: vmax2d(plev,plat) ! Max. wind at each level, latitude
- real(r8), intent(inout) :: vmax2dt(plev,plat) ! Max. truncated wind at each lvl,lat
- real(r8), intent(inout) :: vcour(plev,plat) ! Maximum Courant number in slice
-!
-!--------------------------Local Variables------------------------------
-!
- integer k,lat ! Indices
- integer latarr(1) ! Output from maxloc (needs to be array for conformability)
- integer :: nstep ! Current timestep number
-
- real(r8) vcourmax ! Max courant number in the vertical wind field
- real(r8) vmax1d(plev) ! Sqrt of max wind speed
- real(r8) vmax1dt(plev) ! Sqrt of max wind speed
- real(r8) cn ! Estimate of truncated Courant number
- real(r8) cnmax ! Max. courant no. horiz. wind field
- real(r8) psurfsum ! Summing variable - global mass
- real(r8) stqsum ! Summing variable - global moisture
- real(r8) rmszsum ! Summing variable - global vorticity
- real(r8) rmsdsum ! Summing variable - global divergence
- real(r8) rmstsum ! Summing variable - global temperature
- real(r8) stps ! Global Mass integral
- real(r8) stqf ! Global Moisture integral
- real(r8) rmszf ! Global RMS Vorticity
- real(r8) rmsdf ! Global RMS Divergence
- real(r8) rmstf ! Global RMS Temperature
-!
-!-----------------------------------------------------------------------
-!
-#if ( defined SPMD )
- call t_barrierf ('sync_realloc7', mpicom)
- call t_startf ('realloc7')
- call realloc7 (vmax2d, vmax2dt, vcour)
- call t_stopf ('realloc7')
-#endif
-
- nstep = get_nstep()
-!
-! Compute maximum wind speed for each level
-!
- do k=1,plev
- vmax1d(k) = sqrt (maxval (vmax2d(k,:)))
- vmax1dt(k) = sqrt (maxval (vmax2dt(k,:)))
- end do
-!
-! Compute max. vertical Courant number (k is index to Model interfaces)
-!
- vcourmax = maxval (vcour(2:,:))
-!
-! Determine whether the CFL limit has been exceeded for each level
-! within the specified range (k<=kmxhdc). Set the truncation wave number
-! (for each level independently) so that the CFL limit will not be
-! violated and print a message (information only). The trunc wavenumber
-! is used later in "hordif" to adjust the diffusion coefficients for
-! waves beyond the limit. Store the maximum Courant number for printing
-! on the stats line. Note that the max Courant number is not computed
-! for the entire vertical domain, just the portion for which the limiter
-! is actually applied.
-!
- cnmax = 0._r8
- do k=1,kmxhdc
- cn = vmax1dt(k)*cnfac ! estimate of truncated Courant number
- cnmax = max(cnmax,cn)
- if (cn .gt. cnlim) then
- nindex(k) = int(nmaxhd*cnlim/cn + 1._r8)
- latarr = maxloc (vmax2dt(k,:))
- if (masterproc) write(iulog,800)k,latarr,cn,nindex(k)-1
- else
- nindex(k) = 2*nmaxhd
- endif
- end do
-!
-! Write out estimate of original Courant number if limit is exceeded
-!
- do k=1,kmxhdc
- cn = vmax1d(k)*cnfac ! estimate of original Courant number
- if (cn .gt. cnlim) then
- latarr = maxloc (vmax2d(k,:))
- if (masterproc) write(iulog,805) k,latarr,cn
- end if
- end do
-!
-! Compute Max Courant # for whole atmosphere for diagnostic output
-!
- cnmax = 0._r8
- do k=1,plev-1
- cn = vmax1dt(k)*cnfac ! estimate of Courant number
- cnmax = max(cnmax,cn)
- end do
-!
-! Write out statisitics to standard output
-!
- psurfsum = 0._r8
- stqsum = 0._r8
- rmszsum = 0._r8
- rmsdsum = 0._r8
- rmstsum = 0._r8
-
- do lat=1,plat
- psurfsum = psurfsum + psurf(lat)
- stqsum = stqsum + stq(lat)
- rmszsum = rmszsum + rmsz(lat)
- rmsdsum = rmsdsum + rmsd(lat)
- rmstsum = rmstsum + rmst(lat)
- end do
-
- stps = 0.5_r8*psurfsum
- stqf = 0.5_r8*rga*stqsum
- rmszf = sqrt(0.5_r8*rmszsum)
- rmsdf = sqrt(0.5_r8*rmsdsum)
- rmstf = sqrt(0.5_r8*rmstsum)
- if (masterproc) then
- if (is_first_step()) write(iulog,810)
- write(iulog,820) nstep, rmszf, rmsdf, rmstf, stps, stqf, cnmax, vcourmax
- end if
-!
- return
-!
-! Formats
-!
-800 format('COURLIM: *** Courant limit exceeded at k,lat=',2i3, &
- ' (estimate = ',f6.3, '), solution has been truncated to ', &
- 'wavenumber ',i3,' ***')
-805 format(' *** Original Courant limit exceeded at k,lat=',2i3, &
- ' (estimate = ',f6.3,')',' ***')
-810 format(/109x,'COURANT'/10x,'NSTEP',4x,'RMSZ',19x,'RMSD',19x, &
- 'RMST',4x,'STPS',9x,'STQ',19x,'HOR VERT')
-820 format(' NSTEP =',i8,1x,1p,2e23.15,0p,1f8.3,1p,1e13.5,e23.15, &
- 0p,1f5.2,f6.2)
-end subroutine courlim
-
diff --git a/src/dynamics/eul/cubxdr.F90 b/src/dynamics/eul/cubxdr.F90
deleted file mode 100644
index 4731a2e46e..0000000000
--- a/src/dynamics/eul/cubxdr.F90
+++ /dev/null
@@ -1,83 +0,0 @@
-subroutine cubxdr(pidim ,ibeg ,len ,dx ,f , &
- fxl ,fxr )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute Lagrangian cubic derivative estimates for data on an equally
-! spaced grid.
-!
-! Method:
-! Compute Lagrangian cubic derivative estimates for data on an equally
-! spaced grid. Suppose grid interval i is centered in a 4 point
-! stencil consisting of grid points i-1, i, i+1, and i+2. Then the
-! derivative at the left edge of the interval (i.e., grid point i)
-! is stored in fxl(i), and the derivative at the right edge of the
-! interval (i.e., grid point i+1) is stored in fxr(i). Note that
-! fxl(i) is not necessarily equal to fxr(i-1) even though both of
-! these values are estimates of the derivative at grid point i.
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: pidim ! dimension
- integer, intent(in) :: ibeg ! starting index to perform computation
- integer, intent(in) :: len ! length over which to perform comp.
-!
- real(r8), intent(in) :: dx ! grid interval
- real(r8), intent(in) :: f(pidim) ! input field values
-!
-! Output arguments
-!
- real(r8), intent(out) :: fxl(pidim) ! left derivative of interval i in "f"
- real(r8), intent(out) :: fxr(pidim) ! right derivative of interval i in "f"
-!-----------------------------------------------------------------------
-!
-! pidim Length of f, fxl, and fxr.
-! ibeg First interval of grid for which derivatives are computed.
-! len Number of grid intervals for which derivatives are computed.
-! (There are pidim - 1 intervals between the pidim gridpoints
-! represented in f, fxl, and fxr.)
-! dx Value of grid spacing.
-! f Values on equally spaced grid for which derivatives are
-! computed.
-! fxl fxl(i) is the derivative at the left edge of interval i.
-! fxr fxr(i) is the derivative at the right edge of interval i.
-!
-!---------------------------Local variables-----------------------------
-!
- integer i ! index
- integer iend ! index denoting end of computation
-!
- real(r8) rdx6 ! normalization weight
-!
-!-----------------------------------------------------------------------
-!
- fxl = 0._r8
- fxr = 0._r8
-
- iend = ibeg + len - 1
- rdx6 = 1._r8/(6._r8*dx)
-!
- do i = ibeg,iend
- fxl(i) = ( -2._r8*f(i-1) - 3._r8*f(i) + 6._r8*f(i+1) - f(i+2) )*rdx6
- fxr(i) = ( f(i-1) - 6._r8*f(i) + 3._r8*f(i+1) + 2._r8*f(i+2) )*rdx6
- end do
-!
- return
-end subroutine cubxdr
-
diff --git a/src/dynamics/eul/cubydr.F90 b/src/dynamics/eul/cubydr.F90
deleted file mode 100644
index b20ccc6f86..0000000000
--- a/src/dynamics/eul/cubydr.F90
+++ /dev/null
@@ -1,130 +0,0 @@
-subroutine cubydr(pf ,fint ,wdy ,jdp ,jcen , &
- fyb ,fyt ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute Lagrangian cubic derivative estimates at both ends of the
-! intervals in the y coordinate (unequally spaced) containing the
-! departure points for the latitude slice being forecasted.
-!
-! Method:
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
- use scanslt, only: platd
- use cam_abortutils, only: endrun
- use cam_logfile, only: iulog
-#if ( ! defined UNICOSMP )
- use srchutil, only: whenieq
-#endif
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-#include <parslt.h>
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: pf ! number of constituent fields
-!
- real(r8), intent(in) :: fint(plon,plev,ppdy,pf) ! constituent x- interpolants
- real(r8), intent(in) :: wdy(4,2,platd) ! latitude interpolation weights
-!
- integer, intent(in) :: jdp(plon,plev) ! indices of latitude intervals
- integer, intent(in) :: jcen ! current latitude index
- integer, intent(in) :: nlon
-!
-! Output arguments
-!
- real(r8), intent(out) :: fyb(plon,plev,pf) ! Derivative at south end of interval
- real(r8), intent(out) :: fyt(plon,plev,pf) ! Derivative at north end of interval
-!-----------------------------------------------------------------------
-!
-! pf Number of fields being interpolated.
-! fint (fint(i,k,j,m),j=1,ppdy) contains the x interpolants at each
-! latitude needed for the y derivative estimates at the
-! endpoints of the interval that contains the departure point
-! for grid point (i,k). The last index of fint allows for
-! interpolation of multiple fields. fint is generated by a
-! call to herxin.
-! wdy Weights for Lagrange cubic derivative estimates on the
-! unequally spaced latitude grid. If grid interval j (in
-! extended array) is surrounded by a 4 point stencil, then
-! the derivative at the "bottom" of the interval uses the
-! weights wdy(1,1,j),wdy(2,1,j), wdy(3,1,j), and wdy(4,1,j).
-! The derivative at the "top" of the interval uses wdy(1,2,j),
-! wdy(2,2,j), wdy(3,2,j), and wdy(4,2,j).
-! jdp jdp(i,k) is the index of the y-interval that contains the
-! departure point corresponding to global grid point (i,k) in
-! the latitude slice being forecasted.
-! Suppose yb contains the y-coordinates of the extended array
-! and ydp(i,k) is the y-coordinate of the departure point
-! corresponding to grid point (i,k). Then,
-! yb(jdp(i,k)) .le. ydp(i,k) .lt. yb(jdp(i,k)+1) .
-! fyb fyb(i,k,.) is the derivative at the bottom of the y interval
-! that contains the departure point of global grid point (i,k).
-! fyt fyt(i,k,.) is the derivative at the top of the y interval
-! that contains the departure point of global grid point (i,k).
-!
-!---------------------------Local variables-----------------------------
-!
- integer i,k ! index
- integer m ! index
- integer jdpval ! index
- integer icount ! counter
- integer ii ! index
- integer indx(plon) ! set of indices for indirect addressing
- integer nval(plev) ! number of indices for given "jdpval"
-!
-!-----------------------------------------------------------------------
-!
- icount = 0
- do jdpval=jcen-2,jcen+1
-!$OMP PARALLEL DO PRIVATE (K, INDX, M, II, I)
- do k=1,plev
- call whenieq(nlon,jdp(1,k),1,jdpval,indx,nval(k))
- do m=1,pf
- do ii=1,nval(k)
- i=indx(ii)
- fyb(i,k,m) = wdy(1,1,jdpval)*fint(i,k,1,m) + &
- wdy(2,1,jdpval)*fint(i,k,2,m) + &
- wdy(3,1,jdpval)*fint(i,k,3,m) + &
- wdy(4,1,jdpval)*fint(i,k,4,m)
-!
- fyt(i,k,m) = wdy(1,2,jdpval)*fint(i,k,1,m) + &
- wdy(2,2,jdpval)*fint(i,k,2,m) + &
- wdy(3,2,jdpval)*fint(i,k,3,m) + &
- wdy(4,2,jdpval)*fint(i,k,4,m)
- end do
- end do
- end do
- do k=1,plev
- icount = icount + nval(k)
- enddo
- if (icount.eq.nlon*plev) return
- end do
- if (icount.ne.nlon*plev) then
- write(iulog,*)'CUBYDR: Departure point out of bounds: jcen,icount,nlon*plev=',jcen,icount,nlon*plev
- write(iulog,*)' ****** MODEL IS BLOWING UP: CFL condition likely violated *********'
- write(iulog,*)' Possible solutions: a) reduce time step'
- write(iulog,*)' b) if initial run, set "DIVDAMPN = 1." in namelist and rerun'
- write(iulog,*)' c) modified code may be in error'
- call endrun ()
- end if
-!
- return
-end subroutine cubydr
diff --git a/src/dynamics/eul/cubzdr.F90 b/src/dynamics/eul/cubzdr.F90
deleted file mode 100644
index c5760249ce..0000000000
--- a/src/dynamics/eul/cubzdr.F90
+++ /dev/null
@@ -1,99 +0,0 @@
-
-subroutine cubzdr(nlon ,pkdim ,f ,lbasdz ,dfz1 , &
- dfz2 )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Vertical derivative estimates for a vertical slice using Lagrangian
-! cubic formulas.
-!
-! Method:
-! Derivatives are set to zero at the top and bottom.
-! At the "inner nodes" of the top and bottom intervals, a "one sided"
-! estimate is used.
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon
-!-----------------------------------------------------------------------
- implicit none
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: nlon ! number of longitudes
- integer, intent(in) :: pkdim ! vertical dimension
-!
- real(r8), intent(in) :: f(plon,pkdim) ! constituent field
- real(r8), intent(in) :: lbasdz(4,2,pkdim) ! vertical interpolation weights
-!
-! Output arguments
-!
- real(r8), intent(out) :: dfz1(plon,pkdim) ! derivative at top of interval
- real(r8), intent(out) :: dfz2(plon,pkdim) ! derivative at bot of interval
-!-----------------------------------------------------------------------
-!
-! nlon Number of longitudes
-! pkdim Vertical dimension of arrays.
-! f Vertical slice of data for which derivative estimates are
-! made
-! lbasdz Lagrangian cubic basis functions for evaluating the
-! derivatives on the unequally spaced vertical grid.
-! dfz1 dfz1 contains derivative estimates at the "top" edges of the
-! intervals in the f array.
-! dfz2 dfz2 contains derivative estimates at the "bottom" edges of
-! the intervals in the f array.
-!
-!---------------------------Local variables-----------------------------
-!
- integer i,k ! indices
-!
-!-----------------------------------------------------------------------
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=2,pkdim-2
- do i=1,nlon
-!
-! Lagrangian derivative estimates (cubic) for the two center nodes in a
-! four node stencil.
-!
- dfz1(i,k) = lbasdz(1,1,k)*f(i,k-1) + &
- lbasdz(2,1,k)*f(i,k) + &
- lbasdz(3,1,k)*f(i,k+1) + &
- lbasdz(4,1,k)*f(i,k+2)
-!
- dfz2(i,k) = lbasdz(1,2,k)*f(i,k-1) + &
- lbasdz(2,2,k)*f(i,k) + &
- lbasdz(3,2,k)*f(i,k+1) + &
- lbasdz(4,2,k)*f(i,k+2)
- end do
- end do
-!
-! Constrain derivatives to zero at top and bottom of vertical grid.
-! At the interior nodes of the intervals at the top and bottom of the
-! vertical grid, use the derivative estimate at that same node for the
-! adjacent interval. (This is a "one-sided" estimate for that node.)
-!
- do i=1,nlon
- dfz1(i,1) = 0.0_r8
- dfz2(i,1) = dfz1(i,2)
- dfz1(i,pkdim-1) = dfz2(i,pkdim-2)
- dfz2(i,pkdim-1) = 0.0_r8
- end do
-!
- return
-end subroutine cubzdr
-
diff --git a/src/dynamics/eul/diag_dynvar_ic.F90 b/src/dynamics/eul/diag_dynvar_ic.F90
deleted file mode 100644
index f7e20c3df9..0000000000
--- a/src/dynamics/eul/diag_dynvar_ic.F90
+++ /dev/null
@@ -1,67 +0,0 @@
-
- subroutine diag_dynvar_ic(phis, ps, t3, u3, v3, q3)
-!
-!-----------------------------------------------------------------------
-!
-! Purpose: record state variables to IC file
-!
-!-----------------------------------------------------------------------
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use cam_history , only: outfld, write_inithist, write_camiop
- use constituents, only: pcnst, cnst_name
- use commap, only:clat,clon
- use dyn_grid, only : get_horiz_grid_d
- implicit none
-!
-!-----------------------------------------------------------------------
-!
-! Arguments
-!
- real(r8), intent(in) :: phis(plon, beglat:endlat) ! Surface geopotential
- real(r8), intent(in) :: ps (plon, beglat:endlat) ! surface pressure
- real(r8), intent(in) :: t3 (plon, plev, beglat:endlat) ! temperature
- real(r8), intent(in) :: u3 (plon, plev, beglat:endlat) ! u-wind component
- real(r8), intent(in) :: v3 (plon, plev, beglat:endlat) ! v-wind component
- real(r8), intent(in) :: q3 (plon, plev, pcnst, beglat:endlat) ! constituents
- real(r8) :: clat_plon(plon) ! constituents
- real(r8) :: phi(plat) ! constituents
- real(r8) :: lam(plon) ! constituents
-!
-!---------------------------Local workspace-----------------------------
-!
- integer lat, m ! indices
-!
-!-----------------------------------------------------------------------
-!
- if( write_inithist() ) then
-
-!$OMP PARALLEL DO PRIVATE (LAT, M)
- do lat=beglat,endlat
-
- call outfld('PS&IC ' , ps (1 ,lat), plon, lat)
- call outfld('T&IC ' , t3 (1,1,lat), plon, lat)
- call outfld('U&IC ' , u3 (1,1,lat), plon, lat)
- call outfld('V&IC ' , v3 (1,1,lat), plon, lat)
- if (write_camiop) then
- clat_plon(:)=clat(lat)
- call outfld('CLAT1&IC ', clat_plon, plon, lat)
- call outfld('CLON1&IC ', clon, plon, lat)
- call get_horiz_grid_d(plat, clat_d_out=phi)
- call get_horiz_grid_d(plon, clon_d_out=lam)
- clat_plon(:)=phi(lat)
- call outfld('LAM&IC ', lam, plon, lat)
- call outfld('PHI&IC ', clat_plon, plon, lat)
- end if
-
- do m=1,pcnst
- call outfld(trim(cnst_name(m))//'&IC', q3(1,1,m,lat), plon, lat)
- end do
-
- end do
-
- end if
-
- return
- end subroutine diag_dynvar_ic
diff --git a/src/dynamics/eul/dp_coupling.F90 b/src/dynamics/eul/dp_coupling.F90
deleted file mode 100644
index bc900e2d0e..0000000000
--- a/src/dynamics/eul/dp_coupling.F90
+++ /dev/null
@@ -1,475 +0,0 @@
-
-!-------------------------------------------------------------------------------
-! dynamics - physics coupling module
-!-------------------------------------------------------------------------------
-module dp_coupling
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use ppgrid, only: pcols, pver
- use pmgrid, only: plev, beglat, endlat, plon
-
- use phys_grid
- use physics_types, only: physics_state, physics_tend
- use constituents, only: pcnst
- use physconst, only: cpair, gravit, rair, zvir
- use air_composition, only: rairv
- use geopotential, only: geopotential_t
- use check_energy, only: check_energy_timestep_init
-#if (defined SPMD)
- use spmd_dyn, only: buf1, buf1win, buf2, buf2win, &
- spmdbuf_siz, local_dp_map, &
- block_buf_nrecs, chunk_buf_nrecs
- use mpishorthand, only: mpicom
-#endif
- use cam_abortutils, only: endrun
- use perf_mod
-
- implicit none
-
-!===============================================================================
-CONTAINS
-!===============================================================================
-
-!===============================================================================
- subroutine d_p_coupling(ps, t3, u3, v3, q3, &
- omga, phis, phys_state, phys_tend, pbuf2d, pdeld)
-!------------------------------------------------------------------------------
-! Coupler for converting dynamics output variables into physics input variables
-! also writes dynamics variables (on physics grid) to history file
-!------------------------------------------------------------------------------
- use physconst, only: cappa
- use constituents, only: cnst_get_type_byind, qmin
- use physics_types, only: set_state_pdry
- use physics_buffer, only: pbuf_get_chunk, physics_buffer_desc
- use qneg_module, only: qneg3
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: ps (plon, beglat:endlat) ! surface pressure
- real(r8), intent(in) :: t3 (plon, plev, beglat:endlat) ! temperature
- real(r8), intent(in) :: u3 (plon, plev, beglat:endlat) ! u-wind component
- real(r8), intent(in) :: v3 (plon, plev, beglat:endlat) ! v-wind component
- real(r8), intent(in) :: q3 (plon, plev, pcnst, beglat:endlat) ! constituents
- real(r8), intent(in) :: omga(plon, plev, beglat:endlat) ! vertical velocity
- real(r8), intent(in) :: phis(plon, beglat:endlat) ! Surface geopotential
- real(r8), intent(in) :: pdeld (:,:,beglat:)
- type(physics_buffer_desc), pointer :: pbuf2d(:,:)
- type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state
- type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend
-
-!
-!---------------------------Local workspace-----------------------------
-#if (! defined SPMD)
- real(r8) :: buf1(1), buf2(1) ! transpose buffers
- integer :: buf1win, buf2win ! MPI-2 window ids
- integer :: spmdbuf_siz = 0
- integer :: block_buf_nrecs = 0
- integer :: chunk_buf_nrecs = 0
- integer :: mpicom = 0
- logical :: local_dp_map=.true.
-#endif
-
- integer :: i,k,j,m,lchnk ! indices
- integer :: ncol ! number of columns in current chunk
- integer :: lats(pcols) ! array of latitude indices
- integer :: lons(pcols) ! array of longitude indices
- integer :: tsize ! amount of data per grid point passed to physics
- integer :: bpter(plon,0:plev) ! offsets into block buffer for packing data
- integer :: cpter(pcols,0:pver) ! offsets into chunk buffer for unpacking data
- logical :: wetq(pcnst) ! 'moist-type' constituent flag
- real(r8) :: rlat(pcols) ! array of latitudes (radians)
- real(r8) :: rlon(pcols) ! array of longitudes (radians)
- real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer
-
- type(physics_buffer_desc), pointer :: pbuf_chnk(:)
-
-!-----------------------------------------------------------------------
-
-! Determine which constituents are wet and which are dry
- do m=2,pcnst
- if (cnst_get_type_byind(m).eq.'wet') then
- wetq(m) = .true.
- else
- wetq(m) = .false.
- endif
- enddo
-
-!-----------------------------------------------------------------------
-! copy data from dynamics data structure to physics data structure
-!-----------------------------------------------------------------------
- if (local_dp_map) then
-
-!$OMP PARALLEL DO PRIVATE (LCHNK, NCOL, I, K, M, LONS, LATS)
- do lchnk = begchunk,endchunk
- ncol = phys_state(lchnk)%ncol
- call get_lon_all_p(lchnk, ncol, lons)
- call get_lat_all_p(lchnk, ncol, lats)
-
- do i=1,ncol
- phys_state(lchnk)%ps (i) = ps (lons(i),lats(i))
- phys_state(lchnk)%phis (i) = phis(lons(i),lats(i))
- end do
-
- do k=1,plev
- do i=1,ncol
- phys_state(lchnk)%t (i,k) = t3 (lons(i),k,lats(i))
- phys_state(lchnk)%u (i,k) = u3 (lons(i),k,lats(i))
- phys_state(lchnk)%v (i,k) = v3 (lons(i),k,lats(i))
- phys_state(lchnk)%omega(i,k) = omga(lons(i),k,lats(i))
- phys_state(lchnk)%q(i,k,1) = q3 (lons(i),k,1,lats(i))
- end do
- end do
-
- do k=1,plev
- do i=1,ncol
- phys_state(lchnk)%pdeldry(i,k) = pdeld(lons(i),k,lats(i))
- end do
- end do
-
- ! convert moist-type constituents from dry to moist mixing ratio
-
- do m=2,pcnst
- if (wetq(m)) then
- do k=1,plev
- do i=1,ncol
- phys_state(lchnk)%q(i,k,m) = q3(lons(i),k,m,lats(i))*(1._r8 - q3(lons(i),k,1,lats(i)))
- end do
- end do
- else
- do k=1,plev
- do i=1,ncol
- phys_state(lchnk)%q(i,k,m) = q3(lons(i),k,m,lats(i))
- end do
- end do
- endif
- end do
-
- end do
-
- else
-
- tsize = 5 + pcnst
-
- if (tsize*max(block_buf_nrecs,chunk_buf_nrecs) > spmdbuf_siz) then
- call endrun ('p_d_coupling: communication buffers (spmdbuf_siz) too small')
- endif
-
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (J, BPTER, I, K, M)
-#endif
- do j=beglat,endlat
-
- call block_to_chunk_send_pters(j,plon,plev+1,tsize,bpter)
-
- do i=1,plon
- buf1(bpter(i,0)) = ps (i,j)
- buf1(bpter(i,0)+1) = phis(i,j)
- end do
-
-!$OMP PARALLEL DO PRIVATE (K, I, M)
- do k=1,plev
-
- do i=1,plon
-
- buf1(bpter(i,k)) = t3 (i,k,j)
- buf1(bpter(i,k)+1) = u3 (i,k,j)
- buf1(bpter(i,k)+2) = v3 (i,k,j)
- buf1(bpter(i,k)+3) = omga(i,k,j)
- buf1(bpter(i,k)+4) = q3 (i,k,1,j)
-
- ! convert moist-type constituents from dry to moist mixing ratio
-
- do m=2,pcnst
- if (wetq(m)) then
- buf1(bpter(i,k)+3+m) = q3(i,k,m,j)*(1._r8 - q3(i,k,1,j))
- else
- buf1(bpter(i,k)+3+m) = q3(i,k,m,j)
- endif
- end do
-
- buf1(bpter(i,k)+4+pcnst) = pdeld(i,k,j)
-
- end do
-
- end do
-
- end do
-
- call t_barrierf ('sync_blk_to_chk', mpicom)
- call t_startf ('block_to_chunk')
- call transpose_block_to_chunk(tsize, buf1, buf2, buf2win)
- call t_stopf ('block_to_chunk')
-
-!$OMP PARALLEL DO PRIVATE (LCHNK, NCOL, CPTER, I, K, M)
- do lchnk = begchunk,endchunk
- ncol = phys_state(lchnk)%ncol
-
- call block_to_chunk_recv_pters(lchnk,pcols,pver+1,tsize,cpter)
-
- do i=1,ncol
- phys_state(lchnk)%ps (i) = buf2(cpter(i,0))
- phys_state(lchnk)%phis (i) = buf2(cpter(i,0)+1)
- end do
-
- do k=1,plev
-
- do i=1,ncol
-
- phys_state(lchnk)%t (i,k) = buf2(cpter(i,k))
- phys_state(lchnk)%u (i,k) = buf2(cpter(i,k)+1)
- phys_state(lchnk)%v (i,k) = buf2(cpter(i,k)+2)
- phys_state(lchnk)%omega (i,k) = buf2(cpter(i,k)+3)
-
- do m=1,pcnst
- phys_state(lchnk)%q (i,k,m) = buf2(cpter(i,k)+3+m)
- end do
-
- phys_state(lchnk)%pdeldry(i,k) = buf2(cpter(i,k)+4+pcnst)
-
- end do
-
- end do
-
- end do
-
- endif
-
-!-----------------------------------------------------------------------
-! Fill auxilliary arrays in physics data structure
-!-----------------------------------------------------------------------
-!$OMP PARALLEL DO PRIVATE (LCHNK, NCOL, I, K, M, LONS, LATS, ZVIRV, pbuf_chnk)
-
- do lchnk = begchunk,endchunk
- ncol = phys_state(lchnk)%ncol
-
-! pressure arrays
- call plevs0(ncol, pcols, pver, &
- phys_state(lchnk)%ps, phys_state(lchnk)%pint, &
- phys_state(lchnk)%pmid, phys_state(lchnk)%pdel)
-
-! log(pressure) arrays and Exner function
- do k=1,pver+1
- do i=1,ncol
- phys_state(lchnk)%lnpint(i,k) = log(phys_state(lchnk)%pint(i,k))
- end do
- end do
- do k=1,pver
- do i=1,ncol
- phys_state(lchnk)%rpdel(i,k) = 1._r8/phys_state(lchnk)%pdel(i,k)
- phys_state(lchnk)%lnpmid(i,k) = log(phys_state(lchnk)%pmid(i,k))
- phys_state(lchnk)%exner (i,k) = (phys_state(lchnk)%pint(i,pver+1) &
- / phys_state(lchnk)%pmid(i,k))**cappa
- end do
- end do
-
-!-----------------------------------------------------------------------------------
-! Need to fill zvirv 2D variable to be compatible with geopotential_t interface
-!-----------------------------------------------------------------------------------
- zvirv(:,:) = zvir
-
-! Compute initial geopotential heights
- call geopotential_t (phys_state(lchnk)%lnpint, phys_state(lchnk)%lnpmid , phys_state(lchnk)%pint , &
- phys_state(lchnk)%pmid , phys_state(lchnk)%pdel , phys_state(lchnk)%rpdel , &
- phys_state(lchnk)%t , phys_state(lchnk)%q(:,:,:), rairv(:,:,lchnk), gravit, zvirv, &
- phys_state(lchnk)%zi , phys_state(lchnk)%zm , ncol )
-
-! Compute initial dry static energy, include surface geopotential
- do k = 1, pver
- do i=1,ncol
- phys_state(lchnk)%s(i,k) = cpair*phys_state(lchnk)%t(i,k) &
- + gravit*phys_state(lchnk)%zm(i,k) + phys_state(lchnk)%phis(i)
- end do
- end do
-
-! Compute other dry fields in phys_state, using pdeld copied from dynamics above
- call set_state_pdry(phys_state(lchnk),pdeld_calc=.false.)
-
-!
-! Ensure tracers are all positive
-!
- call qneg3('D_P_COUPLING',lchnk ,ncol ,pcols ,pver , &
- 1, pcnst, qmin ,phys_state(lchnk)%q)
-
-! Compute energy and water integrals of input state
- pbuf_chnk => pbuf_get_chunk(pbuf2d, lchnk)
- call check_energy_timestep_init(phys_state(lchnk), phys_tend(lchnk), pbuf_chnk )
-
- end do
-
- return
- end subroutine d_p_coupling
-
-!===============================================================================
- subroutine p_d_coupling(phys_state, phys_tend, t2, fu, fv, flx_net, qminus)
-!------------------------------------------------------------------------------
-! Coupler for converting physics output variables into dynamics input variables
-!------------------------------Arguments--------------------------------
- use constituents, only: cnst_get_type_byind
-
- type(physics_state),intent(in), dimension(begchunk:endchunk) :: phys_state
- type(physics_tend), intent(in), dimension(begchunk:endchunk) :: phys_tend
-
- real(r8), intent(out) :: t2(plon, plev, beglat:endlat) ! temp tendency
- real(r8), intent(out) :: fu(plon, plev, beglat:endlat) ! u wind tendency
- real(r8), intent(out) :: fv(plon, plev, beglat:endlat) ! v wind tendency
- real(r8), intent(out) :: flx_net(plon,beglat:endlat) ! net flux
- real(r8), intent(out) :: qminus(plon, plev, pcnst, beglat:endlat) ! constituents
-!
-!---------------------------Local workspace-----------------------------
-#if (! defined SPMD)
- real(r8) :: buf1(1), buf2(1) ! transpose buffers
- integer :: buf1win, buf2win ! MPI-2 window ids
- integer :: spmdbuf_siz = 0
- integer :: block_buf_nrecs = 0
- integer :: chunk_buf_nrecs = 0
- integer :: mpicom = 0
- logical :: local_dp_map=.true.
-#endif
-
- integer :: i,j,k,m,lchnk ! indices
- integer :: ncol ! number of columns in current chunk
- integer :: lats(pcols) ! array of latitude indices
- integer :: lons(pcols) ! array of longitude indices
- integer :: tsize ! amount of data per grid point passed to physics
- integer :: bpter(plon,0:plev) ! offsets into block buffer for packing data
- integer :: cpter(pcols,0:pver) ! offsets into chunk buffer for unpacking data
- logical :: wetq(pcnst) ! 'wet' constituent flag
-!-----------------------------------------------------------------------
-
-! Determine which constituents are wet and which are dry
- do m=2,pcnst
- if (cnst_get_type_byind(m).eq.'wet') then
- wetq(m) = .true.
- else
- wetq(m) = .false.
- endif
- enddo
-!-----------------------------------------------------------------------
-! copy data from physics data structure to dynamics data structure
-!-----------------------------------------------------------------------
- if (local_dp_map) then
-
-!$OMP PARALLEL DO PRIVATE (LCHNK, NCOL, I, K, M, LONS, LATS)
-
- do lchnk = begchunk,endchunk
- ncol = get_ncols_p(lchnk)
- call get_lon_all_p(lchnk, ncol, lons)
- call get_lat_all_p(lchnk, ncol, lats)
-
- do k=1,plev
- do i=1,ncol
- t2(lons(i),k,lats(i)) = phys_tend(lchnk)%dTdt (i,k)
- fu(lons(i),k,lats(i)) = phys_tend(lchnk)%dudt (i,k)
- fv(lons(i),k,lats(i)) = phys_tend(lchnk)%dvdt (i,k)
- qminus(lons(i),k,1,lats(i)) = phys_state(lchnk)%q(i,k,1)
- end do
- end do
-
- do i=1,ncol
- flx_net(lons(i),lats(i)) = phys_tend(lchnk)%flx_net(i)
- end do
-
- ! convert moist-type constituents from moist to dry mixing ratio
-
- do m=2,pcnst
- if (wetq(m)) then
- do k=1,plev
- do i=1,ncol
- qminus(lons(i),k,m,lats(i)) = phys_state(lchnk)%q(i,k,m) / &
- (1._r8 - phys_state(lchnk)%q(i,k,1))
- end do
- end do
- else
- do k=1,plev
- do i=1,ncol
- qminus(lons(i),k,m,lats(i)) = phys_state(lchnk)%q(i,k,m)
- end do
- end do
- endif
- end do
-
- end do
-
- else
-
- tsize = 3 + pcnst
-
- if (tsize*max(block_buf_nrecs,chunk_buf_nrecs) > spmdbuf_siz) then
- call endrun ('d_p_coupling: communication buffers (spmdbuf_siz) too small')
- endif
-
-!$OMP PARALLEL DO PRIVATE (LCHNK, NCOL, CPTER, I, K, M)
- do lchnk = begchunk,endchunk
- ncol = get_ncols_p(lchnk)
-
- call chunk_to_block_send_pters(lchnk,pcols,pver+1,tsize,cpter)
-
- do i=1,ncol
- buf2(cpter(i,0)) = phys_tend(lchnk)%flx_net(i)
- end do
-
- do k=1,plev
-
- do i=1,ncol
-
- buf2(cpter(i,k)) = phys_tend(lchnk)%dTdt (i,k)
- buf2(cpter(i,k)+1) = phys_tend(lchnk)%dudt (i,k)
- buf2(cpter(i,k)+2) = phys_tend(lchnk)%dvdt (i,k)
- buf2(cpter(i,k)+3) = phys_state(lchnk)%q(i,k,1)
-
- ! convert moist-type constituents from moist to dry mixing ratio
-
- do m=2,pcnst
- if (wetq(m)) then
- buf2(cpter(i,k)+2+m) = phys_state(lchnk)%q(i,k,m) / &
- (1._r8 - phys_state(lchnk)%q(i,k,1))
- else
- buf2(cpter(i,k)+2+m) = phys_state(lchnk)%q(i,k,m)
- endif
- end do
-
- end do
-
- end do
-
- end do
-
- call t_barrierf ('sync_chk_to_blk', mpicom)
- call t_startf ('chunk_to_block')
- call transpose_chunk_to_block(tsize, buf2, buf1, buf1win)
- call t_stopf ('chunk_to_block')
-
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (J, BPTER, I, K, M)
-#endif
- do j=beglat,endlat
-
- call chunk_to_block_recv_pters(j,plon,plev+1,tsize,bpter)
-
- do i=1,plon
- flx_net(i,j) = buf1(bpter(i,0))
- end do
-
-!$OMP PARALLEL DO PRIVATE (K, I, M)
- do k=1,plev
-
- do i=1,plon
-
- t2(i,k,j) = buf1(bpter(i,k))
- fu(i,k,j) = buf1(bpter(i,k)+1)
- fv(i,k,j) = buf1(bpter(i,k)+2)
-
- do m=1,pcnst
- qminus(i,k,m,j) = buf1(bpter(i,k)+2+m)
- end do
-
- end do
-
- end do
-
- end do
-
- endif
-
- return
- end subroutine p_d_coupling
-end module dp_coupling
diff --git a/src/dynamics/eul/dycore.F90 b/src/dynamics/eul/dycore.F90
deleted file mode 100644
index 726396e9a4..0000000000
--- a/src/dynamics/eul/dycore.F90
+++ /dev/null
@@ -1,28 +0,0 @@
-module dycore
-
-implicit none
-private
-
-public :: dycore_is
-
-!=========================================================================================
-CONTAINS
-!=========================================================================================
-
-logical function dycore_is(name)
-
- character(len=*), intent(in) :: name
-
- if (name == 'eul' .or. name == 'EUL') then
- dycore_is = .true.
- else
- dycore_is = .false.
- end if
-
-end function dycore_is
-
-!=========================================================================================
-
-end module dycore
-
-
diff --git a/src/dynamics/eul/dycore_budget.F90 b/src/dynamics/eul/dycore_budget.F90
deleted file mode 100644
index 7531d69ac7..0000000000
--- a/src/dynamics/eul/dycore_budget.F90
+++ /dev/null
@@ -1,27 +0,0 @@
-module dycore_budget
-implicit none
-
-public :: print_budget
-
-!=========================================================================================
-contains
-!=========================================================================================
-
-subroutine print_budget(hstwr)
-
- use spmd_utils, only: masterproc
- use cam_abortutils, only: endrun
- use cam_budget, only: thermo_budget_history,thermo_budget_histfile_num
-
- ! arguments
- logical, intent(in) :: hstwr(:)
- character(len=*), parameter :: subname = 'dycore_budget:print_budgets:'
-
- !--------------------------------------------------------------------------------------
-
- if (masterproc .and. thermo_budget_history .and. hstwr(thermo_budget_histfile_num)) then
- call endrun(subname//' is not implemented for the EUL dycore')
- end if
-end subroutine print_budget
-
-end module dycore_budget
diff --git a/src/dynamics/eul/dyn.F90 b/src/dynamics/eul/dyn.F90
deleted file mode 100644
index be70698c4e..0000000000
--- a/src/dynamics/eul/dyn.F90
+++ /dev/null
@@ -1,124 +0,0 @@
- subroutine dyn(irow ,grlps1 ,grt1 ,grz1 ,grd1 , &
- grfu1 ,grfv1 ,grut1 ,grvt1 ,grrh1 , &
- grlps2 ,grt2 ,grz2 ,grd2 ,grfu2 , &
- grfv2 ,grut2 ,grvt2 ,grrh2, ztodt )
-!-----------------------------------------------------------------------
-!
-! Combine undifferentiated and longitudinally differentiated Fourier
-! coefficient terms for later use in the Gaussian quadrature
-!
-! Computational note: Index "2*m-1" refers to the real part of the
-! complex coefficient, and "2*m" to the imaginary.
-!
-! The naming convention is as follows:
-! - t, q, d, z refer to temperature, specific humidity, divergence
-! and vorticity
-! - "1" suffix to an array => symmetric component of current latitude pair
-! - "2" suffix to an array => antisymmetric component
-!
-!---------------------------Code history--------------------------------
-!
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, B. Boville, J. Hack, August 1992
-! Reviewed: D. Williamson, March 1996
-! Modified: P. Worley, September 2002
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use comspe
- use commap
- use physconst, only: rearth
- use time_manager, only: get_step_size, is_first_step
- use spmd_utils, only: iam
- implicit none
-
-!
-! Input arguments
-!
- integer irow ! latitude pair index
-!
-! Input/output arguments
-!
- real(r8) grlps1(2*maxm) ! sym. surface pressure equation term
- real(r8) grt1(2*maxm,plev) ! sym. undifferentiated term in t eqn.
- real(r8) grz1(2*maxm,plev) ! sym. undifferentiated term in z eqn.
- real(r8) grd1(2*maxm,plev) ! sym. undifferentiated term in d eqn.
- real(r8) grfu1(2*maxm,plev) ! sym. nonlinear terms in u eqn.
- real(r8) grfv1(2*maxm,plev) ! sym. nonlinear terms in v eqn.
- real(r8) grut1(2*maxm,plev) ! sym. lambda derivative term in t eqn.
- real(r8) grvt1(2*maxm,plev) ! sym. mu derivative term in t eqn.
- real(r8) grrh1(2*maxm,plev) ! sym. RHS of divergence eqn (del^2 term)
- real(r8) grlps2(2*maxm) ! antisym. surface pressure equation term
- real(r8) grt2(2*maxm,plev) ! antisym. undifferentiated term in t eqn.
- real(r8) grz2(2*maxm,plev) ! antisym. undifferentiated term in z eqn.
- real(r8) grd2(2*maxm,plev) ! antisym. undifferentiated term in d eqn.
- real(r8) grfu2(2*maxm,plev) ! antisym. nonlinear terms in u eqn.
- real(r8) grfv2(2*maxm,plev) ! antisym. nonlinear terms in v eqn.
- real(r8) grut2(2*maxm,plev) ! antisym. lambda derivative term in t eqn.
- real(r8) grvt2(2*maxm,plev) ! antisym. mu derivative term in t eqn.
- real(r8) grrh2(2*maxm,plev) ! antisym. RHS of divergence eqn (del^2 term)
- real(r8) ztodt
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) tmp1,tmp2 ! temporaries
- real(r8) zxm(pmmax) ! m*2dt/(a*cos(lat)**2)
- real(r8) zrcsj ! 1./(a*cos(lat)**2)
-! real(r8) dtime ! timestep size [seconds]
- real(r8) ztdtrc ! 2dt/(a*cos(lat)**2) 1dt/..... at nstep=0
- integer lm, mlength ! local Fourier wavenumber index
- ! and number of local indices
- integer k ! level index
-!
-! Set constants
-!
- mlength = numm(iam)
-! dtime = get_step_size()
-
- zrcsj = 1._r8/(cs(irow)*rearth)
- ztdtrc = ztodt*zrcsj
-
-! if (is_first_step()) then
-! ztdtrc = dtime*zrcsj
-! else
-! ztdtrc = 2.0_r8*dtime*zrcsj
-! end if
-!
-! Combine constants with Fourier wavenumber m
-!
- do lm=1,mlength
- zxm(lm) = ztdtrc*xm(locm(lm,iam))
- end do
-!
-! Combine undifferentiated and longitudinal derivative terms for
-! later use in Gaussian quadrature
-!
- do k=1,plev
- do lm=1,mlength
- grt1(2*lm-1,k) = grt1(2*lm-1,k) + zxm(lm)*grut1(2*lm,k)
- grt1(2*lm,k) = grt1(2*lm,k) - zxm(lm)*grut1(2*lm-1,k)
- grd1(2*lm-1,k) = grd1(2*lm-1,k) - zxm(lm)*grfu1(2*lm,k)
- grd1(2*lm,k) = grd1(2*lm,k) + zxm(lm)*grfu1(2*lm-1,k)
- grz1(2*lm-1,k) = grz1(2*lm-1,k) - zxm(lm)*grfv1(2*lm,k)
- grz1(2*lm,k) = grz1(2*lm,k) + zxm(lm)*grfv1(2*lm-1,k)
-!
- grt2(2*lm-1,k) = grt2(2*lm-1,k) + zxm(lm)*grut2(2*lm,k)
- grt2(2*lm,k) = grt2(2*lm,k) - zxm(lm)*grut2(2*lm-1,k)
- grd2(2*lm-1,k) = grd2(2*lm-1,k) - zxm(lm)*grfu2(2*lm,k)
- grd2(2*lm,k) = grd2(2*lm,k) + zxm(lm)*grfu2(2*lm-1,k)
- grz2(2*lm-1,k) = grz2(2*lm-1,k) - zxm(lm)*grfv2(2*lm,k)
- grz2(2*lm,k) = grz2(2*lm,k) + zxm(lm)*grfv2(2*lm-1,k)
- end do
- end do
-
- return
- end subroutine dyn
-
diff --git a/src/dynamics/eul/dyn_comp.F90 b/src/dynamics/eul/dyn_comp.F90
deleted file mode 100644
index bb753fdd33..0000000000
--- a/src/dynamics/eul/dyn_comp.F90
+++ /dev/null
@@ -1,1174 +0,0 @@
-module dyn_comp
-!-----------------------------------------------------------------------
-!
-! Eulerian dycore interface module
-!
-!-----------------------------------------------------------------------
-
-use shr_kind_mod, only: r8=>shr_kind_r8
-
-use spmd_utils, only: masterproc, npes, mpicom, mpir8
-
-use physconst, only: pi
-use pmgrid, only: plon, plat, plev, plevp, plnlv, beglat, endlat
-use commap, only: clat, clon, latdeg
-use dyn_grid, only: ptimelevels
-
-
-use prognostics, only: n3, ps, u3, v3, t3, q3, phis, pdeld, dpsm, dpsl, div, vort
-
-use cam_control_mod, only: initial_run, moist_physics, adiabatic, simple_phys
-use phys_control, only: phys_getopts
-use constituents, only: pcnst, cnst_name, cnst_longname, sflxnam, tendnam, &
- fixcnam, tottnam, hadvnam, vadvnam, cnst_get_ind, &
- cnst_read_iv, qmin
-use cam_initfiles, only: initial_file_get_id, topo_file_get_id, pertlim, scale_dry_air_mass
-use inic_analytic, only: analytic_ic_active, analytic_ic_set_ic
-use dyn_tests_utils, only: vc_moist_pressure
-use cam_history, only: addfld, add_default, horiz_only
-
-use eul_control_mod, only: dif2, hdif_order, kmnhdn, hdif_coef, divdampn, eps, &
- kmxhdc, eul_nsplit
-
-use scamMod, only: single_column, use_camiop, have_u, have_v, &
- have_cldliq, have_cldice, loniop, latiop, scmlat, scmlon, &
- qobs,tobs,scm_cambfb_mode,uobs,vobs,psobs
-
-use cam_pio_utils, only: clean_iodesc_list, cam_pio_get_var
-use pio, only: file_desc_t, pio_noerr, pio_inq_varid, pio_get_att, &
- pio_inq_attlen, pio_inq_dimid, pio_inq_dimlen, &
- pio_get_var,var_desc_t, pio_seterrorhandling, &
- pio_bcast_error, pio_internal_error, pio_offset_kind
-
-#if (defined SPMD)
-use spmd_dyn, only: spmd_readnl
-#endif
-
-use cam_logfile, only: iulog
-use cam_abortutils, only: endrun
-
-implicit none
-private
-save
-
-public :: &
- dyn_import_t, &
- dyn_export_t, &
- dyn_readnl, &
- dyn_register, &
- dyn_init
-
-! these structures are not used in this dycore, but are included
-! for interface compatibility.
-type dyn_import_t
- integer :: placeholder
-end type dyn_import_t
-
-type dyn_export_t
- integer :: placeholder
-end type dyn_export_t
-
-
-real(r8), allocatable :: ps_tmp (:,: )
-real(r8), allocatable :: phis_tmp(:,: )
-real(r8), allocatable :: q3_tmp (:,:,:)
-real(r8), allocatable :: t3_tmp (:,:,:)
-real(r8), allocatable :: arr3d_a (:,:,:)
-real(r8), allocatable :: arr3d_b (:,:,:)
-
-logical readvar ! inquiry flag: true => variable exists on netCDF file
-
-!=========================================================================================
-CONTAINS
-!=========================================================================================
-
-subroutine dyn_readnl(nlfile)
-
- ! Read dynamics namelist group.
- use namelist_utils, only: find_group_name
- use units, only: getunit, freeunit
- use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_real8
-
- ! args
- character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input
-
- ! local vars
- integer :: unitn, ierr
-
- real(r8) :: eul_dif2_coef ! del2 horizontal diffusion coeff.
- integer :: eul_hdif_order ! Order of horizontal diffusion operator
- integer :: eul_hdif_kmnhdn ! Nth order horizontal diffusion operator top level.
- real(r8) :: eul_hdif_coef ! Nth order horizontal diffusion coefficient.
- real(r8) :: eul_divdampn ! Number of days to invoke divergence damper
- real(r8) :: eul_tfilt_eps ! Time filter coefficient. Defaults to 0.06.
- integer :: eul_kmxhdc ! Number of levels to apply Courant limiter
-
- namelist /dyn_eul_inparm/ eul_dif2_coef, eul_hdif_order, eul_hdif_kmnhdn, &
- eul_hdif_coef, eul_divdampn, eul_tfilt_eps, eul_kmxhdc, eul_nsplit
-
- character(len=*), parameter :: sub = 'dyn_readnl'
- !-----------------------------------------------------------------------------
-
- ! Read namelist
- if (masterproc) then
- unitn = getunit()
- open( unitn, file=trim(nlfile), status='old' )
- call find_group_name(unitn, 'dyn_eul_inparm', status=ierr)
- if (ierr == 0) then
- read(unitn, dyn_eul_inparm, iostat=ierr)
- if (ierr /= 0) then
- call endrun(sub//': ERROR reading namelist')
- end if
- end if
- close(unitn)
- call freeunit(unitn)
- end if
-
- call mpi_bcast(eul_dif2_coef, 1, mpi_real8, mstrid, mpicom, ierr)
- if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: eul_dif2_coef")
-
- call mpi_bcast(eul_hdif_order, 1, mpi_integer, mstrid, mpicom, ierr)
- if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: eul_hdif_order")
-
- call mpi_bcast(eul_hdif_kmnhdn, 1, mpi_integer, mstrid, mpicom, ierr)
- if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: eul_hdif_kmnhdn")
-
- call mpi_bcast(eul_hdif_coef, 1, mpi_real8, mstrid, mpicom, ierr)
- if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: eul_hdif_coef")
-
- call mpi_bcast(eul_divdampn, 1, mpi_real8, mstrid, mpicom, ierr)
- if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: eul_divdampn")
-
- call mpi_bcast(eul_tfilt_eps, 1, mpi_real8, mstrid, mpicom, ierr)
- if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: eul_tfilt_eps")
-
- call mpi_bcast(eul_kmxhdc, 1, mpi_integer, mstrid, mpicom, ierr)
- if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: eul_kmxhdc")
-
- call mpi_bcast(eul_nsplit, 1, mpi_integer, mstrid, mpicom, ierr)
- if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: eul_nsplit")
-
- dif2 = eul_dif2_coef
- hdif_order = eul_hdif_order
- kmnhdn = eul_hdif_kmnhdn
- hdif_coef = eul_hdif_coef
- divdampn = eul_divdampn
- eps = eul_tfilt_eps
- kmxhdc = eul_kmxhdc
-
- ! Write namelist variables to logfile
- if (masterproc) then
-
- write(iulog,*) 'Eulerian Dycore Parameters:'
-
-
- ! Order of diffusion
- if (hdif_order < 2 .or. mod(hdif_order, 2) /= 0) then
- write(iulog,*) sub//': Order of diffusion must be greater than 0 and multiple of 2'
- write(iulog,*) 'hdif_order = ', hdif_order
- call endrun(sub//': ERROR: invalid eul_hdif_order specified')
- end if
-
- if (divdampn > 0._r8) then
- write(iulog,*) ' Divergence damper for spectral dycore invoked for days 0. to ',divdampn,' of this case'
- elseif (divdampn < 0._r8) then
- call endrun (sub//': divdampn must be non-negative')
- else
- write(iulog,*) ' Divergence damper for spectral dycore NOT invoked'
- endif
-
- if (kmxhdc >= plev .or. kmxhdc < 0) then
- call endrun (sub//': ERROR: KMXHDC must be between 0 and plev-1')
- end if
-
- write(iulog,9108) eps, hdif_order, kmnhdn, hdif_coef, kmxhdc, eul_nsplit
-
- if (kmnhdn > 1) then
- write(iulog,9109) dif2
- end if
-
- end if
-
-#if (defined SPMD)
- call spmd_readnl(nlfile)
-#endif
-
-9108 format(' Time filter coefficient (EPS) ',f10.3,/,&
- ' Horizontal diffusion order (N) ',i10/, &
- ' Top layer for Nth order horizontal diffusion ',i10/, &
- ' Nth order horizontal diffusion coefficient ',e10.3/, &
- ' Number of levels Courant limiter applied ',i10/, &
- ' Dynamics Subcycling ',i10)
-
-9109 format(' DEL2 horizontal diffusion applied above Nth order diffusion',/,&
- ' DEL2 Horizontal diffusion coefficient (DIF2) ',e10.3)
-
-
-end subroutine dyn_readnl
-
-!=========================================================================================
-
-subroutine dyn_register()
-end subroutine dyn_register
-
-!=========================================================================================
-
-subroutine dyn_init(dyn_in, dyn_out)
-
- use prognostics, only: initialize_prognostics
- use scanslt, only: scanslt_alloc
-
- use scamMod, only: single_column
-#if (defined SPMD)
- use spmd_dyn, only: spmdbuf
-#endif
- use dyn_tests_utils, only: vc_dycore, vc_moist_pressure,string_vc, vc_str_lgth
- ! Arguments are not used in this dycore, included for compatibility
- type(dyn_import_t), intent(out) :: dyn_in
- type(dyn_export_t), intent(out) :: dyn_out
-
- ! Local workspace
- integer :: m
- integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water.
- logical :: history_amwg ! output for AMWG diagnostics
- logical :: history_budget ! output tendencies and state variables for CAM4
- ! temperature, water vapor, cloud ice and cloud
- ! liquid budgets.
- integer :: history_budget_histfile_num ! output history file number for budget fields
- character (len=vc_str_lgth) :: str1
- !----------------------------------------------------------------------------
- vc_dycore = vc_moist_pressure
- if (masterproc) then
- call string_vc(vc_dycore,str1)
- write(iulog,*)'dycore vertical coordinate : ',trim(str1)
- end if
- ! Initialize prognostics variables
- call initialize_prognostics
- call scanslt_alloc()
-
-#if (defined SPMD)
- ! Allocate communication buffers for collective communications in realloc
- ! routines and in dp_coupling. Call must come after phys_grid_init.
- call spmdbuf ()
-#endif
-
- call set_phis()
-
- if (initial_run) then
- call read_inidat()
- call clean_iodesc_list()
- end if
-
- call addfld ('ETADOT',(/ 'ilev' /),'A', '1/s','Vertical (eta) velocity', gridname='gauss_grid')
- call addfld ('U&IC', (/ 'lev' /), 'I', 'm/s','Zonal wind', gridname='gauss_grid' )
- call addfld ('V&IC', (/ 'lev' /), 'I', 'm/s','Meridional wind', gridname='gauss_grid' )
- call add_default ('U&IC',0, 'I')
- call add_default ('V&IC',0, 'I')
-
- call addfld ('PS&IC',horiz_only,'I', 'Pa','Surface pressure', gridname='gauss_grid' )
- call addfld ('T&IC',(/ 'lev' /),'I', 'K','Temperature', gridname='gauss_grid' )
- call add_default ('PS&IC',0, 'I')
- call add_default ('T&IC',0, 'I')
-
- do m = 1, pcnst
- call addfld (trim(cnst_name(m))//'&IC',(/ 'lev' /),'I', 'kg/kg',cnst_longname(m), gridname='gauss_grid' )
- call add_default(trim(cnst_name(m))//'&IC',0, 'I')
- call addfld (hadvnam(m), (/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(m))//' horizontal advection tendency', &
- gridname='gauss_grid')
- call addfld (vadvnam(m), (/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(m))//' vertical advection tendency', &
- gridname='gauss_grid')
- call addfld (tendnam(m), (/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(m))//' total tendency', &
- gridname='gauss_grid')
- call addfld (tottnam(m), (/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(m))//' horz + vert + fixer tendency', &
- gridname='gauss_grid')
- call addfld (fixcnam(m), (/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(m))//' tendency due to slt fixer', &
- gridname='gauss_grid')
- end do
-
- call addfld ('DUH ',(/ 'lev' /),'A', 'K/s ','U horizontal diffusive heating', gridname='gauss_grid')
- call addfld ('DVH ',(/ 'lev' /),'A', 'K/s ','V horizontal diffusive heating', gridname='gauss_grid')
- call addfld ('DTH ',(/ 'lev' /),'A', 'K/s ','T horizontal diffusive heating', gridname='gauss_grid')
-
- call addfld ('ENGYCORR',(/ 'lev' /),'A', 'W/m2 ','Energy correction for over-all conservation', gridname='gauss_grid')
- call addfld ('TFIX ',horiz_only ,'A', 'K/s ','T fixer (T equivalent of Energy correction)', gridname='gauss_grid')
-
- call addfld ('FU ',(/ 'lev' /),'A', 'm/s2 ','Zonal wind forcing term', gridname='gauss_grid')
- call addfld ('FV ',(/ 'lev' /),'A', 'm/s2 ','Meridional wind forcing term', gridname='gauss_grid')
- call addfld ('UTEND ',(/ 'lev' /),'A', 'm/s2 ','U tendency', gridname='gauss_grid')
- call addfld ('VTEND ',(/ 'lev' /),'A', 'm/s2 ','V tendency', gridname='gauss_grid')
- call addfld ('TTEND ',(/ 'lev' /),'A', 'K/s ','T tendency', gridname='gauss_grid')
- call addfld ('LPSTEN ',horiz_only ,'A', 'Pa/s ','Surface pressure tendency', gridname='gauss_grid')
- call addfld ('VAT ',(/ 'lev' /),'A', 'K/s ','Vertical advective tendency of T',gridname='gauss_grid')
- call addfld ('KTOOP ',(/ 'lev' /),'A', 'K/s ','(Kappa*T)*(omega/P)', gridname='gauss_grid')
-
- call phys_getopts(history_amwg_out=history_amwg, &
- history_budget_out = history_budget, &
- history_budget_histfile_num_out = history_budget_histfile_num)
-
- if (history_amwg) then
- call add_default ('DTH ', 1, ' ')
- end if
-
- if ( history_budget ) then
- if (.not.adiabatic) then
- call cnst_get_ind('CLDLIQ', ixcldliq)
- call cnst_get_ind('CLDICE', ixcldice)
- end if
- ! The following variables are not defined for single column
- if (.not. single_column) then
- call add_default(hadvnam( 1), history_budget_histfile_num, ' ')
- call add_default(vadvnam( 1), history_budget_histfile_num, ' ')
- if (.not.adiabatic) then
- call add_default(hadvnam(ixcldliq), history_budget_histfile_num, ' ')
- call add_default(hadvnam(ixcldice), history_budget_histfile_num, ' ')
- call add_default(vadvnam(ixcldliq), history_budget_histfile_num, ' ')
- call add_default(vadvnam(ixcldice), history_budget_histfile_num, ' ')
- end if
- end if
- call add_default(fixcnam( 1), history_budget_histfile_num, ' ')
- call add_default(tottnam( 1), history_budget_histfile_num, ' ')
- call add_default(tendnam( 1), history_budget_histfile_num, ' ')
- if (.not.adiabatic) then
- call add_default(fixcnam(ixcldliq), history_budget_histfile_num, ' ')
- call add_default(fixcnam(ixcldice), history_budget_histfile_num, ' ')
- call add_default(tottnam(ixcldliq), history_budget_histfile_num, ' ')
- call add_default(tottnam(ixcldice), history_budget_histfile_num, ' ')
- call add_default(tendnam(ixcldliq), history_budget_histfile_num, ' ')
- call add_default(tendnam(ixcldice), history_budget_histfile_num, ' ')
- end if
- call add_default('TTEND', history_budget_histfile_num, ' ')
- call add_default('TFIX', history_budget_histfile_num, ' ')
- call add_default('KTOOP', history_budget_histfile_num, ' ')
- call add_default('VAT', history_budget_histfile_num, ' ')
- call add_default('DTH', history_budget_histfile_num, ' ')
- end if
-
-end subroutine dyn_init
-
-!=========================================================================================
-! Private routines
-!=========================================================================================
-
-subroutine read_inidat()
- ! Read initial dataset and spectrally truncate as appropriate.
- ! Read and process the fields one at a time to minimize
- ! memory usage.
-
- use ppgrid, only: begchunk, endchunk, pcols
- use phys_grid, only: clat_p, clon_p
- use comspe, only: alp, dalp
-
- use ncdio_atm, only: infld
-
- use scamMod, only: setiopupdate,setiopupdate_init,readiopdata
- use iop, only: iop_update_prognostics
- use hycoef, only: hyam, hybm, hyai, hybi, ps0
- ! Local variables
-
- integer i,c,m,n,lat ! indices
- integer ncol
- integer ixcldice, ixcldliq ! indices into q3 array for cloud liq and cloud ice
-
- integer :: ierr, pio_errtype
- integer :: lonid, latid
- integer :: mlon, morec ! lon/lat dimension lengths from IC file
-
- type(file_desc_t), pointer :: fh_ini
-
- real(r8), pointer, dimension(:,:,:) :: convptr_2d
- real(r8), pointer, dimension(:,:,:,:) :: convptr_3d
- real(r8), pointer, dimension(:,:,:,:) :: cldptr
- real(r8), pointer, dimension(:,: ) :: arr2d_tmp
- real(r8), pointer, dimension(:,: ) :: arr2d
- character*16 fieldname ! field name
-
- real(r8) :: clat2d(plon,plat),clon2d(plon,plat)
-
- ! variables for analytic initial conditions
- integer, allocatable :: glob_ind(:)
- integer :: m_cnst(1)
- real(r8), allocatable :: q4_tmp(:,:,:,:)
-
- integer londimid,dimlon,latdimid,dimlat,latvarid,lonvarid
- integer strt(3),cnt(3)
- character(len=3), parameter :: arraydims3(3) = (/ 'lon', 'lev', 'lat' /)
- character(len=3), parameter :: arraydims2(2) = (/ 'lon', 'lat' /)
- type(var_desc_t) :: varid
- real(r8), allocatable :: tmp2d(:,:)
-
- character(len=*), parameter :: sub='read_inidat'
- !----------------------------------------------------------------------------
-
- fh_ini => initial_file_get_id()
-
- allocate ( ps_tmp (plon,plat ) )
- allocate ( q3_tmp (plon,plev,plat) )
- allocate ( t3_tmp (plon,plev,plat) )
- allocate ( arr3d_a (plon,plev,plat) )
- allocate ( arr3d_b (plon,plev,plat) )
-
- if (analytic_ic_active()) then
-
- allocate(glob_ind(plon * plat))
- m = 1
- do c = 1, plat
- do i = 1, plon
- ! Create a global column index
- glob_ind(m) = i + (c-1)*plon
- m = m + 1
- end do
- end do
- call analytic_ic_set_ic(vc_moist_pressure, clat(:), clon(:,1), &
- glob_ind(:), U=arr3d_a, V=arr3d_b, T=t3_tmp, PS=ps_tmp, PHIS_IN=phis_tmp)
- readvar = .false.
- call process_inidat('PS')
- call process_inidat('UV')
- call process_inidat('T')
-
- allocate(q4_tmp(plon,plev,plat,1))
- do m = 1, pcnst
- m_cnst(1) = m
- call analytic_ic_set_ic(vc_moist_pressure, clat(:), clon(:,1), &
- glob_ind(:), Q=q4_tmp, m_cnst=m_cnst)
- arr3d_a(:,:,:) = q4_tmp(:,:,:,1)
- call process_inidat('CONSTS', m_cnst=m, fh=fh_ini)
- end do
- deallocate(q4_tmp)
- deallocate(glob_ind)
- deallocate ( arr3d_a )
- deallocate ( arr3d_b )
- else
- !---------------------
- ! Read required fields
- !---------------------
-
- call pio_seterrorhandling(fh_ini, PIO_BCAST_ERROR, pio_errtype)
-
- ierr = pio_inq_dimid(fh_ini, 'lon', lonid)
- ierr = pio_inq_dimid(fh_ini, 'lat', latid)
- ierr = pio_inq_dimlen(fh_ini, lonid, mlon)
- ierr = pio_inq_dimlen(fh_ini, latid, morec)
- if (.not. single_column .and. (mlon /= plon .or. morec /= plat)) then
- write(iulog,*) sub//': ERROR: model parameters do not match initial dataset parameters'
- write(iulog,*)'Model Parameters: plon = ',plon,' plat = ',plat
- write(iulog,*)'Dataset Parameters: dlon = ',mlon,' dlat = ',morec
- call endrun(sub//': ERROR: model parameters do not match initial dataset parameters')
- end if
-
- call pio_seterrorhandling(fh_ini, pio_errtype)
- !-----------
- ! 3-D fields
- !-----------
-
- fieldname = 'U'
- call cam_pio_get_var(fieldname, fh_ini, arraydims3, arr3d_a, found=readvar)
- if (.not. readvar) then
- call endrun(sub//': ERROR: reading '//trim(fieldname))
- end if
-
- fieldname = 'V'
- call cam_pio_get_var(fieldname, fh_ini, arraydims3, arr3d_b, found=readvar)
- if (.not. readvar) then
- call endrun(sub//': ERROR: reading '//trim(fieldname))
- end if
-
- call process_inidat('UV')
-
- fieldname = 'T'
- call cam_pio_get_var(fieldname, fh_ini, arraydims3, t3_tmp, found=readvar)
- if (.not. readvar) then
- call endrun(sub//': ERROR: reading '//trim(fieldname))
- end if
-
- call process_inidat('T')
-
- ! Constituents (read and process one at a time)
-
- do m = 1,pcnst
-
- readvar = .false.
- fieldname = cnst_name(m)
- if (cnst_read_iv(m)) then
- call cam_pio_get_var(fieldname, fh_ini, arraydims3, arr3d_a, found=readvar)
- end if
- call process_inidat('CONSTS', m_cnst=m, fh=fh_ini)
-
- end do
-
- deallocate ( arr3d_a )
- deallocate ( arr3d_b )
-
- !-----------
- ! 2-D fields
- !-----------
-
- fieldname = 'PS'
- call cam_pio_get_var(fieldname, fh_ini, arraydims2, ps_tmp, found=readvar)
- if (.not. readvar) then
- call endrun(sub//': ERROR: reading '//trim(fieldname))
- end if
- call process_inidat('PS')
- end if
-
- if (single_column) then
- ps(:,:,1) = ps_tmp(:,:)
- else
- ! Integrals of mass, moisture and geopotential height
- ! (fix mass of moisture as well)
- call global_int
- end if
-
- ! module data used in global_int
- deallocate ( ps_tmp )
- deallocate ( phis_tmp )
-
- if (single_column) then
- call setiopupdate_init()
- if ( scm_cambfb_mode ) then
-
- fieldname = 'CLAT1'
- call infld(fieldname, fh_ini, 'lon', 'lat', 1, pcols, begchunk, endchunk, &
- clat2d, readvar, gridname='physgrid')
- if (.not. readvar) then
- call endrun('CLAT not on iop initial file')
- else
- clat = clat2d(1,1)
- clat_p(:)=clat2d(1,1)
- latdeg(1) = clat(1)*45._r8/atan(1._r8)
- end if
-
- fieldname = 'CLON1'
- call infld(fieldname, fh_ini, 'lon', 'lat', 1, pcols, begchunk, endchunk, &
- clon2d, readvar, gridname='physgrid')
- if (.not. readvar) then
- call endrun('CLON not on iop initial file')
- else
- clon = clon2d
- clon_p(:)=clon(:,1)
- end if
-
- ! Get latdeg/londeg from initial file for bfb calculations
- ! needed for dyn_grid to determine bounding area and verticies
- ierr = pio_inq_dimid (fh_ini, 'lon' , londimid)
- ierr = pio_inq_dimlen (fh_ini, londimid, dimlon)
- ierr = pio_inq_dimid (fh_ini, 'lat' , latdimid)
- ierr = pio_inq_dimlen (fh_ini, latdimid, dimlat)
- strt(:)=1
- cnt(1)=dimlon
- cnt(2)=dimlat
- cnt(3)=1
- allocate(latiop(dimlat))
- allocate(loniop(dimlon))
- allocate(tmp2d(dimlon,dimlat))
- ierr = pio_inq_varid (fh_ini,'CLAT1', varid)
- ierr = pio_get_var(fh_ini,varid,strt,cnt,tmp2d)
- latiop(:)=tmp2d(1,:)
- ierr = pio_inq_varid (fh_ini,'CLON1', varid)
- ierr = pio_get_var(fh_ini,varid,strt,cnt,tmp2d)
- loniop(:)=tmp2d(:,1)
- deallocate(tmp2d)
- else
-
- ! Using a standard iop - make the default grid size is
- ! 4x4 degree square for mo_drydep deposition.(standard ARM IOP area)
- allocate(latiop(2))
- allocate(loniop(2))
- latiop(1)=(scmlat-2._r8)*pi/180_r8
- latiop(2)=(scmlat+2._r8)*pi/180_r8
- loniop(1)=(mod(scmlon-2.0_r8+360.0_r8,360.0_r8))*pi/180.0_r8
- loniop(2)=(mod(scmlon+2.0_r8+360.0_r8,360.0_r8))*pi/180.0_r8
- call setiopupdate()
- call readiopdata(hyam,hybm,hyai,hybi,ps0)
- call iop_update_prognostics(1,t3=t3,u3=u3,v3=v3,q3=q3,ps=ps)
- end if
- end if
-
- deallocate ( q3_tmp )
- deallocate ( t3_tmp )
-
- if (.not. single_column) then
- deallocate ( alp )
- deallocate ( dalp )
- end if
-
- call copytimelevels()
-
-end subroutine read_inidat
-
-!=========================================================================================
-
-subroutine set_phis()
-
- ! Local variables
- type(file_desc_t), pointer :: fh_topo
-
- integer :: ierr, pio_errtype
- integer :: lonid, latid
- integer :: mlon, morec ! lon/lat dimension lengths from topo file
- character(len=3), parameter :: arraydims2(2) = (/ 'lon', 'lat' /)
-
- character(len=16) :: fieldname
-
- integer :: c, i, m
- integer, allocatable :: glob_ind(:)
-
- character(len=*), parameter :: sub='set_phis'
- !----------------------------------------------------------------------------
-
- fh_topo => topo_file_get_id()
-
- allocate( phis_tmp(plon,plat) )
-
- readvar = .false.
-
- if (associated(fh_topo)) then
-
- call pio_seterrorhandling(fh_topo, PIO_BCAST_ERROR, pio_errtype)
-
- ierr = pio_inq_dimid(fh_topo, 'lon', lonid)
- ierr = pio_inq_dimid(fh_topo, 'lat', latid)
- ierr = pio_inq_dimlen(fh_topo, lonid, mlon)
- ierr = pio_inq_dimlen(fh_topo, latid, morec)
- if (.not. single_column .and. (mlon /= plon .or. morec /= plat)) then
- write(iulog,*) sub//': ERROR: model parameters do not match initial dataset parameters'
- write(iulog,*)'Model Parameters: plon = ',plon,' plat = ',plat
- write(iulog,*)'Dataset Parameters: dlon = ',mlon,' dlat = ',morec
- call endrun(sub//': ERROR: model parameters do not match initial dataset parameters')
- end if
- call pio_seterrorhandling(fh_topo, pio_errtype)
-
- fieldname = 'PHIS'
- call cam_pio_get_var(fieldname, fh_topo, arraydims2, phis_tmp, found=readvar)
- if (.not. readvar) then
- call endrun(sub//': ERROR: reading '//trim(fieldname))
- end if
-
- else if (analytic_ic_active()) then
-
- allocate(glob_ind(plon*plat))
- m = 1
- do c = 1, plat
- do i = 1, plon
- ! Create a global column index
- glob_ind(m) = i + (c-1)*plon
- m = m + 1
- end do
- end do
- call analytic_ic_set_ic(vc_moist_pressure, clat(:), clon(:,1), &
- glob_ind(:), PHIS_OUT=phis_tmp)
-
- deallocate(glob_ind)
-
- else
-
- phis_tmp(:,:) = 0._r8
-
- end if
-
- call process_inidat('PHIS', fh=fh_topo)
-
-end subroutine set_phis
-
-!=========================================================================================
-
-subroutine process_inidat(fieldname, m_cnst, fh)
-
-! Post-process input fields
-
- use commap
- use comspe
- use spetru
- use dyn_grid, only: get_horiz_grid_dim_d
- use const_init, only: cnst_init_default
- use qneg_module, only: qneg3
-
-#if ( defined SPMD )
- use spmd_dyn, only: compute_gsfactors
-#endif
-
- ! arguments
- character(len=*), intent(in) :: fieldname ! fields to be processed
- integer, intent(in), optional :: m_cnst ! constituent index
- type(file_desc_t), intent(inout), optional :: fh ! pio file handle
-
- !---------------------------Local workspace-----------------------------
-
- integer i,j,k,n,lat,irow ! grid and constituent indices
- integer :: nglon, nglat, rndm_seed_sz ! For pertlim
- integer, allocatable :: rndm_seed(:) ! For pertlim
- real(r8) pertval ! perturbation value
- integer varid ! netCDF variable id
- integer ret
- integer(pio_offset_kind) :: attlen ! netcdf return values
- logical phis_hires ! true => PHIS came from hi res topo
- character*256 text
- character*256 trunits ! tracer untis
-
- real(r8), pointer, dimension(:,:,:) :: q_tmp
- real(r8), pointer, dimension(:,:,:) :: tmp3d_a, tmp3d_b, tmp3d_extend
- real(r8), pointer, dimension(:,: ) :: tmp2d_a, tmp2d_b
-
-#if ( defined BFB_CAM_SCAM_IOP )
- real(r8), allocatable :: ps_sav(:,:)
- real(r8), allocatable :: u3_sav(:,:,:)
- real(r8), allocatable :: v3_sav(:,:,:)
-#endif
-
-#if ( defined SPMD )
- integer :: numperlat ! number of values per latitude band
- integer :: numsend(0:npes-1) ! number of items to be sent
- integer :: numrecv ! number of items to be received
- integer :: displs(0:npes-1) ! displacement array
-#endif
- character(len=*), parameter :: sub='process_inidat'
- !----------------------------------------------------------------------------
-
- select case (fieldname)
-
- !------------
- ! Process U/V
- !------------
-
- case ('UV')
-
- allocate ( tmp3d_a(plon,plev,plat) )
- allocate ( tmp3d_b(plon,plev,plat) )
-
- ! Spectral truncation
-
- if (single_column) then
- tmp3d_a(:,:,:) = 0._r8
- tmp3d_b(:,:,:) = 0._r8
- else
-#if (( defined BFB_CAM_SCAM_IOP ) && ( ! defined DO_SPETRU ))
- allocate ( u3_sav (plon,plev,plat) )
- allocate ( v3_sav (plon,plev,plat) )
- u3_sav(:plon,:plev,:plat) = arr3d_a(:plon,:plev,:plat)
- v3_sav(:plon,:plev,:plat) = arr3d_b(:plon,:plev,:plat)
- call spetru_uv(u3_sav ,v3_sav ,vort=tmp3d_a, div=tmp3d_b)
- deallocate ( u3_sav )
- deallocate ( v3_sav )
-#else
- call spetru_uv(arr3d_a ,arr3d_b ,vort=tmp3d_a, div=tmp3d_b)
-#endif
- end if
-
-#if ( defined SPMD )
- numperlat = plnlv
- call compute_gsfactors (numperlat, numrecv, numsend, displs)
-
- call mpiscatterv (arr3d_a ,numsend, displs, mpir8,u3 (:,:,beglat:endlat,1) ,numrecv, mpir8,0,mpicom)
- call mpiscatterv (arr3d_b ,numsend, displs, mpir8,v3 (:,:,beglat:endlat,1) ,numrecv, mpir8,0,mpicom)
- call mpiscatterv (tmp3d_a ,numsend, displs, mpir8,vort(:,:,beglat:endlat,1) ,numrecv, mpir8,0,mpicom)
- call mpiscatterv (tmp3d_b ,numsend, displs, mpir8,div (:,:,beglat:endlat,1) ,numrecv, mpir8,0,mpicom)
-#else
- u3 (:,:,:,1) = arr3d_a(:plon,:plev,:plat)
- v3 (:,:,:,1) = arr3d_b(:plon,:plev,:plat)
- vort (:,:,:,1) = tmp3d_a(:,:,:)
- div (:,:,:,1) = tmp3d_b(:,:,:)
-#endif
- deallocate ( tmp3d_a )
- deallocate ( tmp3d_b )
-
- !----------
- ! Process T
- !----------
-
- case ('T')
-
- ! Add random perturbation to temperature if required
-
- if (pertlim .ne. 0.0_r8) then
- if (masterproc) write(iulog,*) sub//': INFO: Adding random perturbation bounded by +/-', &
- pertlim,' to initial temperature field'
-
- call get_horiz_grid_dim_d(nglon, nglat)
- call random_seed(size=rndm_seed_sz)
- allocate(rndm_seed(rndm_seed_sz))
-
- do lat = 1, plat
- do i = 1, plon
- ! seed random_number generator based on global column index
- rndm_seed = i + (lat-1)*nglon
- call random_seed(put=rndm_seed)
- do k = 1, plev
- call random_number (pertval)
- pertval = 2._r8*pertlim*(0.5_r8 - pertval)
- t3_tmp(i,k,lat) = t3_tmp(i,k,lat)*(1._r8 + pertval)
- end do
- end do
- end do
- deallocate(rndm_seed)
- end if
-
- ! Spectral truncation
-
- if (.not. single_column) then
-#if ( ( ! defined BFB_CAM_SCAM_IOP ) || ( defined DO_SPETRU ) )
- call spetru_3d_scalar(t3_tmp)
-#endif
- end if
-
-#if ( defined SPMD )
- numperlat = plnlv
- call compute_gsfactors (numperlat, numrecv, numsend, displs)
- call mpiscatterv (t3_tmp ,numsend, displs, mpir8,t3(:,:,beglat:endlat,1) ,numrecv, mpir8,0,mpicom)
-#else
- t3 (:,:,:,1) = t3_tmp(:plon,:plev,:plat)
-#endif
-
- !---------------------
- ! Process Constituents
- !---------------------
-
- case ('CONSTS')
-
- if (.not. present(m_cnst)) then
- call endrun(sub//': ERROR: m_cnst needs to be present in the'// &
- ' argument list')
- end if
-
- allocate(tmp3d_extend(plon,plev,beglat:endlat))
-
- if (readvar) then
- ! Check that all tracer units are in mass mixing ratios
- ret = pio_inq_varid(fh, cnst_name(m_cnst), varid)
- ret = pio_get_att(fh, varid, 'units', trunits)
- if (trunits(1:5) .ne. 'KG/KG' .and. trunits(1:5) .ne. 'kg/kg') then
- call endrun(sub//': ERROR: Units for tracer ' &
- //trim(cnst_name(m_cnst))//' must be in KG/KG')
- end if
-
- else if (.not. analytic_ic_active()) then
-
- ! Constituents not read from initial file are initialized by the
- ! package that implements them. Note that the analytic IC code calls
- ! cnst_init_default internally
-
- if (m_cnst == 1 .and. moist_physics) then
- call endrun(sub//': ERROR: Q must be on Initial File')
- end if
-
- call cnst_init_default(m_cnst, clat, clon(:,1), arr3d_a)
- end if
-
-!$omp parallel do private(lat)
- do lat = 1,plat
- call qneg3(sub, lat, plon, plon, plev , &
- m_cnst, m_cnst, qmin(m_cnst) ,arr3d_a(1,1,lat))
- end do
-
- ! if "Q", "CLDLIQ", or "CLDICE", save off for later use
- if (m_cnst == 1) q3_tmp(:plon,:,:) = arr3d_a(:plon,:,:)
-
-#if ( defined SPMD )
- numperlat = plnlv
- call compute_gsfactors(numperlat, numrecv, numsend, displs)
- call mpiscatterv(arr3d_a, numsend, displs, mpir8, tmp3d_extend, numrecv, mpir8,0,mpicom)
- q3(:,:,m_cnst,:,1) = tmp3d_extend(:,:,beglat:endlat)
-#else
- q3(:,:plev,m_cnst,:,1) = arr3d_a(:plon,:plev,:plat)
-#endif
- deallocate ( tmp3d_extend )
-
- !-----------
- ! Process PS
- !-----------
-
- case ('PS')
-
- allocate ( tmp2d_a(plon,plat) )
- allocate ( tmp2d_b(plon,plat) )
-
- ! Spectral truncation
-
- if (single_column) then
- tmp2d_a(:,:) = 0._r8
- tmp2d_b(:,:) = 0._r8
- else
-#if (( defined BFB_CAM_SCAM_IOP ) && ( ! defined DO_SPETRU ))
- allocate ( ps_sav(plon,plat) )
- ps_sav(:plon,:plat)=ps_tmp(:plon,:plat)
- call spetru_ps(ps_sav, tmp2d_a, tmp2d_b)
- deallocate ( ps_sav )
-#else
- call spetru_ps(ps_tmp, tmp2d_a, tmp2d_b)
-#endif
- end if
-
-#if ( defined SPMD )
- numperlat = plon
- call compute_gsfactors (numperlat, numrecv, numsend, displs)
- call mpiscatterv (tmp2d_a ,numsend, displs, mpir8,dpsl ,numrecv, mpir8,0,mpicom)
- call mpiscatterv (tmp2d_b ,numsend, displs, mpir8,dpsm ,numrecv, mpir8,0,mpicom)
-#else
- dpsl(:,:) = tmp2d_a(:,:)
- dpsm(:,:) = tmp2d_b(:,:)
-#endif
- deallocate ( tmp2d_a )
- deallocate ( tmp2d_b )
-
- !-------------
- ! Process PHIS
- !-------------
-
- case ('PHIS')
-
- ! Check for presence of 'from_hires' attribute to decide whether to filter
- if (readvar) then
- ret = pio_inq_varid (fh, 'PHIS', varid)
- ! Allow pio to return errors in case from_hires doesn't exist
- call pio_seterrorhandling(fh, PIO_BCAST_ERROR)
- ret = pio_inq_attlen (fh, varid, 'from_hires', attlen)
- if (ret.eq.PIO_NOERR .and. attlen.gt.256) then
- call endrun(sub//': ERROR: from_hires attribute length is too long')
- end if
- ret = pio_get_att(fh, varid, 'from_hires', text)
-
- if (ret.eq.PIO_NOERR .and. text(1:4).eq.'true') then
- phis_hires = .true.
- if(masterproc) write(iulog,*) sub//': INFO: Will filter input PHIS: attribute from_hires is true'
- else
- phis_hires = .false.
- if(masterproc) write(iulog,*) sub//': INFO: Will not filter input PHIS: attribute ', &
- 'from_hires is either false or not present'
- end if
- call pio_seterrorhandling(fh, PIO_INTERNAL_ERROR)
-
- else
- phis_hires = .false.
-
- end if
-
- ! Spectral truncation
-
- if (.not. single_column) then
-#if (( ! defined BFB_CAM_SCAM_IOP ) || ( defined DO_SPETRU ))
- call spetru_phis(phis_tmp, phis_hires)
-#endif
- end if
-
-#if ( defined SPMD )
- numperlat = plon
- call compute_gsfactors (numperlat, numrecv, numsend, displs)
- call mpiscatterv (phis_tmp ,numsend, displs, mpir8,phis ,numrecv, mpir8,0,mpicom)
-#else
- phis = phis_tmp
-#endif
-
- end select
-
-end subroutine process_inidat
-
-!=========================================================================================
-
-subroutine global_int()
-
- ! Compute global integrals of mass, moisture and geopotential height
- ! and fix mass of atmosphere
-
- use commap
- use physconst, only: gravit
-#if ( defined SPMD )
- use mpishorthand
- use spmd_dyn, only: compute_gsfactors
- use spmd_utils, only: npes
-#endif
- use hycoef, only: hyai, ps0
- use eul_control_mod, only: pdela, qmass1, tmassf, fixmas, &
- tmass0, zgsint, qmass2, qmassf
- use inic_analytic, only: analytic_ic_active
-
- !---------------------------Local workspace-----------------------------
-
- integer i,k,lat,ihem,irow ! grid indices
- real(r8) pdelb(plon,plev) ! pressure diff between interfaces
- ! using "B" part of hybrid grid only
- real(r8) pssum ! surface pressure sum
- real(r8) dotproda ! dot product
- real(r8) dotprodb ! dot product
- real(r8) zgssum ! partial sums of phis
- real(r8) hyad (plev) ! del (A)
- real(r8) tmassf_tmp ! Global mass integral
- real(r8) qmass1_tmp ! Partial Global moisture mass integral
- real(r8) qmass2_tmp ! Partial Global moisture mass integral
- real(r8) qmassf_tmp ! Global moisture mass integral
- real(r8) zgsint_tmp ! Geopotential integral
-
- integer platov2 ! plat/2 or plat (if in scm mode)
-#if ( defined SPMD )
- integer :: numperlat ! number of values per latitude band
- integer :: numsend(0:npes-1) ! number of items to be sent
- integer :: numrecv ! number of items to be received
- integer :: displs(0:npes-1) ! displacement array
-#endif
-
- type(file_desc_t), pointer :: fh_topo
-
- character(len=*), parameter :: sub='global_int'
- !-----------------------------------------------------------------------
-
- fh_topo => topo_file_get_id()
-
- if (masterproc) then
-
- ! Initialize mass and moisture integrals for summation
- ! in a third calculation loop (assures bit-for-bit compare
- ! with non-random history tape).
-
- tmassf_tmp = 0._r8
- qmass1_tmp = 0._r8
- qmass2_tmp = 0._r8
- zgsint_tmp = 0._r8
-
- ! Compute pdel from "A" portion of hybrid vertical grid for later use in global integrals
- do k = 1,plev
- hyad(k) = hyai(k+1) - hyai(k)
- end do
- do k = 1,plev
- do i = 1,plon
- pdela(i,k) = hyad(k)*ps0
- end do
- end do
-
- ! Compute integrals of mass, moisture, and geopotential height
- if (single_column) then
- platov2 = 1
- else
- platov2 = plat/2
- endif
- do irow = 1,platov2
- do ihem = 1,2
- if (ihem.eq.1) then
- lat = irow
- else
- lat = plat - irow + 1
- end if
-
- ! Accumulate average mass of atmosphere
- call pdelb0 (ps_tmp(1,lat), pdelb, plon)
- pssum = 0._r8
- do i = 1, plon
- pssum = pssum + ps_tmp (i,lat)
- end do
- tmassf_tmp = tmassf_tmp + w(irow)*pssum/plon
-
- zgssum = 0._r8
- do i = 1, plon
- zgssum = zgssum + phis_tmp(i,lat)
- end do
- zgsint_tmp = zgsint_tmp + w(irow)*zgssum/plon
-
- ! Calculate global integrals needed for water vapor adjustment
- do k = 1,plev
- dotproda = 0._r8
- dotprodb = 0._r8
- do i = 1, plon
- dotproda = dotproda + q3_tmp(i,k,lat)*pdela(i,k)
- dotprodb = dotprodb + q3_tmp(i,k,lat)*pdelb(i,k)
- end do
- qmass1_tmp = qmass1_tmp + w(irow)*dotproda/plon
- qmass2_tmp = qmass2_tmp + w(irow)*dotprodb/plon
- end do
- end do
- end do ! end of latitude loop
-
- ! Normalize average mass, height
- tmassf_tmp = tmassf_tmp*.5_r8/gravit
- qmass1_tmp = qmass1_tmp*.5_r8/gravit
- qmass2_tmp = qmass2_tmp*.5_r8/gravit
- zgsint_tmp = zgsint_tmp*.5_r8/gravit
- qmassf_tmp = qmass1_tmp + qmass2_tmp
-
- if (simple_phys) then
- tmass0 = tmassf_tmp - qmassf_tmp
- else
- ! Globally avgd sfc. partial pressure of dry air (i.e. global dry mass):
- tmass0 = scale_dry_air_mass/gravit
- end if
-
- if (masterproc) then
- write(iulog,*) sub//': INFO:'
- write(iulog,*) ' Mass of initial data before correction = ', tmassf_tmp
- write(iulog,*) ' Dry mass will be held at = ', tmass0
- write(iulog,*) ' Mass of moisture after removal of negatives = ', qmassf_tmp
- write(iulog,*) ' Globally averaged geopotential height (m) = ', zgsint_tmp
- end if
-
- if (simple_phys) then
- fixmas = 1._r8
- else
- ! Compute and apply an initial mass fix factor which preserves horizontal
- ! gradients of ln(ps).
- fixmas = (tmass0 + qmass1_tmp)/(tmassf_tmp - qmass2_tmp)
- ps_tmp = ps_tmp*fixmas
- end if
-
- ! Global integerals
- tmassf = tmassf_tmp
- qmass1 = qmass1_tmp
- qmass2 = qmass2_tmp
- qmassf = qmassf_tmp
- zgsint = zgsint_tmp
-
- end if ! end of if-masterproc
-
-#if ( defined SPMD )
- call mpibcast (tmass0,1,mpir8,0,mpicom)
- call mpibcast (tmassf,1,mpir8,0,mpicom)
- call mpibcast (qmass1,1,mpir8,0,mpicom)
- call mpibcast (qmass2,1,mpir8,0,mpicom)
- call mpibcast (qmassf,1,mpir8,0,mpicom)
- call mpibcast (zgsint,1,mpir8,0,mpicom)
-
- numperlat = plon
- call compute_gsfactors(numperlat, numrecv, numsend, displs)
- call mpiscatterv(ps_tmp, numsend, displs, mpir8, ps(:,beglat:endlat,1), numrecv, &
- mpir8, 0, mpicom)
-#else
- ps(:,:,1) = ps_tmp(:,:)
-#endif
-
-end subroutine global_int
-
-!=========================================================================================
-
-subroutine copytimelevels()
-
- !---------------------------Local variables-----------------------------
-
- integer n,i,k,lat ! index
- real(r8) pdel(plon,plev) ! pressure arrays needed to calculate
- real(r8) pint(plon,plevp) ! pdeld
- real(r8) pmid(plon,plev) !
-
- ! If dry-type tracers are present, initialize pdeld
- ! First, set current time pressure arrays for model levels etc. to get pdel
- do lat = beglat, endlat
- call plevs0(plon, plon, plev, ps(:,lat,1), pint, pmid, pdel)
- do k = 1, plev
- do i = 1, plon
- pdeld(i,k,lat,1) = pdel(i,k)*(1._r8-q3(i,k,1,lat,1))
- end do
- end do
- end do
-
- ! Make all time levels of prognostics contain identical data.
- ! Fields to be convectively adjusted only *require* n3 time
- ! level since copy gets done in linems.
- do n = 2, ptimelevels
- ps(:,:,n) = ps(:,:,1)
- u3(:,:,:,n) = u3(:,:,:,1)
- v3(:,:,:,n) = v3(:,:,:,1)
- t3(:,:,:,n) = t3(:,:,:,1)
- q3(1:plon,:,:,:,n) = q3(1:plon,:,:,:,1)
- vort(:,:,:,n) = vort(:,:,:,1)
- div(:,:,:,n) = div(:,:,:,1)
- pdeld(1:plon,:,:,n) = pdeld(1:plon,:,:,1)
- end do
-
-end subroutine copytimelevels
-
-!=========================================================================================
-
-end module dyn_comp
diff --git a/src/dynamics/eul/dyn_grid.F90 b/src/dynamics/eul/dyn_grid.F90
deleted file mode 100644
index 62d3d73f0c..0000000000
--- a/src/dynamics/eul/dyn_grid.F90
+++ /dev/null
@@ -1,1199 +0,0 @@
-module dyn_grid
-!-----------------------------------------------------------------------
-!
-! Define grid and decomposition for Eulerian spectral dynamics.
-!
-! Original code: John Drake and Patrick Worley
-!
-!-----------------------------------------------------------------------
-
-use shr_kind_mod, only: r8 => shr_kind_r8
-use pmgrid, only: plat, plev, plon, plevp
-use physconst, only: rair, rearth, ra
-use spmd_utils, only: masterproc, iam
-
-use pio, only: file_desc_t
-use cam_initfiles, only: initial_file_get_id
-
-use cam_abortutils, only: endrun
-use cam_logfile, only: iulog
-use shr_const_mod, only: SHR_CONST_PI, SHR_CONST_REARTH
-
-#if (defined SPMD)
-use spmd_dyn, only: spmdinit_dyn
-#endif
-
-implicit none
-private
-save
-
-public :: &
- dyn_grid_init, &
- dyn_grid_find_gcols, &! find nearest column for given lat/lon
- dyn_grid_get_colndx, &! global lat and lon coordinate and MPI process indices
- ! corresponding to a specified global column index
- dyn_grid_get_elem_coords, &! coordinates of a specified element (latitude)
- ! of the dynamics grid (lat slice of the block)
- get_block_bounds_d, &! first and last indices in global block ordering
- get_block_gcol_d, &! global column indices for given block
- get_block_gcol_cnt_d, &! number of columns in given block
- get_block_levels_d, &! vertical levels in column
- get_block_lvl_cnt_d, &! number of vertical levels in column
- get_block_owner_d, &! process "owning" given block
- get_dyn_grid_parm, &
- get_dyn_grid_parm_real1d, &
- get_gcol_block_d, &! global block indices and local columns
- ! index for given global column index
- get_gcol_block_cnt_d, &! number of blocks containing data
- ! from a given global column index
- get_horiz_grid_d, &! horizontal grid coordinates
- get_horiz_grid_dim_d, &! horizontal dimensions of dynamics grid
- physgrid_copy_attributes_d
-
-! The Eulerian dynamics grids
-integer, parameter, public :: dyn_decomp = 101
-
-integer, parameter, public :: ptimelevels = 3 ! number of time levels in the dycore
-
-real(r8), parameter :: rad2deg = 180._r8/SHR_CONST_PI
-
-integer :: ngcols_d = 0 ! number of dynamics columns
-
-!========================================================================================
-contains
-!========================================================================================
-
-subroutine dyn_grid_init
-
- ! Initialize dynamics grid
-
- use pspect, only: ptrm, ptrn, ptrk, pnmax, pmmax, pspt
- use comspe, only: lpspt, numm, locm, lnstart, nstart, nlen, &
- alp, dalp, lalp, ldalp
- use scanslt, only: nlonex, platd, j1
- use gauaw_mod, only: gauaw
- use commap, only: sq, rsq, slat, w, cs, href, ecref, clat, clon, &
- latdeg, londeg, xm
- use time_manager, only: get_step_size
- use scamMod, only: scmlat, scmlon, single_column
- use hycoef, only: hycoef_init, hypi, hypm, hypd, nprlev, hyam,hybm,hyai,hybi,ps0
- use ref_pres, only: ref_pres_init
- use eul_control_mod, only: ifax, trig, eul_nsplit
-
- ! Local variables
- type(file_desc_t), pointer :: fh_ini
-
- real(r8) zsi(plat) ! sine of latitudes
- real(r8) zw(plat) ! Gaussian weights
- real(r8) zra2 ! ra squared
- real(r8) zalp(2*pspt) ! Legendre function array
- real(r8) zdalp(2*pspt) ! Derivative array
- real(r8) zslat ! sin of lat and cosine of colatitude
-
- integer i ! longitude index
- integer j ! Latitude index
- integer k ! Level index
- integer kk ! Level index
- integer kkk ! Level index
- integer m,lm,mr,lmr ! Indices for legendre array
- integer n ! Index for legendre array
- integer nkk ! Print control variables
- integer ik1 ! Print index temporary variable
- integer ik2 ! Print index temporary variable
- integer itmp ! Dimension of polynomial arrays temporary.
- integer iter ! Iteration index
- real(r8) :: zdt ! Time step for settau
-
- integer :: irow ! Latitude pair index
- integer :: lat ! Latitude index
-
- real(r8) :: xlat ! Latitude (radians)
- real(r8) :: pi ! Mathematical pi (3.14...)
- real(r8) :: dtime ! timestep size [seconds]
-
- character(len=*), parameter :: sub='dyn_grid_init'
- !-----------------------------------------------------------------------
-
- ! File handle for initial file. Needed for vertical coordinate data.
- fh_ini => initial_file_get_id()
-
- ! Compute truncation parameters
- call trunc()
-
-#if (defined SPMD)
- call spmdinit_dyn()
-#endif
-
- ! Initialize hybrid coordinate arrays
- call hycoef_init(fh_ini)
-
- ! Initialize reference pressures
- call ref_pres_init(hypi, hypm, nprlev)
-
-
- dtime = get_step_size()
- zdt = dtime/eul_nsplit
-
- ! Initialize horizontal diffusion coefficients
- call hdinti(rearth, zdt)
-
- if (.not. single_column) then
-
- if (pmmax > plon/2) then
- call endrun (sub//': ERROR: mmax=ptrm+1 .gt. plon/2')
- end if
- end if
-
- ! NMAX dependent arrays
- zra2 = ra*ra
- do j = 2, pnmax
- sq(j) = j*(j-1)*zra2
- rsq(j) = 1._r8/sq(j)
- end do
- sq(1) = 0._r8
- rsq(1) = 0._r8
-
- ! MMAX dependent arrays
- do j = 1, pmmax
- xm(j) = j-1
- end do
-
- ! Integration matrices of hydrostatic equation(href) and conversion
- ! term(a). href computed as in ccm0 but isothermal bottom ecref
- ! calculated to conserve energy
-
- do k = 1, plev
- do kk = 1, plev
- href(kk,k) = 0._r8
- ecref(kk,k) = 0._r8
- end do
- end do
-
- ! Mean atmosphere energy conversion term is consistent with continiuty
- ! Eq. In ecref, 1st index = column; 2nd index = row of matrix.
- ! Mean atmosphere energy conversion term is energy conserving
-
- do k = 1, plev
- ecref(k,k) = 0.5_r8/hypm(k) * hypd(k)
- do kk = 1, k-1
- ecref(kk,k) = 1._r8/hypm(k) * hypd(kk)
- end do
- end do
-
- ! Reference hydrostatic integration matrix consistent with conversion
- ! term for energy conservation. In href, 1st index = column;
- ! 2nd index = row of matrix.
-
- do k = 1, plev
- do kk = k, plev
- href(kk,k) = ecref(k,kk)*hypd(kk)/hypd(k)
- end do
- end do
-
- href = href*rair
-
- if (single_column) then
-
- do j = 1, plat
- slat(j) = 1.0_r8 * sin(4.0_r8*atan(1.0_r8)*scmlat/180._r8)
- w(j) = 2.0_r8/plat
- cs(j) = 10._r8 - slat(j)*slat(j)
- end do
-
- xlat = asin(slat(1))
- clat(1) = xlat
-
- clat(1)=scmlat*atan(1._r8)/45._r8
- latdeg(1) = clat(1)*45._r8/atan(1._r8)
- clon(1,1) = 4.0_r8*atan(1._r8)*mod((scmlon+360._r8),360._r8)/180._r8
- londeg(1,1) = mod((scmlon+360._r8),360._r8)
-
- else
-
- ! Gaussian latitude dependent arrays
- call gauaw(zsi, zw, plat)
- do irow = 1, plat/2
- slat(irow) = zsi(irow)
- w(irow) = zw(irow)
- w(plat-irow+1) = zw(irow)
- cs(irow) = 1._r8 - zsi(irow)*zsi(irow)
- xlat = asin(slat(irow))
- clat(irow) = -xlat
- clat(plat-irow+1) = xlat
- end do
-
- do lat = 1, plat
- latdeg(lat) = clat(lat)*45._r8/atan(1._r8)
- end do
-
- ! Compute constants related to Legendre transforms
- ! Compute and reorder ALP and DALP
-
- allocate(alp(pspt,plat/2))
- allocate(dalp(pspt,plat/2))
-
- do j = 1, plat/2
- zslat = slat(j)
- itmp = 2*pspt - 1
- call phcs(zalp, zdalp, itmp, zslat)
- call reordp(j, itmp, zalp, zdalp)
- end do
-
- ! Copy and save local ALP and DALP
-
- allocate(lalp(lpspt,plat/2))
- allocate(ldalp(lpspt,plat/2))
-
- do j = 1, plat/2
- do lm = 1, numm(iam)
- m = locm(lm,iam)
- mr = nstart(m)
- lmr = lnstart(lm)
- do n = 1, nlen(m)
- lalp(lmr+n,j) = alp(mr+n,j)
- ldalp(lmr+n,j) = dalp(mr+n,j)
- end do
- end do
- end do
-
- ! Mirror latitudes south of south pole
-
- lat = 1
- do j = j1-2, 1, -1
- nlonex(j) = plon
- lat = lat + 1
- end do
- nlonex(j1-1) = plon ! south pole
-
- ! Real latitudes
-
- j = j1
- do lat = 1, plat
- nlonex(j) = plon
- j = j + 1
- end do
- nlonex(j1+plat) = plon ! north pole
-
- ! Mirror latitudes north of north pole
-
- lat = plat
- do j = j1+plat+1, platd
- nlonex(j) = plon
- lat = lat - 1
- end do
-
- ! Longitude array
-
- pi = 4.0_r8*atan(1.0_r8)
- do lat = 1, plat
- do i = 1, plon
- londeg(i,lat) = (i-1)*360._r8/plon
- clon(i,lat) = (i-1)*2.0_r8*pi/plon
- end do
- end do
-
- ! Set up trigonometric tables for fft
-
- do j = 1, plat
- call set99(trig(1,j), ifax(1,j), plon)
- end do
- end if
-
- ! Define the CAM grids (must be before addfld calls)
- call define_cam_grids()
-
- if (masterproc) then
- write(iulog,*) ' '
- write(iulog,*) 'EULERIAN dycore -- Done grid and decomposition initialization'
- write(iulog,*) ' Truncation Parameters: M =',ptrm,' N =',ptrn,' K =',ptrk
- write(iulog,*) ' zdt, dtime=', zdt, dtime
- write(iulog,*) ' '
- end if
-
-end subroutine dyn_grid_init
-
-!========================================================================================
-
- subroutine get_block_bounds_d(block_first,block_last)
-
-!-----------------------------------------------------------------------
-!
-!
-! Purpose: Return first and last indices used in global block ordering
-!
-! Method:
-!
-! Author: Patrick Worley
-!
-!-----------------------------------------------------------------------
- use pmgrid, only: plat
-
- implicit none
-!------------------------------Arguments--------------------------------
- integer, intent(out) :: block_first ! first (global) index used for blocks
- integer, intent(out) :: block_last ! last (global) index used for blocks
-
-!-----------------------------------------------------------------------
-! latitude slice block
- block_first = 1
- block_last = plat
-
- return
- end subroutine get_block_bounds_d
-
-!
-!========================================================================
-!
- subroutine get_block_gcol_d(blockid,size,cdex)
-
-!-----------------------------------------------------------------------
-!
-!
-! Purpose: Return list of dynamics column indices in given block
-!
-! Method:
-!
-! Author: Patrick Worley
-!
-!-----------------------------------------------------------------------
- use pmgrid, only: plat, plon
-
- implicit none
-!------------------------------Arguments--------------------------------
- integer, intent(in) :: blockid ! global block id
- integer, intent(in) :: size ! array size
-
- integer, intent(out):: cdex(size) ! global column indices
-!---------------------------Local workspace-----------------------------
-!
- integer i,j ! loop indices
- integer n ! column index
-!-----------------------------------------------------------------------
-! block == latitude slice
- if (size < plon) then
- write(iulog,*)'GET_BLOCK_GCOL_D: array not large enough (', &
- size,' < ',plon,' ) '
- call endrun
- else
- n = (blockid-1)*plon
- do i = 1,plon
- n = n + 1
- cdex(i) = n
- end do
- end if
-!
- return
- end subroutine get_block_gcol_d
-!
-!========================================================================
-!
- integer function get_block_gcol_cnt_d(blockid)
-
-!-----------------------------------------------------------------------
-!
-!
-! Purpose: Return number of dynamics columns in indicated block
-!
-! Method:
-!
-! Author: Patrick Worley
-!
-!-----------------------------------------------------------------------
- use pmgrid, only: plon
-
- implicit none
-!------------------------------Arguments--------------------------------
- integer, intent(in) :: blockid ! global block id
-
-!-----------------------------------------------------------------------
-! latitude slice block
- get_block_gcol_cnt_d = plon
-
- return
- end function get_block_gcol_cnt_d
-
-!
-!========================================================================
-!
- integer function get_block_lvl_cnt_d(blockid,bcid)
-
-!-----------------------------------------------------------------------
-!
-!
-! Purpose: Return number of levels in indicated column. If column
-! includes surface fields, then it is defined to also
-! include level 0.
-!
-! Method:
-!
-! Author: Patrick Worley
-!
-!-----------------------------------------------------------------------
-
- implicit none
-!------------------------------Arguments--------------------------------
- integer, intent(in) :: blockid ! global block id
- integer, intent(in) :: bcid ! column index within block
-
-!-----------------------------------------------------------------------
-! latitude slice block
- get_block_lvl_cnt_d = plev + 1
-
- return
- end function get_block_lvl_cnt_d
-!
-!========================================================================
-!
- subroutine get_block_levels_d(blockid, bcid, lvlsiz, levels)
-
-!-----------------------------------------------------------------------
-!
-!
-! Purpose: Return level indices in indicated column. If column
-! includes surface fields, then it is defined to also
-! include level 0.
-!
-! Method:
-!
-! Author: Patrick Worley
-!
-!-----------------------------------------------------------------------
-
- implicit none
-!------------------------------Arguments--------------------------------
- integer, intent(in) :: blockid ! global block id
- integer, intent(in) :: bcid ! column index within block
- integer, intent(in) :: lvlsiz ! dimension of levels array
-
- integer, intent(out) :: levels(lvlsiz) ! levels indices for block
-
-!---------------------------Local workspace-----------------------------
-!
- integer k ! loop index
-!-----------------------------------------------------------------------
-! latitude slice block
- if (lvlsiz < plev + 1) then
- write(iulog,*)'GET_BLOCK_LEVELS_D: levels array not large enough (', &
- lvlsiz,' < ',plev + 1,' ) '
- call endrun
- else
- do k=0,plev
- levels(k+1) = k
- end do
- do k=plev+2,lvlsiz
- levels(k) = -1
- end do
- end if
-
- return
- end subroutine get_block_levels_d
-
-!
-!========================================================================
-!
- subroutine get_gcol_block_d(gcol,cnt,blockid,bcid,localblockid)
-
-!-----------------------------------------------------------------------
-!
-!
-! Purpose: Return global block index and local column index
-! for global column index
-!
-! Method:
-!
-! Author: Patrick Worley
-!
-!-----------------------------------------------------------------------
- use pmgrid, only: plat, plon
-
- implicit none
-!------------------------------Arguments--------------------------------
- integer, intent(in) :: gcol ! global column index
- integer, intent(in) :: cnt ! size of blockid and bcid arrays
-
- integer, intent(out) :: blockid(cnt) ! block index
- integer, intent(out) :: bcid(cnt) ! column index within block
- integer, intent(out), optional :: localblockid(cnt)
-!---------------------------Local workspace-----------------------------
-!
- integer jb ! loop index
-!-----------------------------------------------------------------------
-! latitude slice block
- if (cnt < 1) then
- write(iulog,*)'GET_GCOL_BLOCK_D: arrays not large enough (', &
- cnt,' < ',1,' ) '
- call endrun
- else
- blockid(1) = (gcol-1)/plon + 1
- bcid(1) = gcol - (blockid(1)-1)*plon
- do jb=2,cnt
- blockid(jb) = -1
- bcid(jb) = -1
- end do
- end if
-!
- return
- end subroutine get_gcol_block_d
-!
-!========================================================================
-!
- integer function get_gcol_block_cnt_d(gcol)
-
-!-----------------------------------------------------------------------
-!
-!
-! Purpose: Return number of blocks contain data for the vertical column
-! with the given global column index
-!
-! Method:
-!
-! Author: Patrick Worley
-!
-!-----------------------------------------------------------------------
-
- implicit none
-!------------------------------Arguments--------------------------------
- integer, intent(in) :: gcol ! global column index
-!-----------------------------------------------------------------------
-! latitude slice block
- get_gcol_block_cnt_d = 1
-
- return
- end function get_gcol_block_cnt_d
-!
-!========================================================================
-!
- integer function get_block_owner_d(blockid)
-
-!-----------------------------------------------------------------------
-!
-!
-! Purpose: Return id of processor that "owns" the indicated block
-!
-! Method:
-!
-! Author: Patrick Worley
-!
-!-----------------------------------------------------------------------
-#if ( defined SPMD )
- use spmd_dyn, only: proc
-#endif
-
- implicit none
-!------------------------------Arguments--------------------------------
- integer, intent(in) :: blockid ! global block id
-
-!-----------------------------------------------------------------------
-! latitude slice block
-#if (defined SPMD)
- get_block_owner_d = proc(blockid)
-#else
- get_block_owner_d = 0
-#endif
-
- return
- end function get_block_owner_d
-!
-!========================================================================
-!
- subroutine get_horiz_grid_dim_d(hdim1_d,hdim2_d)
-
-!-----------------------------------------------------------------------
-!
-!
-! Purpose: Returns declared horizontal dimensions of computational grid.
-! Note that global column ordering is assumed to be compatible
-! with the first dimension major ordering of the 2D array.
-!
-! Method:
-!
-! Author: Patrick Worley
-!
-!-----------------------------------------------------------------------
- use pmgrid, only: plat, plon
-
-!------------------------------Arguments--------------------------------
- integer, intent(out) :: hdim1_d ! first horizontal dimension
- integer, intent(out) :: hdim2_d ! second horizontal dimension
-!-----------------------------------------------------------------------
- if (ngcols_d == 0) then
- ngcols_d = plat*plon
- end if
- hdim1_d = plon
- hdim2_d = plat
-
- return
- end subroutine get_horiz_grid_dim_d
-!
-!========================================================================
-!
- subroutine get_horiz_grid_d(size,clat_d_out,clon_d_out,area_d_out, &
- wght_d_out,lat_d_out,lon_d_out)
-
-!-----------------------------------------------------------------------
-!
-!
-! Purpose: Return latitude and longitude (in radians), column surface
-! area (in radians squared) and surface integration weights
-! for global column indices that will be passed to/from physics
-!
-! Method:
-!
-! Author: Patrick Worley
-!
-!-----------------------------------------------------------------------
- use pmgrid, only: plat, plon
- use commap, only: clat, clon, londeg, latdeg, w
- use physconst, only: pi, spval
- implicit none
-!------------------------------Arguments--------------------------------
- integer, intent(in) :: size ! array sizes
-
- real(r8), intent(out), optional :: clat_d_out(size) ! column latitudes
- real(r8), intent(out), optional :: clon_d_out(size) ! column longitudes
- real(r8), intent(out), optional :: area_d_out(size) ! column surface
- ! area
- real(r8), intent(out), optional :: wght_d_out(size) ! column integration
- ! weight
- real(r8), intent(out), optional :: lat_d_out(size) ! column deg latitudes
- real(r8), intent(out), optional :: lon_d_out(size) ! column deg longitudes
-!---------------------------Local workspace-----------------------------
-!
- integer i,j ! loop indices
- integer n ! column index
- real(r8) :: ns_vert(2,plon) ! latitude grid vertices
- real(r8) :: ew_vert(2,plon) ! longitude grid vertices
- real(r8) :: del_theta ! difference in latitude at a grid point
- real(r8) :: del_phi ! difference in longitude at a grid point
- real(r8), parameter :: degtorad=pi/180_r8
-!-----------------------------------------------------------------------
- if(present(clon_d_out)) then
- if(size == ngcols_d) then
- n = 0
- do j = 1,plat
- do i = 1, plon
- n = n + 1
- clon_d_out(n) = clon(i,j)
- end do
- end do
- else if(size == plon) then
- clon_d_out(:) = clon(:,1)
- else
- write(iulog,*)'GET_HORIZ_GRID_D: arrays not large enough (', &
- size,' < ',ngcols_d,' ) '
- call endrun
- end if
- end if
- if(present(clat_d_out)) then
- if(size == ngcols_d) then
- n = 0
- do j = 1,plat
- do i = 1, plon
- n = n + 1
- clat_d_out(n) = clat(j)
- end do
- end do
- else if(size == plat) then
- clat_d_out(:) = clat(:)
- else
- write(iulog,*)'GET_HORIZ_GRID_D: arrays not large enough (', &
- size,' < ',ngcols_d,' ) '
- call endrun
- end if
- end if
- if ( ( present(wght_d_out) ) ) then
-
- if(size==plat) then
- wght_d_out(:) = (0.5_r8*w(:)/plon)* (4.0_r8*pi)
- else if(size == ngcols_d) then
- n = 0
- do j = 1,plat
- do i = 1, plon
- n = n + 1
- wght_d_out(n) = ( 0.5_r8*w(j)/plon ) * (4.0_r8*pi)
- end do
- end do
- end if
- end if
- if ( present(area_d_out) ) then
- if(size < ngcols_d) then
- write(iulog,*)'GET_HORIZ_GRID_D: arrays not large enough (', &
- size,' < ',ngcols_d,' ) '
- call endrun
- end if
- n = 0
- do j = 1,plat
-
- ! First, determine vertices of each grid point.
- ! Verticies are ordered as follows:
- ! ns_vert: 1=lower left, 2 = upper left
- ! ew_vert: 1=lower left, 2 = lower right
-
- ! Latitude vertices
- ns_vert(:,:) = spval
- if (j .eq. 1) then
- ns_vert(1,:plon) = -90.0_r8
- else
- ns_vert(1,:plon) = (latdeg(j) + latdeg(j-1) )*0.5_r8
- end if
-
- if (j .eq. plat) then
- ns_vert(2,:plon) = 90.0_r8
- else
- ns_vert(2,:plon) = (latdeg(j) + latdeg(j+1) )*0.5_r8
- end if
-
- ! Longitude vertices
- ew_vert(:,:) = spval
- ew_vert(1,1) = (londeg(1,j) - 360.0_r8 + londeg(plon,j))*0.5_r8
- ew_vert(1,2:plon) = (londeg(1:plon-1,j)+ londeg(2:plon,j))*0.5_r8
- ew_vert(2,:plon-1) = ew_vert(1,2:plon)
- ew_vert(2,plon) = (londeg(plon,j) + (360.0_r8 + londeg(1,j)))*0.5_r8
-
- do i = 1, plon
- n = n + 1
- del_phi = sin( ns_vert(2,i)*degtorad ) - sin( ns_vert(1,i)*degtorad )
- del_theta = ( ew_vert(2,i) - ew_vert(1,i) )*degtorad
- area_d_out(n) = del_theta*del_phi
- end do
-
- end do
- end if
- if(present(lon_d_out)) then
- if(size == ngcols_d) then
- n = 0
- do j = 1,plat
- do i = 1, plon
- n = n + 1
- lon_d_out(n) = londeg(i,j)
- end do
- end do
- else if(size == plon) then
- lon_d_out(:) = londeg(:,1)
- else
- write(iulog,*)'GET_HORIZ_GRID_D: arrays not large enough (', &
- size,' < ',ngcols_d,' ) '
- call endrun
- end if
- end if
- if(present(lat_d_out)) then
- if(size == ngcols_d) then
- n = 0
- do j = 1,plat
- do i = 1, plon
- n = n + 1
- lat_d_out(n) = latdeg(j)
- end do
- end do
- else if(size == plat) then
- lat_d_out(:) = latdeg(:)
- else
- write(iulog,*)'GET_HORIZ_GRID_D: arrays not large enough (', &
- size,' < ',ngcols_d,' ) '
- call endrun
- end if
- end if
-!
- return
- end subroutine get_horiz_grid_d
-
-
-!#######################################################################
- function get_dyn_grid_parm_real2d(name) result(rval)
- use commap, only : londeg, clon
- character(len=*), intent(in) :: name
- real(r8), pointer :: rval(:,:)
-
- if(name.eq.'clon') then
- rval => clon
- else if(name.eq.'londeg') then
- rval => londeg
- else
- nullify(rval)
- end if
- end function get_dyn_grid_parm_real2d
-
-!#######################################################################
- function get_dyn_grid_parm_real1d(name) result(rval)
- use commap, only : latdeg, clat, w
- character(len=*), intent(in) :: name
- real(r8), pointer :: rval(:)
-
- if(name.eq.'clat') then
- rval => clat
- else if(name.eq.'latdeg') then
- rval => latdeg
- else if(name.eq.'w') then
- rval => w
- else
- nullify(rval)
- end if
- end function get_dyn_grid_parm_real1d
-
-
-
-
- integer function get_dyn_grid_parm(name) result(ival)
- use pmgrid, only : beglat, endlat, plat, plon, plev, plevp
- character(len=*), intent(in) :: name
-
- if(name.eq.'beglat' .or. name .eq. 'beglatxy') then
- ival = beglat
- else if(name.eq.'endlat' .or. name .eq. 'endlatxy') then
- ival = endlat
- else if(name.eq.'plat') then
- ival = plat
- else if(name.eq.'plon' .or. name .eq. 'endlonxy') then
- ival = plon
- else if(name.eq.'plev') then
- ival = plev
- else if(name.eq.'plevp') then
- ival = plevp
- else if(name .eq. 'beglonxy') then
- ival = 1
- else
- ival = -1
- end if
-
-
- end function get_dyn_grid_parm
-
-!#######################################################################
-
-!-------------------------------------------------------------------------------
-! This returns the lat/lon information (and corresponding MPI task numbers (owners))
-! of the global model grid columns nearest to the input satellite coordinate (lat,lon)
-!-------------------------------------------------------------------------------
-subroutine dyn_grid_find_gcols( lat, lon, nclosest, owners, indx, jndx, rlat, rlon, idyn_dists )
- use spmd_utils, only: iam
- use pmgrid, only: plon, plat
-
- real(r8), intent(in) :: lat
- real(r8), intent(in) :: lon
- integer, intent(in) :: nclosest
- integer, intent(out) :: owners(nclosest)
- integer, intent(out) :: indx(nclosest)
- integer, intent(out) :: jndx(nclosest)
-
- real(r8),optional, intent(out) :: rlon(nclosest)
- real(r8),optional, intent(out) :: rlat(nclosest)
- real(r8),optional, intent(out) :: idyn_dists(nclosest)
-
- real(r8) :: dist ! the distance (in radians**2 from lat, lon)
- real(r8) :: latr, lonr ! lat, lon inputs converted to radians
- integer :: ngcols
- integer :: i, j
-
- integer :: blockid(1), bcid(1), lclblockid(1)
-
- real(r8), allocatable :: clat_d(:), clon_d(:), distmin(:)
- integer, allocatable :: igcol(:)
-
- latr = lat/rad2deg
- lonr = lon/rad2deg
-
- ngcols = plon*plat
- allocate( clat_d(1:ngcols) )
- allocate( clon_d(1:ngcols) )
- allocate( igcol(nclosest) )
- allocate( distmin(nclosest) )
-
- call get_horiz_grid_d(ngcols, clat_d_out=clat_d, clon_d_out=clon_d)
-
- igcol(:) = -999
- distmin(:) = 1.e10_r8
-
- do i = 1,ngcols
-
- ! Use the Spherical Law of Cosines to find the great-circle distance.
- dist = acos(sin(latr) * sin(clat_d(i)) + cos(latr) * cos(clat_d(i)) * cos(clon_d(i) - lonr)) * SHR_CONST_REARTH
- do j = nclosest, 1, -1
- if (dist < distmin(j)) then
-
- if (j < nclosest) then
- distmin(j+1) = distmin(j)
- igcol(j+1) = igcol(j)
- end if
-
- distmin(j) = dist
- igcol(j) = i
- else
- exit
- end if
- end do
-
- end do
-
- do i = 1,nclosest
-
- call get_gcol_block_d( igcol(i), 1, blockid, bcid, lclblockid )
- owners(i) = get_block_owner_d(blockid(1))
-
- if ( iam==owners(i) ) then
- ! get global lat and lon coordinate indices from global column index
- ! -- plon is global number of longitude grid points
- jndx(i) = (igcol(i)-1)/plon + 1
- indx(i) = igcol(i) - (jndx(i)-1)*plon
- else
- jndx(i) = -1
- indx(i) = -1
- end if
-
- if ( present(rlat) ) rlat(i) = clat_d(igcol(i)) * rad2deg
- if ( present(rlon) ) rlon(i) = clon_d(igcol(i)) * rad2deg
-
- if (present(idyn_dists)) then
- idyn_dists(i) = distmin(i)
- end if
-
- end do
-
- deallocate( clat_d )
- deallocate( clon_d )
- deallocate( igcol )
- deallocate( distmin )
-
-end subroutine dyn_grid_find_gcols
-
-!#######################################################################
-subroutine dyn_grid_get_colndx( igcol, nclosest, owners, indx, jndx )
- use spmd_utils, only: iam
- use pmgrid, only: plon
-
- integer, intent(in) :: nclosest
- integer, intent(in) :: igcol(nclosest)
- integer, intent(out) :: owners(nclosest)
- integer, intent(out) :: indx(nclosest)
- integer, intent(out) :: jndx(nclosest)
-
- integer :: i
- integer :: blockid(1), bcid(1), lclblockid(1)
-
- do i = 1,nclosest
-
- call get_gcol_block_d( igcol(i), 1, blockid, bcid, lclblockid )
- owners(i) = get_block_owner_d(blockid(1))
-
- if ( iam==owners(i) ) then
- ! get global lat and lon coordinate indices from global column index
- ! -- plon is global number of longitude grid points
- jndx(i) = (igcol(i)-1)/plon + 1
- indx(i) = igcol(i) - (jndx(i)-1)*plon
- else
- jndx(i) = -1
- indx(i) = -1
- endif
-
- end do
-
-end subroutine dyn_grid_get_colndx
-!#######################################################################
-
-! this returns coordinates of a latitude slice of the block corresponding
-! to latitude index latndx
-
-subroutine dyn_grid_get_elem_coords( latndx, rlon, rlat, cdex )
- use commap, only : clat, clon
- use pmgrid, only : plon
-
- integer, intent(in) :: latndx ! lat index
-
- real(r8),optional, intent(out) :: rlon(:) ! longitudes of the columns in the latndx slice
- real(r8),optional, intent(out) :: rlat(:) ! latitudes of the columns in the latndx slice
- integer, optional, intent(out) :: cdex(:) ! global column index
-
- integer :: i,ii,j
-
- if (present(cdex)) cdex(:) = -1
- if (present(rlat)) rlat(:) = -999._r8
- if (present(rlon)) rlon(:) = -999._r8
-
- j = latndx
- ii=0
- do i = 1,plon
- ii = ii+1
- if (present(cdex)) cdex(ii) = i + (j-1)*plon
- if (present(rlat)) rlat(ii) = clat(j)
- if (present(rlon)) rlon(ii) = clon(i,1)
- end do
-
-end subroutine dyn_grid_get_elem_coords
-
-!#######################################################################
-
-subroutine physgrid_copy_attributes_d(gridname, grid_attribute_names)
- use cam_grid_support, only: max_hcoordname_len
-
- ! Dummy arguments
- character(len=max_hcoordname_len), intent(out) :: gridname
- character(len=max_hcoordname_len), pointer, intent(out) :: grid_attribute_names(:)
-
- gridname = 'gauss_grid'
- allocate(grid_attribute_names(4))
- grid_attribute_names(1) = 'gw'
- grid_attribute_names(2) = 'ntrm'
- grid_attribute_names(3) = 'ntrn'
- grid_attribute_names(4) = 'ntrk'
-
-end subroutine physgrid_copy_attributes_d
-
-!========================================================================================
-! Private Methods
-!========================================================================================
-
-
-subroutine trunc()
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Check consistency of truncation parameters and evaluate pointers
-! and displacements for spectral arrays
-!
-! Method:
-!
-! Author:
-! Original version: CCM1
-! Standardized: L. Bath, June 1992
-! T. Acker, March 1996
-! Reviewed: J. Hack, D. Williamson, August 1992
-! Reviewed: J. Hack, D. Williamson, April 1996
-!-----------------------------------------------------------------------
-
- use pspect, only: ptrm, ptrn, ptrk, pmmax
- use comspe, only: nstart, nlen, locm, lnstart
-
-!---------------------------Local variables-----------------------------
-!
- integer m ! loop index
-!
-!-----------------------------------------------------------------------
-!
-! trunc first evaluates truncation parameters for a general pentagonal
-! truncation for which the following parameter relationships are true
-!
-! 0 .le. |m| .le. ptrm
-!
-! |m| .le. n .le. |m|+ptrn for |m| .le. ptrk-ptrn
-!
-! |m| .le. n .le. ptrk for (ptrk-ptrn) .le. |m| .le. ptrm
-!
-! Most commonly utilized truncations include:
-! 1: triangular truncation for which ptrk=ptrm=ptrn
-! 2: rhomboidal truncation for which ptrk=ptrm+ptrn
-! 3: trapezoidal truncation for which ptrn=ptrk .gt. ptrm
-!
-! Simple sanity check
-! It is necessary that ptrm .ge. ptrk-ptrn .ge. 0
-!
- if (ptrm.lt.(ptrk-ptrn)) then
- call endrun ('TRUNC: Error in truncation parameters. ntrm < (ptrk-ptrn)')
- end if
- if (ptrk.lt.ptrn) then
- call endrun ('TRUNC: Error in truncation parameters. ptrk < ptrn')
- end if
-!
-! Evaluate pointers and displacement info based on truncation params
-!
- nstart(1) = 0
- nlen(1) = ptrn + 1
- do m=2,pmmax
- nstart(m) = nstart(m-1) + nlen(m-1)
- nlen(m) = min0(ptrn+1,ptrk+2-m)
- end do
-!
-! Assign wavenumbers and spectral offsets if not SPMD
-!
-#if ( ! defined SPMD )
- do m=1,pmmax
- locm(m,0) = m
- lnstart(m) = nstart(m)
- enddo
-#endif
-
-end subroutine trunc
-
-!========================================================================================
-
-subroutine define_cam_grids()
- use pspect, only: ptrm, ptrn, ptrk
- use pmgrid, only: beglat, endlat, plon, plat
- use commap, only: londeg, latdeg, w
- use cam_grid_support, only: horiz_coord_t, horiz_coord_create, iMap
- use cam_grid_support, only: cam_grid_register, cam_grid_attribute_register
-
- ! Local variables
- integer :: i, j, ind
- integer(iMap), pointer :: grid_map(:,:)
- integer(iMap) :: latmap(endlat - beglat + 1)
- type(horiz_coord_t), pointer :: lat_coord
- type(horiz_coord_t), pointer :: lon_coord
- real(r8), pointer :: rattval(:)
-
- nullify(grid_map)
- nullify(lat_coord)
- nullify(lon_coord)
- nullify(rattval)
-
- ! Dynamics Grid
- ! Make grid and lat maps (need to do this because lat indices are distributed)
- ! Note that for this dycore, some pes may be inactive
- if(endlat >= beglat) then
- allocate(grid_map(4, (plon * (endlat - beglat + 1))))
- ind = 0
- do i = beglat, endlat
- do j = 1, plon
- ind = ind + 1
- grid_map(1, ind) = j
- grid_map(2, ind) = i
- grid_map(3, ind) = j
- grid_map(4, ind) = i
- end do
- end do
- ! Do we need a lat map?
- if ((beglat /= 1) .or. (endlat /= plat)) then
- do i = beglat, endlat
- latmap(i - beglat + 1) = i
- end do
- end if
- else
- allocate(grid_map(4, 0))
- end if
-
- ! Create the lat coordinate
- if ((beglat /= 1) .or. (endlat /= plat)) then
- lat_coord => horiz_coord_create('lat', '', plat, 'latitude', &
- 'degrees_north', beglat, endlat, latdeg(beglat:endlat), map=latmap)
- else
- lat_coord => horiz_coord_create('lat', '', plat, 'latitude', &
- 'degrees_north', beglat, endlat, latdeg(beglat:endlat))
- end if
-
- ! Create the lon coordinate
- lon_coord => horiz_coord_create('lon', '', plon, 'longitude', &
- 'degrees_east', 1, plon, londeg(1:plon, 1))
-
- call cam_grid_register('gauss_grid', dyn_decomp, lat_coord, lon_coord, &
- grid_map, unstruct=.false.)
-
- allocate(rattval(size(w)))
- rattval = w
- call cam_grid_attribute_register('gauss_grid', 'gw', 'gauss weights', 'lat', rattval)
- nullify(rattval) ! belongs to attribute
-
- ! Scalar variable 'attributes'
- call cam_grid_attribute_register('gauss_grid', 'ntrm', &
- 'spectral truncation parameter M', ptrm)
- call cam_grid_attribute_register('gauss_grid', 'ntrn', &
- 'spectral truncation parameter N', ptrn)
- call cam_grid_attribute_register('gauss_grid', 'ntrk', &
- 'spectral truncation parameter K', ptrk)
- ! These belong to the grid now
- nullify(grid_map)
- nullify(lat_coord)
- nullify(lon_coord)
-
-end subroutine define_cam_grids
-
-!========================================================================================
-
-end module dyn_grid
diff --git a/src/dynamics/eul/dyndrv.F90 b/src/dynamics/eul/dyndrv.F90
deleted file mode 100644
index b3afd7adc6..0000000000
--- a/src/dynamics/eul/dyndrv.F90
+++ /dev/null
@@ -1,142 +0,0 @@
-subroutine dyndrv(grlps1, grt1, grz1, grd1, grfu1, &
- grfv1, grut1, grvt1, grrh1, grlps2, &
- grt2, grz2, grd2, grfu2, grfv2, &
- grut2, grvt2, grrh2, vmax2d, vmax2dt, &
- vcour, ztodt )
-!-----------------------------------------------------------------------
-!
-! Driving routine for Gaussian quadrature, semi-implicit equation
-! solution and linear part of horizontal diffusion.
-! The need for this interface routine is to have a multitasking
-! driver for the spectral space routines it invokes.
-!
-!---------------------------Code history--------------------------------
-!
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, B. Boville, J. Hack, August 1992
-! Reviewed: D. Williamson, March 1996
-! Modified: P. Worley, September 2002
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use comspe
- use commap
-! use time_manager, only: get_step_size, is_first_step
- use spmd_utils, only: iam
- use perf_mod
-
- implicit none
-
-!
-! Input arguments
-!
- real(r8), intent(in) :: grlps1(2*maxm,(plat+1)/2) ! ----------------------------
- real(r8), intent(inout) :: grt1(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(inout) :: grz1(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(inout) :: grd1(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(in) :: grfu1(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(in) :: grfv1(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(in) :: grut1(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(in) :: grvt1(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(in) :: grrh1(2*maxm,plev,(plat+1)/2) ! |- see linems and quad for
- real(r8), intent(in) :: grlps2(2*maxm,(plat+1)/2) ! | definitions: these variables are
- real(r8), intent(inout) :: grt2(2*maxm,plev,(plat+1)/2) ! | declared here for data scoping
- real(r8), intent(inout) :: grz2(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(inout) :: grd2(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(in) :: grfu2(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(in) :: grfv2(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(in) :: grut2(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(in) :: grvt2(2*maxm,plev,(plat+1)/2) ! |
- real(r8), intent(in) :: grrh2(2*maxm,plev,(plat+1)/2) ! ----------------------------
- real(r8), intent(inout) :: vmax2d(plev,plat) ! max. wind at each level, latitude
- real(r8), intent(inout) :: vmax2dt(plev,plat) ! max. truncated wind at each lvl,lat
- real(r8), intent(inout) :: vcour(plev,plat) ! maximum Courant number in slice
- real(r8), intent(in) :: ztodt
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) ztdtsq(pnmax) ! 2dt*(n(n+1)/a^2)
- real(r8) zdt ! dt unless nstep = 0
- real(r8) ztdt ! 2*zdt (2dt)
- integer irow ! latitude pair index
- integer lm ! local longitudinal wavenumber index
- integer n ! total wavenumber index
- integer k ! level index
-
- call t_startf('dyn')
-
-!$OMP PARALLEL DO PRIVATE (IROW)
- do irow=1,plat/2
- call dyn(irow, grlps1(:,irow), grt1(:,:,irow), &
- grz1(:,:,irow), grd1(:,:,irow), &
- grfu1(:,:,irow), grfv1(:,:,irow), &
- grut1(:,:,irow), grvt1(:,:,irow), &
- grrh1(:,:,irow), &
- grlps2(:,irow), grt2(:,:,irow), &
- grz2(:,:,irow), grd2(:,:,irow), &
- grfu2(:,:,irow), &
- grfv2(:,:,irow), grut2(:,:,irow), &
- grvt2(:,:,irow), grrh2(:,:,irow),ztodt )
- end do
-
- call t_stopf('dyn')
-!
-!-----------------------------------------------------------------------
-!
-! Build vector with del^2 response function
-!
-
- ztdt = ztodt
- zdt = ztdt/2
-! zdt = get_step_size()
-! if (is_first_step()) zdt = .5_r8*zdt
-! ztdt = 2._r8*zdt
-
-
- do n=1,pnmax
- ztdtsq(n) = ztdt*sq(n)
- end do
-
- call t_startf ('quad-tstep')
-
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE(LM)
-#endif
- do lm=1,numm(iam)
-!
-! Perform Gaussian quadrature
-!
- call quad(lm, zdt, ztdtsq, grlps1, grlps2, &
- grt1, grz1, grd1, grfu1, grfv1, &
- grvt1, grrh1, grt2, grz2, grd2, &
- grfu2, grfv2, grvt2, grrh2 )
-!
-! Complete time advance, solve vertically coupled semi-implicit system
-!
- call tstep(lm,zdt,ztdtsq)
- end do
- call t_stopf ('quad-tstep')
-!
-! Find out if courant limit has been exceeded. If so, the limiter will be
-! applied in HORDIF
-!
- call t_startf('courlim')
- call courlim(vmax2d, vmax2dt, vcour )
- call t_stopf('courlim')
-!
-! Linear part of horizontal diffusion
-!
- call t_startf('hordif')
-
-!$OMP PARALLEL DO PRIVATE(K)
- do k=1,plev
- call hordif(k,ztdt)
- end do
-
- call t_stopf('hordif')
-
- return
-end subroutine dyndrv
diff --git a/src/dynamics/eul/dynpkg.F90 b/src/dynamics/eul/dynpkg.F90
deleted file mode 100644
index 0d3a2810f7..0000000000
--- a/src/dynamics/eul/dynpkg.F90
+++ /dev/null
@@ -1,151 +0,0 @@
-
-subroutine dynpkg (adv_state, t2 ,fu ,fv ,etamid , &
- cwava ,detam ,flx_net ,ztodt )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Driving routines for dynamics and transport.
-!
-! Method:
-!
-! Author:
-! Original version: CCM3
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plat, plev, plevp, beglat, endlat
- use pspect
- use comspe
- use scanslt, only: scanslt_run, plond, platd, advection_state
- use scan2, only: scan2run
- use scamMod, only: single_column,scm_crm_mode,switch,wfldh
- use iop, only: t2sav,fusav,fvsav
- use perf_mod
- use cam_history, only: write_camiop
-!-----------------------------------------------------------------------
- implicit none
-
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- type(advection_state), intent(inout) :: adv_state ! Advection state data
- real(r8), intent(inout) :: t2(plon,plev,beglat:endlat) ! temp tendency
- real(r8), intent(inout) :: fu(plon,plev,beglat:endlat) ! u wind tendency
- real(r8), intent(inout) :: fv(plon,plev,beglat:endlat) ! v wind tendency
-
- real(r8), intent(in) :: etamid(plev) ! vertical coords at midpoints
- real(r8), intent(inout) :: cwava(plat) ! weight applied to global integrals
- real(r8), intent(inout) :: detam(plev) ! intervals between vert full levs.
- real(r8), intent(in) :: flx_net(plon,beglat:endlat) ! net flux from physics
- real(r8), intent(in) :: ztodt ! twice time step unless nstep=0
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) etadot(plon,plevp,beglat:endlat) ! Vertical motion (slt)
-!
-! Fourier coefficient arrays which have a latitude index on them for
-! multitasking. These arrays are defined in LINEMSAC and used in QUAD
-! to compute spectral coefficients. They contain a latitude index so
-! that the sums over latitude can be performed in a specified order.
-!
- real(r8) grlps1(2*maxm,plat/2) ! ------------------------------
- real(r8) grlps2(2*maxm,plat/2) ! |
- real(r8) grt1(2*maxm,plev,plat/2) ! |
- real(r8) grt2(2*maxm,plev,plat/2) ! |
- real(r8) grz1(2*maxm,plev,plat/2) ! |
- real(r8) grz2(2*maxm,plev,plat/2) ! |
- real(r8) grd1(2*maxm,plev,plat/2) ! |
- real(r8) grd2(2*maxm,plev,plat/2) ! |
- real(r8) grfu1(2*maxm,plev,plat/2) ! |- see quad for definitions
- real(r8) grfu2(2*maxm,plev,plat/2) ! |
- real(r8) grfv1(2*maxm,plev,plat/2) ! |
- real(r8) grfv2(2*maxm,plev,plat/2) ! |
- real(r8) grut1(2*maxm,plev,plat/2) ! |
- real(r8) grut2(2*maxm,plev,plat/2) ! |
- real(r8) grvt1(2*maxm,plev,plat/2) ! |
- real(r8) grvt2(2*maxm,plev,plat/2) ! |
- real(r8) grrh1(2*maxm,plev,plat/2) ! |
- real(r8) grrh2(2*maxm,plev,plat/2) ! ------------------------------
- real(r8) :: vcour(plev,plat) ! maximum Courant number in slice
- real(r8) :: vmax2d(plev,plat) ! max. wind at each level, latitude
- real(r8) :: vmax2dt(plev,plat) ! max. truncated wind at each lvl,lat
- integer c
-
- call settau(ztodt/2)
- if(single_column.and.scm_crm_mode) return
-!----------------------------------------------------------
-! SCANDYN Dynamics scan
-!----------------------------------------------------------
-!
-if (write_camiop) then
- do c=beglat,endlat
- t2sav(:plon,:,c)= t2(:plon,:,c)
- fusav(:plon,:,c)= fu(:plon,:,c)
- fvsav(:plon,:,c)= fv(:plon,:,c)
- enddo
-end if
-
-if ( single_column ) then
- etadot(1,:,1)=wfldh(:)
-else
- call t_startf('scandyn')
- call scandyn(ztodt ,etadot ,etamid ,grlps1 ,grt1 , &
- grz1 ,grd1 ,grfu1 ,grfv1 ,grut1 , &
- grvt1 ,grrh1 ,grlps2 ,grt2 ,grz2 , &
- grd2 ,grfu2 ,grfv2 ,grut2 ,grvt2 , &
- grrh2 ,vcour ,vmax2d, vmax2dt ,detam , &
- cwava ,flx_net ,t2 ,fu ,fv )
- call t_stopf('scandyn')
-endif
-!
-!----------------------------------------------------------
-! SLT scan from south to north
-!----------------------------------------------------------
-!
- call t_startf('sltrun')
- call scanslt_run(adv_state, ztodt ,etadot , detam, etamid, cwava )
- call t_stopf('sltrun')
-
- if ( single_column ) then
- call scan2run (ztodt, cwava, etamid ,t2 ,fu ,fv )
- else
-!
-!----------------------------------------------------------
-! Accumulate spectral coefficients
-!----------------------------------------------------------
-!
- call t_startf('dynpkg_alloc')
- allocate( vz (2*lpspt,plev) )
- allocate( d (2*lpspt,plev) )
- allocate( t (2*lpspt,plev) )
- allocate( alps(2*lpspt) )
- call t_stopf('dynpkg_alloc')
-
- call t_startf('dyndrv')
- call dyndrv(grlps1 ,grt1 ,grz1 ,grd1 ,grfu1 , &
- grfv1 ,grut1 ,grvt1 ,grrh1 ,grlps2 , &
- grt2 ,grz2 ,grd2 ,grfu2 ,grfv2 , &
- grut2 ,grvt2 ,grrh2 ,vmax2d ,vmax2dt , &
- vcour, ztodt )
- call t_stopf('dyndrv')
-!
-!----------------------------------------------------------
-! Second gaussian scan (spectral -> grid)
-!----------------------------------------------------------
-!
- call t_startf('scan2')
- call scan2run (ztodt, cwava, etamid)
- call t_stopf('scan2')
-
- call t_startf('dynpkg_dealloc')
- deallocate( vz )
- deallocate( d )
- deallocate( t )
- deallocate( alps )
- call t_stopf('dynpkg_dealloc')
-endif
-
- return
-end subroutine dynpkg
diff --git a/src/dynamics/eul/eul_control_mod.F90 b/src/dynamics/eul/eul_control_mod.F90
deleted file mode 100644
index d484ba33b8..0000000000
--- a/src/dynamics/eul/eul_control_mod.F90
+++ /dev/null
@@ -1,55 +0,0 @@
-module eul_control_mod
-
-! Eulerian dynamics shared data
-
-use shr_kind_mod, only: r8=>shr_kind_r8
-use pmgrid, only: plat, plon, plev
-use spmd_utils, only: masterproc
-use pspect, only: pnmax
-
-implicit none
-private
-save
-
-real(r8) ,public :: tmass(plat) ! Mass integral for each latitude pair
-real(r8) ,public :: tmass0 ! Specified dry mass of atmosphere
-real(r8) ,public :: tmassf ! Global mass integral
-real(r8) ,public :: qmassf ! Global moisture integral
-real(r8) ,public :: fixmas ! Proportionality factor for ps in dry mass fixer
-real(r8) ,public :: qmass1 ! Contribution to global moisture integral (mass
- ! weighting is based upon the "A" part of the hybrid grid)
-real(r8) ,public :: qmass2 ! Contribution to global moisture integral (mass
- ! weighting is based upon the "B" part of the hybrid grid)
-real(r8) ,public :: pdela(plon,plev)! pressure difference between interfaces (pressure
- ! defined using the "A" part of hybrid grid only)
-real(r8) ,public :: zgsint ! global integral of geopotential height
-
-integer ,public :: pcray ! length of vector register (words) for FFT workspace
-parameter (pcray=64)
-
-real(r8) ,public :: trig (3*plon/2+1,plat) ! trigonometric funct values used by fft
-integer ,public :: ifax(19,plat) ! fft factorization of plon/2
-real(r8), public :: cnfac ! Courant num factor(multiply by max |V|)
-real(r8), public :: cnlim ! Maximum allowable courant number
-real(r8), public :: hdfsd2(pnmax) ! Del^2 mult. for each wave (vort-div)
-real(r8), public :: hdfst2(pnmax) ! Del^2 multiplier for each wave (t-q)
-real(r8), public :: hdfsdn(pnmax) ! Del^N mult. for each wave (vort-div)
-real(r8), public :: hdfstn(pnmax) ! Del^N multiplier for each wave (t-q)
-real(r8), public :: hdiftq(pnmax,plev) ! Temperature-tracer diffusion factors
-real(r8), public :: hdifzd(pnmax,plev) ! Vorticity-divergence diffusion factors
-integer, parameter, public :: kmxhd2 = 2 ! Bottom level for increased del^2 diffusion
-integer, public :: nindex(plev) ! Starting index for spectral truncation
-integer, public :: nmaxhd ! Maximum two dimensional wave number
-
-! Variables set by namelist
-real(r8), public :: dif2 ! del2 horizontal diffusion coeff.
-integer, public :: hdif_order ! Order of horizontal diffusion operator
-integer, public :: kmnhdn ! Nth order diffusion applied at and below layer kmnhdn.
- ! 2nd order diffusion is applied above layer kmnhdn.
-real(r8), public :: hdif_coef ! Nth order horizontal diffusion coefficient.
-real(r8), public :: divdampn ! Number of days (from nstep 0) to run divergence
-real(r8), public :: eps ! time filter coefficient. Defaults to 0.06.
-integer, public :: kmxhdc ! number of levels (starting from model top) to apply Courant limiter.
-integer, public :: eul_nsplit ! Intended number of dynamics timesteps per physics timestep
-
-end module eul_control_mod
diff --git a/src/dynamics/eul/grcalc.F90 b/src/dynamics/eul/grcalc.F90
deleted file mode 100644
index 6219a1c69b..0000000000
--- a/src/dynamics/eul/grcalc.F90
+++ /dev/null
@@ -1,513 +0,0 @@
-
-subroutine grcalcs (irow ,ztodt ,grts ,grths ,grds ,&
- grzs ,grus ,gruhs ,grvs ,grvhs ,&
- grpss ,grdpss ,grpms ,grpls ,tmpSPEcoef)
-!-----------------------------------------------------------------------
-!
-! Complete inverse Legendre transforms from spectral to Fourier space at
-! the the given latitude. Only positive latitudes are considered and
-! symmetric and antisymmetric (about equator) components are computed.
-! The sum and difference of these components give the actual fourier
-! coefficients for the latitude circle in the northern and southern
-! hemispheres respectively.
-!
-! The naming convention is as follows:
-! - The fourier coefficient arrays all begin with "gr";
-! - "t, q, d, z, ps" refer to temperature, specific humidity,
-! divergence, vorticity, and surface pressure;
-! - "h" refers to the horizontal diffusive tendency for the field.
-! - "s" suffix to an array => symmetric component;
-! - "a" suffix to an array => antisymmetric component.
-! Thus "grts" contains the symmetric Fourier coeffs of temperature and
-! "grtha" contains the antisymmetric Fourier coeffs of the temperature
-! tendency due to horizontal diffusion.
-! Three additional surface pressure related quantities are returned:
-! 1. "grdpss" and "grdpsa" contain the surface pressure factor
-! (proportional to del^4 ps) used for the partial correction of
-! the horizontal diffusion to pressure surfaces.
-! 2. "grpms" and "grpma" contain the longitudinal component of the
-! surface pressure gradient.
-! 3. "grpls" and "grpla" contain the latitudinal component of the
-! surface pressure gradient.
-!
-!---------------------------Code history--------------------------------
-!
-! Original version: CCM1
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, D. Williamson, J. Hack, August 1992
-! Reviewed: B. Boville, D. Williamson, April 1996
-! Modified: P. Worley, October 2002
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use comspe
- use commap
- use physconst, only: ez, ra
- use eul_control_mod
- use spmd_utils, only : iam
- implicit none
-
-!
-! Input arguments
-!
- integer, intent(in) :: irow ! latitude pair index
- real(r8), intent(in) :: ztodt ! twice the timestep unless nstep = 0
- real(r8), intent(in) :: tmpSPEcoef(plev*24,pnmax,maxm) ! rearranged variables array
-!
-! Output arguments: symmetric fourier coefficients
-!
- real(r8), intent(out) :: grts(2*maxm,plev) ! sum(n) of t(n,m)*P(n,m)
- real(r8), intent(out) :: grths(2*maxm,plev) ! sum(n) of K(2i)*t(n,m)*P(n,m)
- real(r8), intent(out) :: grds(2*maxm,plev) ! sum(n) of d(n,m)*P(n,m)
- real(r8), intent(out) :: grzs(2*maxm,plev) ! sum(n) of z(n,m)*P(n,m)
- real(r8), intent(out) :: grus(2*maxm,plev) ! sum(n) of z(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(out) :: gruhs(2*maxm,plev) ! sum(n) of K(2i)*z(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(out) :: grvs(2*maxm,plev) ! sum(n) of d(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(out) :: grvhs(2*maxm,plev) ! sum(n) of K(2i)*d(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(out) :: grpss(2*maxm) ! sum(n) of lnps(n,m)*P(n,m)
- real(r8), intent(out) :: grdpss(2*maxm) ! sum(n) of K(4)*(n(n+1)/a**2)**2*2dt*lnps(n,m)*P(n,m)
- real(r8), intent(out) :: grpms(2*maxm) ! sum(n) of lnps(n,m)*H(n,m)
- real(r8), intent(out) :: grpls(2*maxm) ! sum(n) of lnps(n,m)*P(n,m)*m/a
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) dalpn(pspt) ! (a/(n(n+1)))*derivative of Legendre functions (complex)
- real(r8) zurcor ! conversion term relating abs. & rel. vort.
- real(r8) tmpGRcoef(plev*24,maxm) ! temporal storage for Fourier coeffs
-
- integer k ! level index
- integer lm, m ! local and global Fourier wavenumber indices of spectral array
- integer mlength ! number of local wavenumbers
- integer n ! meridional wavenumber index
- integer ir,ii ! spectral indices
- integer lmr,lmc ! spectral indices
- integer lmwave0 ! local index for wavenumber 0
- integer lmrwave0 ! local offset for wavenumber 0
- integer kv ! level x variable index
-!
-!-----------------------------------------------------------------------
-!
-! Compute alpn and dalpn
-!
- lmwave0 = -1
- lmrwave0 = 0
- dalpn(2) = 0.0_r8
- mlength = numm(iam)
- do lm=1,mlength
- m = locm(lm,iam)
- lmr = lnstart(lm)
- if (m .eq. 1) then
- lmwave0 = lm
- lmrwave0 = lmr
- endif
- do n=1,nlen(m)
- dalpn(lmr+n) = ldalp(lmr+n,irow)*rsq(m+n-1)*ra
- end do
- end do
- zurcor = ez*dalpn(lmrwave0 + 2)
-!
-! Initialize sums
-!
- grpss (:) = 0._r8
- grpls (:) = 0._r8
- grpms (:) = 0._r8
- grdpss(:) = 0._r8
- tmpGRcoef (:,:) = 0._r8
-!
-! Loop over n for t,q,d,and end of u and v
-!
- do lm=1,mlength
- m = locm(lm,iam)
- lmr = lnstart(lm)
- do n=2,nlen(m),2
- do kv=1,plev*8
- tmpGRcoef(kv,lm) = tmpGRcoef(kv,lm) + tmpSPEcoef(kv,n,lm)*dalpn(lmr+n)
- end do
- end do
- end do
-!
- do lm=1,mlength
- m = locm(lm,iam)
- lmr = lnstart(lm)
- do n=1,nlen(m),2
- do kv=plev*8+1,plev*24
- tmpGRcoef(kv,lm) = tmpGRcoef(kv,lm) + tmpSPEcoef(kv,n,lm)*lalp(lmr+n,irow)
- end do
- end do
- end do
-!
-! Combine the two parts of u(m) and v(m)
-!
- do lm=1,mlength
- do kv=1,plev*8
- tmpGRcoef(kv,lm) = tmpGRcoef(kv,lm) + tmpGRcoef(kv+plev*16,lm)
- end do
- end do
-!
-! Save accumulated results to gr* arrays
-!
- do lm=1,mlength
- do k=1,plev
- grus (2*lm-1,k) = tmpGRcoef(k ,lm)
- grus (2*lm ,k) = tmpGRcoef(k+plev ,lm)
- grvs (2*lm-1,k) = tmpGRcoef(k+plev*2 ,lm)
- grvs (2*lm ,k) = tmpGRcoef(k+plev*3 ,lm)
- gruhs(2*lm-1,k) = tmpGRcoef(k+plev*4 ,lm)
- gruhs(2*lm ,k) = tmpGRcoef(k+plev*5 ,lm)
- grvhs(2*lm-1,k) = tmpGRcoef(k+plev*6 ,lm)
- grvhs(2*lm ,k) = tmpGRcoef(k+plev*7 ,lm)
-
- grts (2*lm-1,k) = tmpGRcoef(k+plev*8 ,lm)
- grts (2*lm ,k) = tmpGRcoef(k+plev*9 ,lm)
- grths(2*lm-1,k) = tmpGRcoef(k+plev*10,lm)
- grths(2*lm ,k) = tmpGRcoef(k+plev*11,lm)
- grds (2*lm-1,k) = tmpGRcoef(k+plev*12,lm)
- grds (2*lm ,k) = tmpGRcoef(k+plev*13,lm)
- grzs (2*lm-1,k) = tmpGRcoef(k+plev*14,lm)
- grzs (2*lm ,k) = tmpGRcoef(k+plev*15,lm)
- end do
- end do
-!
-! Remove Coriolis contribution to absolute vorticity from u(m)
-! Correction for u:zeta=vz-ez=(zeta+f)-f
-!
- if (lmwave0 .ne. -1) then
- do k=1,plev
-! grus(1,k) = grus(1,k) - zurcor
- grus(2*lmwave0-1,k) = grus(2*lmwave0-1,k) - zurcor
- end do
- endif
-!
-!-----------------------------------------------------------------------
-!
-! Computation for 1-level variables (ln(p*) and derivatives).
-!
- do lm=1,mlength
- m = locm(lm,iam)
- lmr = lnstart(lm)
- lmc = 2*lmr
- do n=1,nlen(m),2
- ir = lmc + 2*n - 1
- ii = ir + 1
-!
- grpss (2*lm-1) = grpss (2*lm-1) + alps(ir)*lalp(lmr+n,irow)
- grpss (2*lm ) = grpss (2*lm ) + alps(ii)*lalp(lmr+n,irow)
-!
- grdpss(2*lm-1) = grdpss(2*lm-1) + alps(ir)*lalp(lmr+n,irow)*hdfstn(m+n-1)*ztodt
- grdpss(2*lm ) = grdpss(2*lm ) + alps(ii)*lalp(lmr+n,irow)*hdfstn(m+n-1)*ztodt
- end do
- end do
-
- do lm=1,mlength
- m = locm(lm,iam)
- lmr = lnstart(lm)
- lmc = 2*lmr
- do n=2,nlen(m),2
- ir = lmc + 2*n - 1
- ii = ir + 1
-!
- grpms(2*lm-1) = grpms(2*lm-1) + alps(ir)*ldalp(lmr+n,irow)*ra
- grpms(2*lm ) = grpms(2*lm ) + alps(ii)*ldalp(lmr+n,irow)*ra
- end do
-!
-! Multiply by m/a to get d(ln(p*))/dlamda
-! and by 1/a to get (1-mu**2)d(ln(p*))/dmu
-!
- grpls(2*lm-1) = -grpss(2*lm )*ra*xm(m)
- grpls(2*lm ) = grpss(2*lm-1)*ra*xm(m)
- end do
-!
- return
-end subroutine grcalcs
-
-subroutine grcalca (irow ,ztodt ,grta ,grtha ,grda ,&
- grza ,grua ,gruha ,grva ,grvha ,&
- grpsa ,grdpsa ,grpma ,grpla ,tmpSPEcoef)
-
-!-----------------------------------------------------------------------
-!
-! Complete inverse Legendre transforms from spectral to Fourier space at
-! the the given latitude. Only positive latitudes are considered and
-! symmetric and antisymmetric (about equator) components are computed.
-! The sum and difference of these components give the actual fourier
-! coefficients for the latitude circle in the northern and southern
-! hemispheres respectively.
-!
-! The naming convention is as follows:
-! - The fourier coefficient arrays all begin with "gr";
-! - "t, q, d, z, ps" refer to temperature, specific humidity,
-! divergence, vorticity, and surface pressure;
-! - "h" refers to the horizontal diffusive tendency for the field.
-! - "s" suffix to an array => symmetric component;
-! - "a" suffix to an array => antisymmetric component.
-! Thus "grts" contains the symmetric Fourier coeffs of temperature and
-! "grtha" contains the antisymmetric Fourier coeffs of the temperature
-! tendency due to horizontal diffusion.
-! Three additional surface pressure related quantities are returned:
-! 1. "grdpss" and "grdpsa" contain the surface pressure factor
-! (proportional to del^4 ps) used for the partial correction of
-! the horizontal diffusion to pressure surfaces.
-! 2. "grpms" and "grpma" contain the longitudinal component of the
-! surface pressure gradient.
-! 3. "grpls" and "grpla" contain the latitudinal component of the
-! surface pressure gradient.
-!
-!---------------------------Code history--------------------------------
-!
-! Original version: CCM1
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, D. Williamson, J. Hack, August 1992
-! Reviewed: B. Boville, D. Williamson, April 1996
-! Modified: P. Worley, October 2002
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use comspe
- use commap
- use physconst, only: ra
- use eul_control_mod
- use spmd_utils, only : iam
- implicit none
-
-!
-! Input arguments
-!
- integer, intent(in) :: irow ! latitude pair index
- real(r8), intent(in) :: ztodt ! twice the timestep unless nstep = 0
- real(r8), intent(in) :: tmpSPEcoef(plev*24,pnmax,maxm) ! array for rearranged variables
-!
-!
-! Output arguments: antisymmetric fourier coefficients
-!
- real(r8), intent(out) :: grta(2*maxm,plev) ! sum(n) of t(n,m)*P(n,m)
- real(r8), intent(out) :: grtha(2*maxm,plev) ! sum(n) of K(2i)*t(n,m)*P(n,m)
- real(r8), intent(out) :: grda(2*maxm,plev) ! sum(n) of d(n,m)*P(n,m)
- real(r8), intent(out) :: grza(2*maxm,plev) ! sum(n) of z(n,m)*P(n,m)
- real(r8), intent(out) :: grua(2*maxm,plev) ! sum(n) of z(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(out) :: gruha(2*maxm,plev) ! sum(n) of K(2i)*z(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(out) :: grva(2*maxm,plev) ! sum(n) of d(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(out) :: grvha(2*maxm,plev) ! sum(n) of K(2i)*d(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(out) :: grpsa(2*maxm) ! sum(n) of lnps(n,m)*P(n,m)
- real(r8), intent(out) :: grdpsa(2*maxm) ! sum(n) of K(4)*(n(n+1)/a**2)**2*2dt*lnps(n,m)*P(n,m)
- real(r8), intent(out) :: grpma(2*maxm) ! sum(n) of lnps(n,m)*H(n,m)
- real(r8), intent(out) :: grpla(2*maxm) ! sum(n) of lnps(n,m)*P(n,m)*m/a
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) dalpn(pspt) ! (a/(n(n+1)))*derivative of Legendre functions (complex)
- real(r8) tmpGRcoef(plev*24,maxm) ! temporal storage for Fourier coefficients
-
- integer k ! level index
- integer lm, m ! local and global Fourier wavenumber indices of spectral array
- integer mlength ! number of local wavenumbers
- integer n ! meridional wavenumber index
- integer ir,ii ! spectral indices
- integer lmr,lmc ! spectral indices
- integer kv ! level x variable index
-!
-!-----------------------------------------------------------------------
-!
-! Compute alpn and dalpn
-!
- mlength = numm(iam)
- do lm=1,mlength
- m = locm(lm,iam)
- lmr = lnstart(lm)
- do n=1,nlen(m)
- dalpn(lmr+n) = ldalp(lmr+n,irow)*rsq(m+n-1)*ra
- end do
- end do
-!
-! Initialize sums
-!
- grpsa (:) = 0._r8
- grpla (:) = 0._r8
- grpma (:) = 0._r8
- grdpsa(:) = 0._r8
- tmpGRcoef(:,:) = 0._r8
-!
-! Loop over n for t,q,d,and end of u and v
-!
- do lm=1,mlength
- m = locm(lm,iam)
- lmr = lnstart(lm)
- do n=1,nlen(m),2
- do kv=1,plev*8
- tmpGRcoef(kv,lm) = tmpGRcoef(kv,lm) + tmpSPEcoef(kv,n,lm)*dalpn(lmr+n)
- end do
- end do
- end do
-
- do lm=1,mlength
- m = locm(lm,iam)
- lmr = lnstart(lm)
- do n=2,nlen(m),2
- do kv=plev*8+1,plev*24
- tmpGRcoef(kv,lm) = tmpGRcoef(kv,lm) + tmpSPEcoef(kv,n,lm)*lalp(lmr+n,irow)
- end do
- end do
- end do
-!
-! Combine the two parts of u(m) and v(m)
-!
- do lm=1,mlength
- do kv=1,plev*8
- tmpGRcoef(kv,lm) = tmpGRcoef(kv,lm) + tmpGRcoef(kv+plev*16,lm)
- end do
- end do
-!
-! Save accumulated results to gr* arrays
-!
- do lm=1,mlength
- do k=1,plev
- grua (2*lm-1,k) = tmpGRcoef(k ,lm)
- grua (2*lm ,k) = tmpGRcoef(k+plev ,lm)
- grva (2*lm-1,k) = tmpGRcoef(k+plev*2 ,lm)
- grva (2*lm ,k) = tmpGRcoef(k+plev*3 ,lm)
- gruha(2*lm-1,k) = tmpGRcoef(k+plev*4 ,lm)
- gruha(2*lm ,k) = tmpGRcoef(k+plev*5 ,lm)
- grvha(2*lm-1,k) = tmpGRcoef(k+plev*6 ,lm)
- grvha(2*lm ,k) = tmpGRcoef(k+plev*7 ,lm)
-
- grta (2*lm-1,k) = tmpGRcoef(k+plev*8 ,lm)
- grta (2*lm ,k) = tmpGRcoef(k+plev*9 ,lm)
- grtha(2*lm-1,k) = tmpGRcoef(k+plev*10,lm)
- grtha(2*lm ,k) = tmpGRcoef(k+plev*11,lm)
- grda (2*lm-1,k) = tmpGRcoef(k+plev*12,lm)
- grda (2*lm ,k) = tmpGRcoef(k+plev*13,lm)
- grza (2*lm-1,k) = tmpGRcoef(k+plev*14,lm)
- grza (2*lm ,k) = tmpGRcoef(k+plev*15,lm)
- end do
- end do
-!
-!-----------------------------------------------------------------------
-!
-! Computation for 1-level variables (ln(p*) and derivatives).
-!
- do lm=1,mlength
- m = locm(lm,iam)
- lmr = lnstart(lm)
- lmc = 2*lmr
- do n=1,nlen(m),2
- ir = lmc + 2*n - 1
- ii = ir + 1
-
- grpma(2*lm-1) = grpma(2*lm-1) + alps(ir)*ldalp(lmr+n,irow)*ra
- grpma(2*lm ) = grpma(2*lm ) + alps(ii)*ldalp(lmr+n,irow)*ra
- end do
- end do
-
- do lm=1,mlength
- m = locm(lm,iam)
- lmr = lnstart(lm)
- lmc = 2*lmr
- do n=2,nlen(m),2
- ir = lmc + 2*n - 1
- ii = ir + 1
-!
- grpsa (2*lm-1) = grpsa (2*lm-1) + alps(ir)*lalp(lmr+n,irow)
- grpsa (2*lm ) = grpsa (2*lm ) + alps(ii)*lalp(lmr+n,irow)
-!
- grdpsa(2*lm-1) = grdpsa(2*lm-1) + alps(ir)*lalp(lmr+n,irow)*hdfstn(m+n-1)*ztodt
- grdpsa(2*lm ) = grdpsa(2*lm ) + alps(ii)*lalp(lmr+n,irow)*hdfstn(m+n-1)*ztodt
- end do
-!
-! Multiply by m/a to get d(ln(p*))/dlamda
-! and by 1/a to get (1-mu**2)d(ln(p*))/dmu
-!
- grpla(2*lm-1) = -grpsa(2*lm )*ra*xm(m)
- grpla(2*lm ) = grpsa(2*lm-1)*ra*xm(m)
- end do
-!
- return
-end subroutine grcalca
-
-subroutine prepGRcalc(tmpSPEcoef)
-
-!-----------------------------------------------------------------------
-!
-! Rearrange multi-level spectral coefficients for vectorization.
-! The results are saved to "tmpSPEcoef" and will be used in
-! "grcalcs" and "grcalca".
-!
-!-----------------------------------------------------------------------
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use comspe
- use commap
- use physconst, only: ra
- use eul_control_mod, only: hdiftq, hdifzd
- use spmd_utils, only : iam
-!
- implicit none
-!
-!
-!---------------------------Output argument-----------------------------
-!
- real(r8), intent(out) :: tmpSPEcoef(plev*24,pnmax,maxm) ! array for rearranged variables
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) raxm
-!
- integer lm, m, n, k
- integer lmr, lmc
- integer ir ,ii
-!
-!-----------------------------------------------------------------------
-!
- do lm=1,numm(iam)
- m = locm(lm,iam)
- lmr = lnstart(lm)
- lmc = 2*lmr
- raxm = ra*xm(m)
- do n=1,nlen(m)
- ir = lmc + 2*n - 1
- ii = ir + 1
- do k=1,plev
- tmpSPEcoef(k ,n,lm) = vz(ir,k)
- tmpSPEcoef(k+plev ,n,lm) = vz(ii,k)
- tmpSPEcoef(k+plev*2 ,n,lm) = -d(ir,k)
- tmpSPEcoef(k+plev*3 ,n,lm) = -d(ii,k)
- tmpSPEcoef(k+plev*4 ,n,lm) = -vz(ir,k)*hdifzd(n+m-1,k)
- tmpSPEcoef(k+plev*5 ,n,lm) = -vz(ii,k)*hdifzd(n+m-1,k)
- tmpSPEcoef(k+plev*6 ,n,lm) = d(ir,k)*hdifzd(n+m-1,k)
- tmpSPEcoef(k+plev*7 ,n,lm) = d(ii,k)*hdifzd(n+m-1,k)
-
- tmpSPEcoef(k+plev*8 ,n,lm) = t(ir,k)
- tmpSPEcoef(k+plev*9 ,n,lm) = t(ii,k)
- tmpSPEcoef(k+plev*10,n,lm) = -t(ir,k)*hdiftq(n+m-1,k)
- tmpSPEcoef(k+plev*11,n,lm) = -t(ii,k)*hdiftq(n+m-1,k)
- tmpSPEcoef(k+plev*12,n,lm) = d(ir,k)
- tmpSPEcoef(k+plev*13,n,lm) = d(ii,k)
- tmpSPEcoef(k+plev*14,n,lm) = vz(ir,k)
- tmpSPEcoef(k+plev*15,n,lm) = vz(ii,k)
-
- tmpSPEcoef(k+plev*16,n,lm) = d (ii,k)*rsq(m+n-1)*raxm
- tmpSPEcoef(k+plev*17,n,lm) = -d (ir,k)*rsq(m+n-1)*raxm
- tmpSPEcoef(k+plev*18,n,lm) = vz(ii,k)*rsq(m+n-1)*raxm
- tmpSPEcoef(k+plev*19,n,lm) = -vz(ir,k)*rsq(m+n-1)*raxm
- tmpSPEcoef(k+plev*20,n,lm) = -d (ii,k)*hdifzd(n+m-1,k)*rsq(m+n-1)*raxm
- tmpSPEcoef(k+plev*21,n,lm) = d (ir,k)*hdifzd(n+m-1,k)*rsq(m+n-1)*raxm
- tmpSPEcoef(k+plev*22,n,lm) = -vz(ii,k)*hdifzd(n+m-1,k)*rsq(m+n-1)*raxm
- tmpSPEcoef(k+plev*23,n,lm) = vz(ir,k)*hdifzd(n+m-1,k)*rsq(m+n-1)*raxm
- end do
- end do
- end do
-!
- return
-end subroutine prepGRcalc
diff --git a/src/dynamics/eul/grmult.F90 b/src/dynamics/eul/grmult.F90
deleted file mode 100644
index 11f8136bd5..0000000000
--- a/src/dynamics/eul/grmult.F90
+++ /dev/null
@@ -1,322 +0,0 @@
-
-subroutine grmult(rcoslat ,d ,qm1 ,tm1 ,um1 ,&
- vm1 ,z ,tm2 ,phis ,dpsl ,&
- dpsm ,omga ,pdel ,pbot ,logpsm2 ,&
- logpsm1 ,rpmid ,rpdel ,fu ,fv ,&
- t2 ,ut ,vt ,drhs ,pmid ,&
- etadot ,etamid ,engy ,ddpn ,vpdsn ,&
- dpslon ,dpslat ,vat ,ktoop ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Non-linear dynamics calculations in grid point space
-!
-! Method:
-!
-! Author:
-! Original version: CCM1
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, D. Williamson, J. Hack, August 1992
-! Reviewed: B. Boville, D. Williamson, April 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev, plevp, plon
- use pspect
- use commap
- use physconst, only: rair, cappa, cpvir, zvir
- use hycoef, only : hybi, hybm, hybd, nprlev
-
- implicit none
-
-!
-! Input arguments
-!
- real(r8), intent(in) :: rcoslat ! 1./cosine(latitude)
- real(r8), intent(in) :: d(plon,plev) ! divergence
- real(r8), intent(in) :: qm1(plon,plev) ! specific humidity
- real(r8), intent(in) :: tm1(plon,plev) ! temperature
- real(r8), intent(in) :: um1(plon,plev) ! zonal wind * cos(lat)
- real(r8), intent(in) :: vm1(plon,plev) ! meridional wind * cos(lat)
- real(r8), intent(in) :: z(plon,plev) ! vorticity
- real(r8), intent(in) :: phis(plon) ! surface geopotential
- real(r8), intent(in) :: dpsl(plon) ! longitudinal component of grad ln(ps)
- real(r8), intent(in) :: dpsm(plon) ! latitudinal component of grad ln(ps)
- real(r8), intent(in) :: omga(plon,plev) ! vertical pressure velocity
- real(r8), intent(in) :: pdel(plon,plev) ! layer thicknesses (pressure)
- real(r8), intent(in) :: pbot(plon) ! bottom interface pressure
- real(r8), intent(in) :: logpsm2(plon) ! log(psm2)
- real(r8), intent(in) :: logpsm1(plon) ! log(ps)
- real(r8), intent(in) :: rpmid(plon,plev) ! 1./pmid
- real(r8), intent(in) :: rpdel(plon,plev) ! 1./pdel
- real(r8), intent(in) :: tm2(plon,plev) ! temperature at previous time step
- integer, intent(in) :: nlon
-!
-! Input/Output arguments
-!
- real(r8), intent(inout) :: fu(plon,plev) ! nonlinear term - u momentum eqn
- real(r8), intent(inout) :: fv(plon,plev) ! nonlinear term - v momentum eqn
- real(r8), intent(inout) :: t2(plon,plev) ! nonlinear term - temperature
- real(r8), intent(inout) :: ut(plon,plev) ! (u*TM1) - heat flux - zonal
- real(r8), intent(inout) :: vt(plon,plev) ! (u*TM1) - heat flux - meridional
- real(r8), intent(inout) :: drhs(plon,plev) ! RHS of divergence eqn (del^2 term)
- real(r8), intent(inout) :: pmid(plon,plev) ! pressure at full levels
- real(r8), intent(inout) :: etadot(plon,plevp) ! vertical velocity in eta coordinates
- real(r8), intent(in) :: etamid(plev) ! midpoint values of eta (a+b)
- real(r8), intent(inout) :: engy(plon,plev) ! kinetic energy
-!
-! Output arguments
-!
- real(r8), intent(out) :: ddpn(plon) ! complete sum of d*delta p
- real(r8), intent(out) :: vpdsn(plon) ! complete sum V dot grad(ln(ps)) delta b
- real(r8), intent(out) :: dpslat(plon,plev) ! ln(ps) component of lon press gradient
- real(r8), intent(out) :: dpslon(plon,plev) ! ln(ps) component of lat press gradient
- real(r8), intent(out) :: vat (plon,plev) ! Vertical advection of temperature
- real(r8), intent(out) :: ktoop (plon,plev) ! (Kappa*T)*(omega/P)
-
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) tv(plon,plev) ! virtual temperature
- real(r8) ddpk(plon) ! partial sum of d*delta p
- real(r8) vkdp ! V dot grad(ln(ps))
- real(r8) vpdsk(plon) ! partial sum V dot grad(ln(ps)) delta b
- real(r8) tk0(plon) ! tm1 at phony level 0
- real(r8) uk0(plon) ! u at phony level 0
- real(r8) vk0(plon) ! v at phone level 0
- real(r8) rtv(plon,plev) ! rair*tv
- real(r8) pterm(plon,plev) ! intermediate term for hydrostatic eqn
- real(r8) tterm(plon,plev) ! intermediate term for hydrostatic eqn
- real(r8) tmp ! temporary workspace
- real(r8) tmpk ! temporary workspace
- real(r8) tmpkp1 ! temporary workspace
- real(r8) edotdpde(plon,plevp) ! etadot*dp/deta
- real(r8) udel(plon,0:plev-1) ! vertical u difference
- real(r8) vdel(plon,0:plev-1) ! vertical v difference
- real(r8) tdel(plon,0:plev-1) ! vertical TM1 difference
-
- integer i,k,kk ! longitude, level indices
-!
-! Initialize arrays which represent vertical sums (ddpk, ddpn, vpdsk,
-! vpdsn). Set upper boundary condition arrays (k=0: tk0, uk0, vk0).
-!
- ddpk = 0.0_r8
- ddpn = 0.0_r8
- vpdsk = 0.0_r8
- vpdsn = 0.0_r8
- tk0 = 0.0_r8
- uk0 = 0.0_r8
- vk0 = 0.0_r8
-!
-! Virtual temperature
-!
-tv(:nlon,:) = tm1(:nlon,:) * (1.0_r8 + zvir * qm1(:nlon,:))
-
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- rtv(i,k) = rair*tv(i,k)
- end do
- end do
-!
-!$OMP PARALLEL DO PRIVATE (I, K, VKDP)
- do i=1,nlon
-!
-! sum(plev)(d(k)*dp(k))
-!
- do k=1,plev
- ddpn(i) = ddpn(i) + d(i,k)*pdel(i,k)
- end do
-!
-! sum(plev)(v(k)*grad(lnps)*db(k))
-!
- do k=nprlev,plev
- vkdp = rcoslat*(um1(i,k)*dpsl(i) + vm1(i,k)*dpsm(i))*pbot(i)
- vpdsn(i) = vpdsn(i) + vkdp*hybd(k)
- end do
-!
-! Compute etadot (dp/deta) (k+1/2). Note: sum(k)(d(j)*dp(j)) required in
-! pressure region. sum(k)(d(j)*dp(j)) and sum(k)(v(j)*grad(ps)*db(j))
-! required in hybrid region
-!
- edotdpde(i,1) = 0._r8
- do k=1,nprlev-1
- ddpk(i) = ddpk(i) + d(i,k)*pdel(i,k)
- edotdpde(i,k+1) = -ddpk(i)
- end do
-!
- do k=nprlev,plev-1
- ddpk(i) = ddpk(i) + d(i,k)*pdel(i,k)
- vkdp = rcoslat*(um1(i,k)*dpsl(i) + vm1(i,k)*dpsm(i))*pbot(i)
- vpdsk(i) = vpdsk(i) + vkdp*hybd(k)
- edotdpde(i,k+1) = -ddpk(i) - vpdsk(i) + hybi(k+1)*(ddpn(i)+vpdsn(i))
- end do
- edotdpde(i,plevp) = 0._r8
-!
-!
- end do
-
-!
-! Nonlinear advection terms. u*tm1, v*tm1, kinetic energy first
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- ut(i,k) = um1(i,k)*tm1(i,k)
- vt(i,k) = vm1(i,k)*tm1(i,k)
- engy(i,k) = 0.5_r8*(um1(i,k)**2 + vm1(i,k)**2)
- end do
- end do
-!
-! Compute workspace arrays for delta-u, delta-v, delta-tm1 (k)
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=0,plev-1
- if (k == 0) then
- do i=1,nlon
- udel(i,0) = um1(i,1) - uk0(i)
- vdel(i,0) = vm1(i,1) - vk0(i)
- tdel(i,0) = tm1(i,1) - tk0(i)
- end do
- else
- do i=1,nlon
- udel(i,k) = um1(i,k+1) - um1(i,k)
- vdel(i,k) = vm1(i,k+1) - vm1(i,k)
- tdel(i,k) = tm1(i,k+1) - tm1(i,k)
- end do
- endif
- end do
-!
-!$OMP PARALLEL DO PRIVATE (K, I, TMPK, TMPKP1, TMP)
- do k=1,plev
-!
- if (k < nprlev) then
-!
-! Horizontal advection: u*z, v*z, energy conversion term (omega/p),
-! vertical advection for interface above. Pure pressure region first.
-!
- do i=1,nlon
- dpslat(i,k) = 0._r8
- dpslon(i,k) = 0._r8
- tmpk = 0.5_r8*rpdel(i,k)*edotdpde(i,k )
- tmpkp1 = 0.5_r8*rpdel(i,k)*edotdpde(i,k+1)
- fu(i,k) = fu(i,k) + vm1(i,k)*z(i,k) - udel(i,k-1)*tmpk - udel(i,k )*tmpkp1
- fv(i,k) = fv(i,k) - um1(i,k)*z(i,k) - vdel(i,k-1)*tmpk - vdel(i,k )*tmpkp1
- vat (i,k) = - (tdel(i,k-1)*tmpk + tdel(i,k)*tmpkp1)
- ktoop(i,k) = cappa*tv(i,k)/(1._r8 + cpvir*qm1(i,k))* &
- omga(i,k)*rpmid(i,k)
- t2 (i,k) = t2(i,k) + d(i,k)*tm1(i,k) - tdel(i,k-1)*tmpk + &
- ktoop(i,k) - tdel(i,k)*tmpkp1
- end do
-!
- else if (k < plev) then
-!
-! Hybrid region above bottom level: Computations are the same as in pure
-! pressure region, except that pressure gradient terms are added to
-! momentum tendencies.
-!
- do i=1,nlon
- tmpk = 0.5_r8*rpdel(i,k)*edotdpde(i,k )
- tmpkp1 = 0.5_r8*rpdel(i,k)*edotdpde(i,k+1)
- tmp = rtv(i,k)*hybm(k)*rpmid(i,k)*pbot(i)
- dpslon(i,k) = rcoslat*tmp*dpsl(i)
- dpslat(i,k) = rcoslat*tmp*dpsm(i)
- fu(i,k) = fu(i,k) + vm1(i,k)*z(i,k) - udel(i,k-1)*tmpk - &
- udel(i,k )*tmpkp1 - dpslon(i,k)
- fv(i,k) = fv(i,k) - um1(i,k)*z(i,k) - vdel(i,k-1)*tmpk - &
- vdel(i,k )*tmpkp1 - dpslat(i,k)
- vat (i,k) = - (tdel(i,k-1)*tmpk + tdel(i,k)*tmpkp1)
- ktoop(i,k) = cappa*tv(i,k)/(1._r8 + cpvir*qm1(i,k))* &
- omga(i,k)*rpmid(i,k)
- t2 (i,k) = t2(i,k) + d(i,k)*tm1(i,k) - tdel(i,k-1)*tmpk + &
- ktoop(i,k) - tdel(i,k)*tmpkp1
- end do
-!
- else
-!
-! Bottom level
-!
- do i=1,nlon
- tmpk = 0.5_r8*rpdel(i,plev)*edotdpde(i,plev )
- tmp = rtv(i,plev)*hybm(plev)*rpmid(i,plev)*pbot(i)
- dpslon(i,plev) = rcoslat*tmp*dpsl(i)
- dpslat(i,plev) = rcoslat*tmp*dpsm(i)
- fu(i,plev) = fu(i,plev) + vm1(i,plev)*z(i,plev) - &
- udel(i,plev-1)*tmpk - dpslon(i,plev)
- fv(i,plev) = fv(i,plev) - um1(i,plev)*z(i,plev) - &
- vdel(i,plev-1)*tmpk - dpslat(i,plev)
- vat (i,plev) = -(tdel(i,plev-1)*tmpk)
- ktoop(i,plev) = cappa*tv(i,plev)/(1._r8 + cpvir*qm1(i,plev))* &
- omga(i,plev)*rpmid(i,plev)
- t2 (i,plev) = t2(i,plev) + d(i,plev)*tm1(i,plev) - &
- tdel(i,plev-1)*tmpk + ktoop(i,plev)
- end do
-!
- end if
-!
- enddo
-!
-! Convert eta-dot(dp/deta) to eta-dot (top and bottom = 0.)
-!
- etadot(:,1) = 0._r8
- etadot(:,plevp) = 0._r8
-!$OMP PARALLEL DO PRIVATE (K, TMP, I)
- do k=2,plev
- tmp = etamid(k) - etamid(k-1)
- do i=1,nlon
- etadot(i,k) = edotdpde(i,k)*tmp/(pmid(i,k) - pmid(i,k-1))
- end do
- end do
-!
-!-----------------------------------------------------------------------
-!
-! Divergence and hydrostatic equations
-!
-! Del squared part of RHS of divergence equation.
-! Kinetic energy and diagonal term of hydrostatic equation.
-! Total temperature as opposed to perturbation temperature is acceptable
-! since del-square operator will operate on this term.
-! (Also store some temporary terms.)
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- tterm(i,k) = 0.5_r8*tm2(i,k) - tm1(i,k)
- pterm(i,k) = rtv(i,k)*rpmid(i,k)*pdel(i,k)
- drhs(i,k) = phis(i) + engy(i,k) + rtv(i,k)*0.5_r8* &
- rpmid(i,k)*pdel(i,k) + href(k,k)*tterm(i,k) + &
- bps(k)*(0.5_r8*logpsm2(i) - logpsm1(i))
- end do
- end do
-
-!
-! Bottom level term of hydrostatic equation
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev-1
- do i=1,nlon
- drhs(i,k) = drhs(i,k) + rtv(i,plev)* &
- rpmid(i,plev)*pdel(i,plev) + &
- href(plev,k)*tterm(i,plev)
- end do
- end do
-!
-! Interior terms of hydrostatic equation
-!
-!$OMP PARALLEL DO PRIVATE (K, KK, I)
- do k=1,plev-2
- do kk=k+1,plev-1
- do i=1,nlon
- drhs(i,k) = drhs(i,k) + pterm(i,kk) + href(kk,k)*tterm(i,kk)
- end do
- end do
- end do
-!
- return
-end subroutine grmult
diff --git a/src/dynamics/eul/hdinti.F90 b/src/dynamics/eul/hdinti.F90
deleted file mode 100644
index 67a4110fa4..0000000000
--- a/src/dynamics/eul/hdinti.F90
+++ /dev/null
@@ -1,80 +0,0 @@
-
-subroutine hdinti(rearth, deltat)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Time independent initialization for the horizontal diffusion.
-!
-! Method:
-!
-! Author:
-! Original version: D. Williamson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, J. Hack, August 1992
-! Reviewed: B. Boville, April 1996
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8=>shr_kind_r8
- use cam_abortutils, only: endrun
- use pmgrid
- use pspect
- use eul_control_mod
- use cam_logfile, only: iulog
- implicit none
-
-!------------------------------Arguments--------------------------------
-
- real(r8), intent(in) :: rearth ! radius of the earth
- real(r8), intent(in) :: deltat ! time step
-
-!---------------------------Local workspace-----------------------------
-
- integer :: k ! level index
- integer :: n ! n-wavenumber index
- integer :: iexpon
- real(r8) :: fn
-!
-!-----------------------------------------------------------------------
-!
-! Initialize physical constants for courant number based spect truncation
-!
- nmaxhd = ptrk
- cnlim = 0.999_r8 ! maximum allowable Courant number
- cnfac = deltat*real(nmaxhd,r8)/rearth
-!
-! Initialize arrays used for courant number based spectral truncation
-!
- do k=1,plev
- nindex(k) = 2*nmaxhd
- end do
-!
-! Set the Del^2 and Del^N diffusion coefficients for each wavenumber
-!
- hdfst2(1) = 0._r8
- hdfsd2(1) = 0._r8
-!
- hdfstn(1) = 0._r8
- hdfsdn(1) = 0._r8
-
- iexpon = hdif_order/2
-
- do n=2,pnmax
-
- hdfst2(n) = dif2 * (n*(n-1) ) / rearth**2
- hdfsd2(n) = dif2 * (n*(n-1)-2) / rearth**2
-
- fn = n*(n-1)
- fn = fn/rearth**2
- fn = fn**iexpon
-
- hdfstn(n) = hdif_coef * fn
- fn = 2._r8/rearth**2
- hdfsdn(n) = hdfstn(n) - hdif_coef * fn**iexpon
-
- end do
-!
- return
-end subroutine hdinti
-
diff --git a/src/dynamics/eul/herxin.F90 b/src/dynamics/eul/herxin.F90
deleted file mode 100644
index afed4de04f..0000000000
--- a/src/dynamics/eul/herxin.F90
+++ /dev/null
@@ -1,143 +0,0 @@
-
-subroutine herxin(pf ,pkcnst ,fb ,fxl ,fxr , &
- x ,xdp ,idp ,jdp ,fint , &
- nlon ,nlonex )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-!
-! Method:
-! For each departure point in the latitude slice being forecast,
-! interpolate (using equally spaced Hermite cubic formulas) to its
-! x value at each latitude required for later interpolation in the y
-! direction.
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plon
- use scanslt, only: plond, beglatex, endlatex, platd, nxpt
- use cam_abortutils, only: endrun
-!-----------------------------------------------------------------------
- implicit none
-!------------------------------Parameters-------------------------------
-#include <parslt.h>
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: pf ! dimension (number of fields)
- integer, intent(in) :: pkcnst ! dimension,=p3d
-!
- real(r8), intent(in) :: fb (plond,plev,pkcnst,beglatex:endlatex) ! field
- real(r8), intent(in) :: fxl(plond,plev,pf,beglatex:endlatex) ! left x derivative
- real(r8), intent(in) :: fxr(plond,plev,pf,beglatex:endlatex) ! right x derivative
- real(r8), intent(in) :: x(plond,platd) ! longitudinal grid coordinates
- real(r8), intent(in) :: xdp(plon,plev) ! departure point coordinates
-!
- integer, intent(in) :: idp(plon,plev,4) ! longitude index of dep pt.
- integer, intent(in) :: jdp(plon,plev) ! latitude index of dep pt.
- integer, intent(in) :: nlon
- integer, intent(in) :: nlonex(platd)
-!
-! Output arguments
-!
- real(r8), intent(out) :: fint(plon,plev,ppdy,pf) ! x-interpolants
-!
-!-----------------------------------------------------------------------
-!
-! pf Number of fields being interpolated.
-! pkcnst Dimensioning construct for 3-D arrays.
-! fb extended array of data to be interpolated.
-! fxl x derivatives at the left edge of each interval containing
-! the departure point
-! fxr x derivatives at the right edge of each interval containing
-! the departure point
-! x Equally spaced x grid values in extended arrays.
-! xdp xdp(i,k) is the x-coordinate (extended grid) of the
-! departure point that corresponds to global grid point (i,k)
-! in the latitude slice being forecasted.
-! idp idp(i,k) is the index of the x-interval (extended grid) that
-! contains the departure point corresponding to global grid
-! point (i,k) in the latitude slice being forecasted.
-! Note that
-! x(idp(i,k)) .le. xdp(i,k) .lt. x(idp(i,k)+1) .
-! jdp jdp(i,k) is the index of the y-interval (extended grid) that
-! contains the departure point corresponding to global grid
-! point (i,k) in the latitude slice being forecasted.
-! Suppose yb contains the y-coordinates of the extended array
-! and ydp(i,k) is the y-coordinate of the departure point
-! corresponding to grid point (i,k). Then,
-! yb(jdp(i,k)) .le. ydp(i,k) .lt. yb(jdp(i,k)+1) .
-! fint (fint(i,k,j,n),j=1,ppdy) contains the x interpolants at each
-! latitude needed for the y derivative estimates at the
-! endpoints of the interval that contains the departure point
-! for grid point (i,k). The last index of fint allows for
-! interpolation of multiple fields.
-!
-!---------------------------Local workspace-----------------------------
-!
- integer i,j,k,m ! indices
-!
- real(r8) dx (platd) ! x-increment
- real(r8) rdx(platd) ! 1./dx
- real(r8) xl ! |
- real(r8) xr ! |
- real(r8) hl (plon,plev) ! | --interpolation coeffs
- real(r8) hr (plon,plev) ! |
- real(r8) dhl(plon,plev) ! |
- real(r8) dhr(plon,plev) ! |
-
- integer n
-
-!
-!-----------------------------------------------------------------------
-!
- if(ppdy .ne. 4) then
- call endrun ('HERXIN:Fatal error: ppdy must be set to 4')
- end if
-
- dx (1) = x(nxpt+2,1) - x(nxpt+1,1)
- rdx(1) = 1._r8/dx(1)
-!$OMP PARALLEL DO PRIVATE (K, I, XL, XR)
- do k=1,plev
- do i=1,nlon
- xl = ( x(idp(i,k,1)+1,1) - xdp(i,k) )*rdx(1)
- xr = 1._r8 - xl
- hl (i,k) = ( 3.0_r8 - 2.0_r8*xl)*xl**2
- hr (i,k) = ( 3.0_r8 - 2.0_r8*xr )*xr**2
- dhl(i,k) = -dx(1)*( xl - 1._r8 )*xl**2
- dhr(i,k) = dx(1)*( xr - 1._r8 )*xr**2
- end do
- end do
-
- ! x interpolation at each latitude needed for y interpolation.
- ! Once for each field.
-
- do m = 1,pf
-!$OMP PARALLEL DO PRIVATE (N, K, I)
- do n=1,4
- do k = 1,plev
- do i = 1,nlon
- fint(i,k,n,m) = &
- fb (idp(i,k,1) ,k,m,jdp(i,k)+(n-2))*hl (i,k) + &
- fb (idp(i,k,1)+1,k,m,jdp(i,k)+(n-2))*hr (i,k) + &
- fxl(idp(i,k,1) ,k,m,jdp(i,k)+(n-2))*dhl(i,k) + &
- fxr(idp(i,k,1) ,k,m,jdp(i,k)+(n-2))*dhr(i,k)
- enddo
- enddo
- enddo
- enddo
-
-end subroutine herxin
diff --git a/src/dynamics/eul/heryin.F90 b/src/dynamics/eul/heryin.F90
deleted file mode 100644
index 69a378ed88..0000000000
--- a/src/dynamics/eul/heryin.F90
+++ /dev/null
@@ -1,129 +0,0 @@
-
-subroutine heryin(pf ,fint ,fyb ,fyt ,y , &
- dy ,ydp ,jdp ,fdp ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-!
-! Method:
-! For each departure point in the latitude slice to be forecast,
-! interpolate (using unequally spaced Hermite cubic formulas) the
-! x interpolants to the y value of the departure point.
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
- use scanslt, only: platd
-!-----------------------------------------------------------------------
- implicit none
-!------------------------------Parameters-------------------------------
-#include <parslt.h>
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: pf ! dimension (number of fields)
-!
- real(r8), intent(in) :: fint(plon,plev,ppdy,pf) ! x-interpolants
- real(r8), intent(in) :: fyb (plon,plev,pf) ! y-derivatives at bottom of interval
- real(r8), intent(in) :: fyt (plon,plev,pf) ! y-derivatives at top of interval
- real(r8), intent(in) :: y (platd) ! latitude grid coordinates
- real(r8), intent(in) :: dy (platd) ! intervals between latitude grid pts.
- real(r8), intent(in) :: ydp (plon,plev) ! lat. coord of departure point.
-!
- integer, intent(in) :: jdp (plon,plev) ! lat. index of departure point.
- integer, intent(in) :: nlon
-!
-! Output arguments
-!
- real(r8), intent(out) :: fdp (plon,plev,pf) ! y-interpolants
-
-!
-!-----------------------------------------------------------------------
-!
-! pf Number of fields being interpolated.
-! fint (fint(i,k,j,m),j=ppdy/2,ppdy/2 + 1) contains the x
-! interpolants at the endpoints of the y-interval that
-! contains the departure point for grid point (i,k). The last
-! index of fint allows for interpolation of multiple fields.
-! fint is generated by a call to herxin.
-! fyb fyb(i,k,.) is the derivative at the "bottom" of the
-! y-interval that contains the departure point of grid
-! point (i,k). fyb is generated by a call to cubydr.
-! fyt fyt(i,k,.) is the derivative at the "top" of the y-interval
-! that contains the departure point of grid point (i,k).
-! fyt is generated by a call to cubydr.
-! y y-coordinate (latitude) values in the extended array.
-! dy Increment in the y-coordinate value for each interval in the
-! extended array.
-! ydp ydp(i,k) is the y-coordinate of the departure point that
-! corresponds to global grid point (i,k) in the latitude slice
-! being forecasted.
-! jdp jdp(i,k) is the index of the y-interval that contains the
-! departure point corresponding to global grid point (i,k) in
-! the latitude slice being forecasted.
-! Note that
-! y(jdp(i,k)) .le. ydp(i,k) .lt. y(jdp(i,k)+1) .
-! fdp Horizontally interpolated field values at the departure point
-! for the latitude slice being forecasted.
-!
-!---------------------------Local variables-----------------------------
-!
- integer i,k ! index
- integer jb ! index corresponding to bot of interval
- integer jt ! index corresponding to top of interval
- integer m ! index
-!
- real(r8) dyj(plon,plev) ! latitude interval containing dep. pt.
- real(r8) yb (plon,plev) ! |
- real(r8) yt (plon,plev) ! |
- real(r8) hb (plon,plev) ! | -- interpolation coefficients
- real(r8) ht (plon,plev) ! |
- real(r8) dhb(plon,plev) ! |
- real(r8) dht(plon,plev) ! |
-!
-!-----------------------------------------------------------------------
-!
- jb = ppdy/2
- jt = jb + 1
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i = 1,nlon
- dyj(i,k) = dy(jdp(i,k))
- yb (i,k) = ( y(jdp(i,k)+1) - ydp(i,k) )/dyj(i,k)
- yt (i,k) = 1._r8 - yb(i,k)
- hb (i,k) = ( 3.0_r8 - 2.0_r8*yb(i,k) )*yb(i,k)**2
- ht (i,k) = ( 3.0_r8 - 2.0_r8*yt(i,k) )*yt(i,k)**2
- dhb(i,k) = -dyj(i,k)*( yb(i,k) - 1._r8 )*yb(i,k)**2
- dht(i,k) = dyj(i,k)*( yt(i,k) - 1._r8 )*yt(i,k)**2
- end do
- end do
-!
-! Loop over fields.
-!
- do m = 1,pf
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i = 1,nlon
- fdp(i,k,m) = fint(i,k,jb,m)*hb(i,k) + fyb(i,k,m)*dhb(i,k) + &
- fint(i,k,jt,m)*ht(i,k) + fyt(i,k,m)*dht(i,k)
- end do
- end do
- end do
-!
- return
-end subroutine heryin
diff --git a/src/dynamics/eul/herzin.F90 b/src/dynamics/eul/herzin.F90
deleted file mode 100644
index d56a3d0fe0..0000000000
--- a/src/dynamics/eul/herzin.F90
+++ /dev/null
@@ -1,107 +0,0 @@
-
-subroutine herzin(pkdim ,pf ,f ,fst ,fsb , &
- sig ,dsig ,sigdp ,kdp ,fdp , &
- nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Interpolate field on vertical slice to vertical departure point using
-! Hermite cubic interpolation.
-!
-! Method:
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
-!-----------------------------------------------------------------------
- implicit none
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: pkdim ! vertical dimension
- integer, intent(in) :: pf ! dimension (number of fields)
-!
- real(r8), intent(in) :: f (plon,pkdim,pf) ! fields
- real(r8), intent(in) :: fst (plon,pkdim,pf) ! z-derivatives at top edge of interval
- real(r8), intent(in) :: fsb (plon,pkdim,pf) ! z-derivatives at bot edge of interval
- real(r8), intent(in) :: sig (pkdim) ! vertical grid coordinates
- real(r8), intent(in) :: dsig (pkdim) ! intervals between vertical grid pts.
- real(r8), intent(in) :: sigdp(plon,plev) ! vertical coord. of departure point
-!
- integer, intent(in) :: kdp (plon,plev) ! vertical index of departure point
- integer, intent(in) :: nlon
-!
-! Output arguments
-!
- real(r8), intent(out) :: fdp(plon,plev,pf) ! z-interpolants
-!
-!-----------------------------------------------------------------------
-!
-! pkdim Vertical dimension of vertical slice arrays.
-! pf Number of fields being interpolated.
-! f Vertical slice of data to be interpolated.
-! fst z-derivatives at the top edge of each interval contained in f
-! fsb z-derivatives at the bot edge of each interval contained in f
-! sig Sigma values corresponding to the vertical grid
-! dsig Increment in sigma value for each interval in vertical grid.
-! sigdp Sigma value at the trajectory midpoint or endpoint for each
-! gridpoint in a vertical slice from the global grid.
-! kdp Vertical index for each gridpoint. This index points into a
-! vertical slice array whose vertical grid is given by sig.
-! E.g., sig(kdp(i,j)) .le. sigdp(i,j) .lt. sig(kdp(i,j)+1) .
-! fdp Value of field at the trajectory midpoints or endpoints.
-!
-!---------------------------Local variables-----------------------------
-!
- integer i,k,m ! indices
-!
- real(r8) dzk ! vert interval containing the dep. pt.
- real(r8) zt ! |
- real(r8) zb ! |
- real(r8) ht (plon) ! | -- interpolation coefficients
- real(r8) hb (plon) ! |
- real(r8) dht(plon) ! |
- real(r8) dhb(plon) ! |
-!
-!-----------------------------------------------------------------------
-!
-!$OMP PARALLEL DO PRIVATE (K, I, DZK, ZT, ZB, HT, HB, DHT, DHB, M)
- do k=1,plev
- do i=1,nlon
- dzk = dsig(kdp(i,k))
- zt = ( sig(kdp(i,k)+1) - sigdp(i,k) )/dzk
- zb = 1._r8 - zt
- ht (i) = ( 3.0_r8 - 2.0_r8*zt )*zt**2
- hb (i) = ( 3.0_r8 - 2.0_r8*zb )*zb**2
- dht(i) = -dzk*( zt - 1._r8 )*zt**2
- dhb(i) = dzk*( zb - 1._r8 )*zb**2
- end do
-!
-! Loop over fields.
-!
- do m=1,pf
- do i=1,nlon
- fdp(i,k,m) = f(i,kdp(i,k) ,m)* ht(i) + &
- fst(i,kdp(i,k),m)*dht(i) + &
- f(i,kdp(i,k)+1,m)* hb(i) + &
- fsb(i,kdp(i,k),m)*dhb(i)
- end do
- end do
- end do
-!
- return
-end subroutine herzin
diff --git a/src/dynamics/eul/hordif.F90 b/src/dynamics/eul/hordif.F90
deleted file mode 100644
index c745b562cc..0000000000
--- a/src/dynamics/eul/hordif.F90
+++ /dev/null
@@ -1,154 +0,0 @@
-subroutine hordif(k,ztdt)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-!
-! Method:
-! Horizontal diffusion of z,d,t,q
-! 1. implicit del**2 form above level kmnhdn
-! 2. implicit del**N form at level kmnhdn and below
-! 3. courant number based truncation at level kmxhdc and above
-! 4. increased del**2 coefficient at level kmxhd2 and above
-!
-! Computational note: this routine is multitasked by level, hence it
-! is called once for each k
-!
-! Author:
-! Original version: CCM1
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, J. Hack, August 1992
-! Reviewed: B. Boville, April 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use comspe
- use time_manager, only: get_step_size, is_first_step, get_nstep
- use eul_control_mod
- use spmd_utils, only : iam
-!-----------------------------------------------------------------------
- implicit none
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: k ! level index
-
- real(r8), intent(in) :: ztdt ! 2 times time step unless nstep=0
-!
-!---------------------------Local workspace-----------------------------
-!
- integer ir,ii ! spectral indices
- integer lmr,lmc ! spectral indices
- real(r8) dfac ! large coefficient on del^n multipliers to
-! strongly damp waves req'd by Courant limiter
- integer lm,m,n ! spectral indices
- real(r8) ztodt ! 2 delta t
- real(r8) zdt ! model time step
- real(r8) dmpini ! used to compute divergence damp rate
- real(r8) dmptim ! used to compute divergence damp rate
- real(r8) dmprat ! divergence damping rate
- real(r8) coef ! coeff. used to apply damping rate to divergence
- real(r8) two
-!
-!-----------------------------------------------------------------------
- two=2._r8
-!
-! Set the horizontal diffusion factors for each wavenumer at this level
-! depending on: whether del^2 or del^N diffusion is to be applied; and
-! whether the courant number limit is to be applied.
-!
- if (k .ge. kmnhdn) then ! Del^N diffusion factors
- do n=1,pnmax
- hdiftq(n,k) = hdfstn(n)
- hdifzd(n,k) = hdfsdn(n)
- end do
-!
-! Spectrally truncate selected levels (if courant number too large)
-!
- if (k.le. kmxhdc .and. nindex(k).le.pnmax) then
- dfac = 1000._r8
- do n=nindex(k),pnmax
- hdiftq(n,k) = dfac*hdfstn(n)
- hdifzd(n,k) = dfac*hdfsdn(n)
- end do
- end if
- else ! Del^2 diffusion factors
- if (k.le.kmxhd2) then
-!
-! Buggy sun compiler gives wrong answer for following line when
-! using -Qoption f90comp -r8const flags
-! dfac = 2.**(real(kmxhd2-k+1,r8))
- dfac = two**(real(kmxhd2-k+1,r8))
- else
- dfac = 1.0_r8
- end if
- do n=1,pnmax
- hdiftq(n,k) = dfac*hdfst2(n)
- hdifzd(n,k) = dfac*hdfsd2(n)
- end do
-!
-! Spectrally truncate selected levels (if courant number too large)
-!
- if ((k.le.kmxhdc).and.(nindex(k).le.pnmax)) then
- dfac = 1000._r8
- do n=nindex(k),pnmax
- hdiftq(n,k) = dfac*hdfst2(n)
- hdifzd(n,k) = dfac*hdfsd2(n)
- end do
- end if
- end if
-!
-! Define damping rate for divergence damper
-!
- zdt = get_step_size()
-
-! ztodt = 2._r8*zdt
-! if (is_first_step()) ztodt = .5_r8*ztodt
- ztodt = ztdt
-!
-! Initial damping rate (e-folding time = zdt) and then linearly decrease
-! to 0. over number of days specified by "divdampn".
-!
- coef = 1._r8
- if (divdampn .gt. 0.0_r8) then
- dmpini = 1._r8/(zdt)
- dmptim = divdampn*86400._r8
- dmprat = dmpini * (dmptim - real(get_nstep(),r8)*zdt) / dmptim
- if (dmprat .gt. 0.0_r8) coef = 1.0_r8 / (1.0_r8+ztodt*dmprat)
- endif
-!
-! Compute time-split implicit factors for this level
-!
- do lm=1,numm(iam)
- m=locm(lm,iam)
- lmr = lnstart(lm)
- lmc = 2*lmr
- do n=1,nlen(m)
- ir = lmc + 2*n - 1
- ii = ir + 1
-!
-! time-split implicit factors
-!
- t(ir,k) = t(ir,k)/(1._r8 + ztdt*hdiftq(n+m-1,k))
- t(ii,k) = t(ii,k)/(1._r8 + ztdt*hdiftq(n+m-1,k))
-!
- d(ir,k) = d(ir,k)*coef/(1._r8 + ztdt*hdifzd(n+m-1,k))
- d(ii,k) = d(ii,k)*coef/(1._r8 + ztdt*hdifzd(n+m-1,k))
-!
- vz(ir,k) = vz(ir,k)/(1._r8 + ztdt*hdifzd(n+m-1,k))
- vz(ii,k) = vz(ii,k)/(1._r8 + ztdt*hdifzd(n+m-1,k))
- end do
- end do
-!
- return
-end subroutine hordif
-
diff --git a/src/dynamics/eul/hrintp.F90 b/src/dynamics/eul/hrintp.F90
deleted file mode 100644
index 84ab7668b0..0000000000
--- a/src/dynamics/eul/hrintp.F90
+++ /dev/null
@@ -1,139 +0,0 @@
-
-subroutine hrintp(pf ,pkcnst ,fb ,fxl ,fxr , &
- x ,y ,dy ,wdy ,xdp , &
- ydp ,idp ,jdp ,jcen ,limitd , &
- fint ,fyb ,fyt ,fdp ,nlon , &
- nlonex )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Interpolate 2-d field to departure point using tensor product
-! Hermite cubic interpolation.
-!
-! Method:
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plon
- use scanslt, only: plond, platd, beglatex, endlatex
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-#include <parslt.h>
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: pf ! dimension (number of fields)
- integer, intent(in) :: pkcnst ! dimension (see ext. document)
-!
- real(r8), intent(in) :: fb (plond,plev,pkcnst,beglatex:endlatex) ! input fields
- real(r8), intent(in) :: fxl(plond,plev,pf ,beglatex:endlatex) ! left x-derivs
- real(r8), intent(in) :: fxr(plond,plev,pf ,beglatex:endlatex) ! right x-derivs
- real(r8), intent(in) :: x (plond,platd) ! long. grid coordinates
- real(r8), intent(in) :: y (platd) ! lat. grid coordinates
- real(r8), intent(in) :: dy (platd) ! intervals betwn lat grid pts.
- real(r8), intent(in) :: wdy(4,2,platd) ! lat. derivative weights
- real(r8), intent(in) :: xdp(plon,plev) ! x-coord of dep. pt.
- real(r8), intent(in) :: ydp(plon,plev) ! y-coord of dep. pt.
-!
- integer, intent(in) :: idp(plon,plev,4) ! i index of dep. pt.
- integer, intent(in) :: jdp(plon,plev) ! j index of dep. pt.
- integer, intent(in) :: jcen
-!
- logical, intent(in) :: limitd ! flag for shape-preservation
-!
-! Output arguments
-!
- real(r8), intent(out) :: fint(plon,plev,ppdy,pf) ! x interpolants
- real(r8), intent(out) :: fyb (plon,plev,pf) ! y-derivatives at bot of int.
- real(r8), intent(out) :: fyt (plon,plev,pf) ! y-derivatives at top of int.
- real(r8), intent(out) :: fdp (plon,plev,pf) ! horizontal interpolants
-
- integer, intent(in) :: nlon
- integer, intent(in) :: nlonex(platd)
-!
-!-----------------------------------------------------------------------
-!
-! pf Number of fields being interpolated.
-! pkcnst dimensioning construct for 3-D arrays. (see ext. document)
-! fb Extended array of data to be interpolated.
-! fxl x-derivatives at the left edge of each interval containing
-! the departure point.
-! fxr x-derivatives at the right edge of each interval containing
-! the departure point.
-! x Equally spaced x grid values in extended arrays.
-! y y-coordinate (latitude) values in the extended array.
-! dy Increment in the y-coordinate value for each interval in the
-! extended array.
-! wdy Weights for Lagrange cubic derivative estimates on the
-! unequally spaced y-grid. If grid interval j (in extended
-! array is surrounded by a 4 point stencil, then the
-! derivative at the "bottom" of the interval uses the weights
-! wdy(1,1,j),wdy(2,1,j), wdy(3,1,j), and wdy(4,1,j). The
-! derivative at the "top" of the interval uses wdy(1,2,j),
-! wdy(2,2,j), wdy(3,2,j) and wdy(4,2,j).
-! xdp xdp(i,k) is the x-coordinate of the departure point that
-! corresponds to global grid point (i,k) in the latitude slice
-! being forecasted.
-! ydp ydp(i,k) is the y-coordinate of the departure point that
-! corresponds to global grid point (i,k) in the latitude slice
-! being forecasted.
-! idp idp(i,k) is the index of the x-interval that contains the
-! departure point corresponding to global grid point (i,k) in
-! the latitude slice being forecasted.
-! Note that
-! x(idp(i,k)) .le. xdp(i,k) .lt. x(idp(i,k)+1) .
-! jdp jdp(i,k) is the index of the y-interval that contains the
-! departure point corresponding to global grid point (i,k) in
-! the latitude slice being forecasted.
-! Suppose yb contains the y-coordinates of the extended array
-! and ydp(i,k) is the y-coordinate of the departure point
-! corresponding to grid point (i,k). Then,
-! yb(jdp(i,k)) .le. ydp(i,k) .lt. yb(jdp(i,k)+1) .
-! limitd Logical flag to specify whether or not the y-derivatives will
-! be limited.
-! fint WORK ARRAY, results not used on return
-! fyb WORK ARRAY, results not used on return
-! fyt WORK ARRAY, results not used on return
-! fdp Value of field at the horizontal departure points.
-!
-!-----------------------------------------------------------------------
-!
-! Hermite cubic interpolation to the x-coordinate of each
-! departure point at each y-coordinate required to compute the
-! y-derivatives.
-!
- call herxin(pf ,pkcnst ,fb ,fxl ,fxr , &
- x ,xdp ,idp ,jdp ,fint , &
- nlon ,nlonex )
-!
-! Compute y-derivatives.
-!
- call cubydr(pf ,fint ,wdy ,jdp ,jcen , &
- fyb ,fyt ,nlon )
- if( limitd )then
- call limdy(pf ,fint ,dy ,jdp ,fyb , &
- fyt ,nlon )
- end if
-!
-! Hermite cubic interpolation in the y-coordinate.
-!
- call heryin(pf ,fint ,fyb ,fyt ,y , &
- dy ,ydp ,jdp ,fdp ,nlon )
-!
- return
-end subroutine hrintp
diff --git a/src/dynamics/eul/interp_mod.F90 b/src/dynamics/eul/interp_mod.F90
deleted file mode 100644
index a36f01d731..0000000000
--- a/src/dynamics/eul/interp_mod.F90
+++ /dev/null
@@ -1,65 +0,0 @@
-module interp_mod
- use shr_kind_mod, only : r8=>shr_kind_r8
- use cam_abortutils, only : endrun
-
- implicit none
- private
- save
-
- public :: setup_history_interpolation
- public :: set_interp_hfile
- public :: write_interpolated
-
- interface write_interpolated
- module procedure write_interpolated_scalar
- module procedure write_interpolated_vector
- end interface
- integer, parameter :: nlat=0, nlon=0
-contains
-
- subroutine setup_history_interpolation(interp_ok, mtapes, interp_output, &
- interp_info)
- use cam_history_support, only: interp_info_t
-
- ! Dummy arguments
- logical, intent(inout) :: interp_ok
- integer, intent(in) :: mtapes
- logical, intent(in) :: interp_output(:)
- type(interp_info_t), intent(inout) :: interp_info(:)
-
- interp_ok = .false.
-
- end subroutine setup_history_interpolation
-
- subroutine set_interp_hfile(hfilenum, interp_info)
- use cam_history_support, only: interp_info_t
-
- ! Dummy arguments
- integer, intent(in) :: hfilenum
- type(interp_info_t), intent(inout) :: interp_info(:)
- end subroutine set_interp_hfile
-
- subroutine write_interpolated_scalar(File, varid, fld, numlev, data_type, decomp_type)
- use pio, only : file_desc_t, var_desc_t
- use shr_kind_mod, only : r8=>shr_kind_r8
- implicit none
- type(file_desc_t), intent(inout) :: File
- type(var_desc_t), intent(inout) :: varid
- real(r8), intent(in) :: fld(:,:,:)
- integer, intent(in) :: numlev, data_type, decomp_type
- call endrun('This routine is a stub, you shouldnt get here')
-
- end subroutine write_interpolated_scalar
-
- subroutine write_interpolated_vector(File, varidu, varidv, fldu, fldv, numlev, data_type, decomp_type)
- use pio, only : file_desc_t, var_desc_t
- implicit none
- type(file_desc_t), intent(inout) :: File
- type(var_desc_t), intent(inout) :: varidu, varidv
- real(r8), intent(in) :: fldu(:,:,:), fldv(:,:,:)
- integer, intent(in) :: numlev, data_type, decomp_type
- call endrun('This routine is a stub, you shouldnt get here')
-
- end subroutine write_interpolated_vector
-
-end module interp_mod
diff --git a/src/dynamics/eul/iop.F90 b/src/dynamics/eul/iop.F90
deleted file mode 100644
index 0754030830..0000000000
--- a/src/dynamics/eul/iop.F90
+++ /dev/null
@@ -1,134 +0,0 @@
-module iop
-!-----------------------------------------------------------------------
-!BOP
-!
-! !MODULE: iop
-!
-! !DESCRIPTION:
-! iop specific routines
-!
-! !USES:
-!
- use cam_abortutils, only: endrun
- use constituents, only: pcnst
- use eul_control_mod, only: eul_nsplit
- use pmgrid, only: beglat,endlat,plon,plev
- use shr_kind_mod, only: r8 => shr_kind_r8
-!
-! !PUBLIC TYPES:
- implicit none
-
-
- private
-
- real(r8), allocatable,target :: dqfx3sav(:,:,:,:)
- real(r8), allocatable,target :: t2sav(:,:,:)
- real(r8), allocatable,target :: fusav(:,:,:)
- real(r8), allocatable,target :: fvsav(:,:,:)
- real(r8), allocatable,target :: divq3dsav(:,:,:,:)
- real(r8), allocatable,target :: divt3dsav(:,:,:)
- real(r8), allocatable,target :: divu3dsav(:,:,:)
- real(r8), allocatable,target :: divv3dsav(:,:,:)
- real(r8), allocatable,target :: betasav(:)
-
-!
-! !PUBLIC MEMBER FUNCTIONS:
- public :: init_iop_fields
- public :: iop_update_prognostics
-! !PUBLIC DATA:
- public betasav, &
- dqfx3sav, divq3dsav, divt3dsav,divu3dsav,divv3dsav,t2sav,fusav,fvsav
-
-!
-! !REVISION HISTORY:
-! Created by John Truesdale
-!
-!EOP
-!
-! !PRIVATE MEMBER FUNCTIONS:
-!-----------------------------------------------------------------------
-
-contains
- subroutine init_iop_fields()
-!------------------------------------------------------------------------------
-! Coupler for converting dynamics output variables into physics input variables
-! also writes dynamics variables (on physics grid) to history file
-!------------------------------------------------------------------------------
- implicit none
- character(len=*), parameter :: sub = "init_iop_fields"
-!-----------------------------------------------------------------------
- if (eul_nsplit>1) then
- call endrun('iop module cannot be used with eul_nsplit>1')
- endif
-
- if(.not.allocated(betasav)) then
- allocate (betasav(beglat:endlat))
- betasav(:)=0._r8
- endif
-
- if(.not.allocated(dqfx3sav)) then
- allocate (dqfx3sav(plon,plev,pcnst,beglat:endlat))
- dqfx3sav(:,:,:,:)=0._r8
- endif
- if(.not.allocated(divq3dsav)) then
- allocate (divq3dsav(plon,plev,pcnst,beglat:endlat))
- divq3dsav(:,:,:,:)=0._r8
- endif
- if(.not.allocated(divt3dsav)) then
- allocate (divt3dsav(plon,plev,beglat:endlat))
- divt3dsav(:,:,:)=0._r8
- endif
- if(.not.allocated(divu3dsav)) then
- allocate (divu3dsav(plon,plev,beglat:endlat))
- divu3dsav(:,:,:)=0._r8
- endif
- if(.not.allocated(divv3dsav)) then
- allocate (divv3dsav(plon,plev,beglat:endlat))
- divv3dsav(:,:,:)=0._r8
- endif
- if(.not.allocated(t2sav)) then
- allocate (t2sav(plon,plev,beglat:endlat)) ! temp tendency
- t2sav(:,:,:)=0._r8
- endif
- if(.not.allocated(fusav)) then
- allocate (fusav(plon,plev,beglat:endlat)) ! U wind tendency
- fusav(:,:,:)=0._r8
- endif
- if(.not.allocated(fvsav)) then
- allocate (fvsav(plon,plev,beglat:endlat)) ! v wind tendency
- fvsav(:,:,:)=0._r8
- endif
- end subroutine init_iop_fields
-
- subroutine iop_update_prognostics(timelevel,ps,t3,u3,v3,q3)
-!------------------------------------------------------------------------------
-! Copy IOP forcing fields into prognostics which for Eulerian is just PS
-!------------------------------------------------------------------------------
- use scamMod, only: tobs,uobs,vobs,qobs,psobs
- implicit none
-
- !-----------------------------------------------------------------------
-
- integer, intent(in) :: timelevel
- real(r8), optional, intent(inout) :: q3(:,:,:,:,:)
- real(r8), optional, intent(inout) :: u3(:,:,:,:)
- real(r8), optional, intent(inout) :: v3(:,:,:,:)
- real(r8), optional, intent(inout) :: t3(:,:,:,:)
- real(r8), optional, intent(inout) :: ps(:,:,:)
-
-!---------------------------Local workspace-----------------------------
- integer :: ioptop
- character(len=*), parameter :: sub = "iop_update_prognostics"
-!-----------------------------------------------------------------------
- ! set prognostics from iop
- ! Find level where tobs is no longer zero
- ioptop = minloc(tobs(:), 1, BACK=.true.)+1
- if (present(ps)) ps(1,1,timelevel) = psobs
- if (present(t3)) t3(1,ioptop:,1,timelevel) = tobs(ioptop:)
- if (present(q3)) q3(1,ioptop:,1,1,timelevel) = qobs(ioptop:)
- if (present(u3)) u3(1,ioptop:,1,timelevel) = uobs(ioptop:)
- if (present(v3)) v3(1,ioptop:,1,timelevel) = vobs(ioptop:)
-
- end subroutine iop_update_prognostics
-
-end module iop
diff --git a/src/dynamics/eul/lagyin.F90 b/src/dynamics/eul/lagyin.F90
deleted file mode 100644
index faaa5f10b3..0000000000
--- a/src/dynamics/eul/lagyin.F90
+++ /dev/null
@@ -1,151 +0,0 @@
-
-subroutine lagyin(pf ,fint ,wdy ,ydp ,jdp , &
- jcen ,fdp ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! For each departure point in the latitude slice to be forecast,
-! interpolate (using unequally spaced Lagrange cubic formulas) the
-! x interpolants to the y value of the departure point.
-!
-! Method:
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
- use scanslt, only: platd
- use cam_abortutils, only: endrun
- use cam_logfile, only: iulog
-#if (!defined UNICOSMP)
- use srchutil, only: whenieq
-#endif
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-#include <parslt.h>
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: pf ! dimension (number of fields)
-!
- real(r8), intent(in) :: fint(plon,plev,ppdy,pf) ! x-interpolants
- real(r8), intent(in) :: wdy(4,2,platd) ! y-interpolation weights
- real(r8), intent(in) :: ydp(plon,plev) ! y-coordinates of departure pts.
-!
- integer, intent(in) :: jdp(plon,plev) ! j-index of departure point coord.
- integer, intent(in) :: jcen ! current latitude
- integer, intent(in) :: nlon
-!
-! Output arguments
-!
- real(r8), intent(out) :: fdp(plon,plev,pf) ! interpolants at the horiz. depart. pt.
-!
-!-----------------------------------------------------------------------
-!
-! pf Number of fields being interpolated.
-! fint (fint(i,k,j,m),j=ppdy/2,ppdy/2 + 1) contains the x
-! interpolants at the endpoints of the y-interval that contains
-! the departure point for grid point (i,k). The last index of
-! fint allows for interpolation of multiple fields. fint is
-! generated by a call to herxin.
-! wdy Grid values and weights for Lagrange cubic interpolation on
-! the unequally spaced y-grid.
-! ydp ydp(i,k) is the y-coordinate of the departure point that
-! corresponds to global grid point (i,k) in the latitude slice
-! being forecasted.
-! jdp jdp(i,k) is the index of the y-interval that contains the
-! departure point corresponding to global grid point (i,k) in
-! the latitude slice being forecasted.
-! Note that
-! y(jdp(i,k)) .le. ydp(i,k) .lt. y(jdp(i,k)+1) .
-! fdp Horizontally interpolated field values at the departure point
-! for the latitude slice being forecasted.
-!
-!---------------------------Local variables-----------------------------
-!
- integer i,m ! indices
-!
- real(r8) ymy1 ! |
- real(r8) ymy2 ! |
- real(r8) ymy3 ! |
- real(r8) ymy4 ! |
- real(r8) coef12 ! |
- real(r8) coef34 ! | -- interpolation weights/coeffs.
- real(r8) term1(plon,plev) ! |
- real(r8) term2(plon,plev) ! |
- real(r8) term3(plon,plev) ! |
- real(r8) term4(plon,plev) ! |
-!
- integer jdpval,icount,ii,indx(plon),nval(plev)
- integer k
-!
-!-----------------------------------------------------------------------
-!
- if( ppdy .ne. 4) then
- call endrun ('LAGYIN:Error: ppdy .ne. 4')
- end if
- icount = 0
- do jdpval=jcen-2,jcen+1
- if (icount.lt.nlon*plev) then
-!$OMP PARALLEL DO PRIVATE (K, INDX, II, I, YMY3, YMY4, COEF12, YMY2, YMY1, COEF34)
- do k=1,plev
- call whenieq(nlon,jdp(1,k),1,jdpval,indx,nval(k))
-!
- do ii = 1,nval(k)
- i=indx(ii)
- ymy3 = ydp(i,k) - wdy(3,1,jdpval)
- ymy4 = ydp(i,k) - wdy(4,1,jdpval)
- coef12 = ymy3*ymy4
- ymy2 = ydp(i,k) - wdy(2,1,jdpval)
- term1(i,k) = coef12*ymy2*wdy(1,2,jdpval)
- ymy1 = ydp(i,k) - wdy(1,1,jdpval)
- term2(i,k) = coef12*ymy1*wdy(2,2,jdpval)
- coef34 = ymy1*ymy2
- term3(i,k) = coef34*ymy4*wdy(3,2,jdpval)
- term4(i,k) = coef34*ymy3*wdy(4,2,jdpval)
- end do
- end do
- do k=1,plev
- icount = icount + nval(k)
- enddo
- end if
- end do
- if (icount.ne.nlon*plev) then
- write(iulog,*)'LAGYIN: Departure pt out of bounds: jcen,icount,nlon*plev=',jcen,icount,nlon*plev
- write(iulog,*)' ****** MODEL IS BLOWING UP: CFL condition likely violated *********'
- write(iulog,*)' Possible solutions: a) reduce time step'
- write(iulog,*)' b) if initial run, set "DIVDAMPN = 1." in namelist and rerun'
- write(iulog,*)' c) modified code may be in error'
- call endrun
- end if
-!
-! Loop over fields.
-!
- do m = 1,pf
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i = 1,nlon
- fdp(i,k,m) = fint(i,k,1,m)*term1(i,k) + &
- fint(i,k,2,m)*term2(i,k) + &
- fint(i,k,3,m)*term3(i,k) + &
- fint(i,k,4,m)*term4(i,k)
- end do
- end do
- end do
-!
- return
-end subroutine lagyin
diff --git a/src/dynamics/eul/limdx.F90 b/src/dynamics/eul/limdx.F90
deleted file mode 100644
index 7d9ab9aa40..0000000000
--- a/src/dynamics/eul/limdx.F90
+++ /dev/null
@@ -1,100 +0,0 @@
-
-subroutine limdx(pidim ,ibeg ,len ,dx ,f ,&
- fxl ,fxr )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Limit the derivative estimates for data on an equally spaced grid
-! so they satisfy the SCM0 condition, that is, the spline will be
-! monotonic, but only C0 continuous on the domain
-!
-! Method:
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use scanslt, only: plond
- use cam_abortutils, only: endrun
- use cam_logfile, only: iulog
-
-!-----------------------------------------------------------------------
- implicit none
-!---------------------------Local parameters----------------------------
-!
- integer pbpts ! (length of latitude slice)*fields
- parameter(pbpts = plond)
-!
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: pidim ! vector dimension
- integer, intent(in) :: ibeg ! index of vector to begin computation
- integer, intent(in) :: len ! length of vector to compute
-!
- real(r8), intent(in) :: dx ! length of grid inteval
- real(r8), intent(in) :: f(pidim) ! field
-!
-! Input/output arguments
-!
- real(r8), intent(inout) :: fxl(pidim) ! x-derivs at left edge of interval
- real(r8), intent(inout) :: fxr(pidim) ! x-derivs at right edge of interval
-!
-!-----------------------------------------------------------------------
-!
-! pidim Length of f, fxl, and fxr.
-! ibeg First interval of grid for which derivatives are computed.
-! len Number of grid intervals for which derivatives are computed.
-! (There are pidim - 1 intervals between the pidim gridpoints
-! represented in f, fxl, and fxr.)
-! dx Value of grid spacing.
-! f Values on equally spaced grid from which derivatives fxl and
-! fxr were computed.
-! fxl fxl(i) is the limited derivative at the left edge of
-! interval
-! fxr fxr(i) is the limited derivative at the right edge of
-! interval
-!
-!---------------------------Local variables-----------------------------
-!
- integer i ! index
- integer iend ! index to end work on vector
-!
- real(r8) rdx ! 1./dx
- real(r8) deli(pbpts) ! simple linear derivative
-!
-!-----------------------------------------------------------------------
-!
- if(pidim .gt. pbpts) then
- write(iulog,9000) pidim
- call endrun
- end if
-!
- iend = ibeg + len - 1
- rdx = 1._r8/dx
-!
- do i = ibeg,iend
- deli(i) = ( f(i+1) - f(i) )*rdx
- end do
-!
-! Limiter
-!
- call scm0(len ,deli(ibeg),fxl(ibeg),fxr(ibeg))
-!
- return
-9000 format('LIMDX: Local work array DELI not dimensioned large enough' &
- ,/' Increase local parameter pbpts to ',i5)
-end subroutine limdx
-
diff --git a/src/dynamics/eul/limdy.F90 b/src/dynamics/eul/limdy.F90
deleted file mode 100644
index abcb526b35..0000000000
--- a/src/dynamics/eul/limdy.F90
+++ /dev/null
@@ -1,126 +0,0 @@
-
-subroutine limdy(pf ,fint ,dy ,jdp ,fyb ,&
- fyt ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Limit the y-derivative estimates so they satisy the SCM0 for the
-! x-interpolated data corresponding to the departure points of a single
-! latitude slice in the global grid, that is, they are monotonic, but
-! spline has only C0 continuity
-!
-! Method:
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996!
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
- use scanslt, only: platd
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-#include <parslt.h>
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: pf ! dimension (number of fields)
-!
- real(r8), intent(in) :: fint(plon,plev,ppdy,pf) ! x-interpolants
- real(r8), intent(in) :: dy(platd) ! interval lengths in lat grid
-!
- integer, intent(in) :: jdp(plon,plev) ! j-index of coord. of dep. pt.
- integer, intent(in) :: nlon
-!
-! Input/output arguments
-!
- real(r8), intent(inout) :: fyb(plon,plev,pf) ! y-derivatives at bot of interval
- real(r8), intent(inout) :: fyt(plon,plev,pf) ! y-derivatives at top of interval
-!
-!-----------------------------------------------------------------------
-!
-! pf Number of fields being interpolated.
-! fint (fint(i,k,j,m),j=1,ppdy) contains the x interpolants at each
-! latitude needed for the y derivative estimates at the
-! endpoints of the interval that contains the departure point
-! for grid point (i,k). The last index of fint allows for
-! interpolation of multiple fields. fint is generated by a
-! call to herxin.
-! dy Increment in the y-coordinate value for each interval in the
-! extended array.
-! jdp jdp(i,k) is the index of the y-interval that contains the
-! departure point corresponding to global grid point (i,k) in
-! the latitude slice being forecasted.
-! Suppose yb contains the y-coordinates of the extended array
-! and ydp(i,k) is the y-coordinate of the departure point
-! corresponding to grid point (i,k). Then,
-! yb(jdp(i,k)) .le. ydp(i,k) .lt. yb(jdp(i,k)+1) .
-! fyb fyb(i,k,.) is the limited derivative at the bot of the y
-! interval that contains the departure point of global grid
-! point (i,k).
-! fyt fyt(i,k,.) is the limited derivative at the top of the y
-! interval that contains the departure point of global grid
-! point (i,k).
-!
-!---------------------------Local variables-----------------------------
-!
- integer i,k,m ! indices
- integer jb ! index for bottom of interval
- integer jt ! index for top of interval
-!
- real(r8) rdy (plon,plev) ! 1./dy
- real(r8) deli(plon) ! simple linear derivative
-
-!GRCJR
- real(r8) fac,tmp1,tmp2
- fac = 3._r8*(1._r8 - 10._r8*epsilon(fac))
-!
-!-----------------------------------------------------------------------
-!
- jb = ppdy/2
- jt = jb + 1
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k = 1,plev
- do i = 1,nlon
- rdy(i,k) = 1._r8/dy(jdp(i,k))
- end do
- end do
-!
-! Loop over fields.
-!
- do m = 1,pf
-!$OMP PARALLEL DO PRIVATE (K, I, DELI, TMP1, TMP2)
- do k = 1,plev
- do i = 1,nlon
- deli(i) = ( fint(i,k,jt,m) - fint(i,k,jb,m) )*rdy(i,k)
-! end do
-!
-! Limiter
-!
-!GRCJR call scm0(nlon,deli,fyb(1,k,m),fyt(1,k,m))
-! do i = 1,nlon
- tmp1 = fac*deli(i)
- tmp2 = abs( tmp1 )
- if( deli(i)*fyb(i,k,m) <= 0.0_r8 ) fyb(i,k,m) = 0._r8
- if( deli(i)*fyt(i,k,m) <= 0.0_r8 ) fyt(i,k,m) = 0._r8
- if( abs( fyb(i,k,m) ) > tmp2 ) fyb(i,k,m) = tmp1
- if( abs( fyt(i,k,m) ) > tmp2 ) fyt(i,k,m) = tmp1
- end do
- end do
- end do
-!
- return
-end subroutine limdy
diff --git a/src/dynamics/eul/limdz.F90 b/src/dynamics/eul/limdz.F90
deleted file mode 100644
index d13eb4ce33..0000000000
--- a/src/dynamics/eul/limdz.F90
+++ /dev/null
@@ -1,96 +0,0 @@
-
-subroutine limdz(f ,dsig ,fst ,fsb ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Apply SCMO limiter to vertical derivative estimates on a vertical
-! slice.
-!
-! Method:
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use constituents, only: pcnst
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
- integer plevm1
- parameter( plevm1 = plev - 1 )
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- real(r8), intent(in) :: f(plon,plev,pcnst) ! input field
- real(r8), intent(in) :: dsig(plev) ! size of vertical interval
-
- integer, intent(in) :: nlon
-!
-! Input/output arguments
-!
- real(r8), intent(inout) :: fst(plon,plev,pcnst) ! z-derivative at top of interval
- real(r8), intent(inout) :: fsb(plon,plev,pcnst) ! z-derivative at bot of interval
-!
-!-----------------------------------------------------------------------
-!
-! f Field values used to compute the discrete differences for
-! each interval in the vertical grid.
-! dsig Increment in the sigma-coordinate value for each interval.
-! fst Limited derivative at the top of each interval.
-! fsb Limited derivative at the bottom of each interval.
-!
-!---------------------------Local variables-----------------------------
-!
- integer i ! longitude index
- integer k ! vertical index
- integer m ! constituent index
-!
- real(r8) rdsig ! 1./dsig
- real(r8) deli(plon) ! simple linear derivative
-
-!GRCJR
- real(r8) fac,tmp1,tmp2
- fac = 3._r8*(1._r8 - 10._r8*epsilon(fac))
-
-!
-!------------------------------Externals--------------------------------
-!
-!GRCJR external scm0
-!
-!-----------------------------------------------------------------------
-!
-! Loop over fields.
-!
- do m = 1,pcnst
-!$OMP PARALLEL DO PRIVATE (K, RDSIG, I, DELI, TMP1, TMP2)
- do k = 1,plev-1
- rdsig = 1.0_r8/dsig(k)
- do i = 1,nlon
- deli(i) = ( f(i,k+1,m) - f(i,k,m) )*rdsig
-!GRCJR end do
-!GRCJR call scm0(nlon,deli,fst(1,k,m),fsb(1,k,m) )
-!GRCJR do i=1,nlon
- tmp1 = fac*deli(i)
- tmp2 = abs( tmp1 )
- if( deli(i)*fst(i,k,m) <= 0.0_r8 ) fst(i,k,m) = 0._r8
- if( deli(i)*fsb(i,k,m) <= 0.0_r8 ) fsb(i,k,m) = 0._r8
- if( abs( fst(i,k,m) ) > tmp2 ) fst(i,k,m) = tmp1
- if( abs( fsb(i,k,m) ) > tmp2 ) fsb(i,k,m) = tmp1
- end do
- end do
- end do
-!
- return
-end subroutine limdz
diff --git a/src/dynamics/eul/linemsdyn.F90 b/src/dynamics/eul/linemsdyn.F90
deleted file mode 100644
index 1ec5104f8b..0000000000
--- a/src/dynamics/eul/linemsdyn.F90
+++ /dev/null
@@ -1,563 +0,0 @@
-
-module linemsdyn
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Control non-linear dynamical terms, FFT and combine terms
-! in preparation for Fourier -> spectral quadrature.
-!
-! Method:
-! The naming convention is as follows:
-! - prefix gr contains grid point values before FFT and Fourier
-! coefficients after
-! - t, q, d, z and ps refer to temperature, specific humidity,
-! divergence, vorticity and surface pressure
-! - "1" suffix to an array => symmetric component current latitude pair
-! - "2" suffix to an array => antisymmetric component.
-!
-! Author:
-! Original version: CCM3
-! Modified: P. Worley, October 2002
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev, plevp, plat, beglat, endlat
- use spmd_utils, only: iam
- use perf_mod
- implicit none
-
- private
-!
-! Public interfaces
-!
- public linemsdyn_bft ! Before FFT
- public linemsdyn_fft ! FFT
- public linemsdyn_aft ! After FFT
-!
-! Public data
-!
- integer, public, parameter :: plondfft = plon + 2 ! Length needed for FFT
- integer, public, parameter :: plndlvfft = plondfft*plev ! Length of multilevel 3-d field slice
-
-!
-!-----------------------------------------------------------------------
-!
-
-contains
-
-!-----------------------------------------------------------------------
-
-subroutine linemsdyn_bft( &
- lat ,nlon ,nlon_fft, &
- psm1 ,psm2 ,u3m1 , &
- u3m2 ,v3m1 ,v3m2 ,t3m1 ,t3m2 , &
- q3m1 ,etadot ,etamid , &
- ztodt , vcour ,vmax ,vmaxt , &
- detam ,t2 ,fu ,fv , &
- divm1 ,vortm2 ,divm2 ,vortm1 ,phis , &
- dpsl ,dpsm ,omga ,cwava ,flx_net , &
- fftbuf )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Control non-linear dynamical terms and fill FFT buffer
-! in preparation for Fourier -> spectral quadrature.
-!
-! Author:
-! Original version: CCM3
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-
- use constituents, only: pcnst
- use pspect, only: ptrm, ptrn
- use scanslt, only: engy1lat
- use commap, only: clat, tau, w
- use cam_history, only: outfld
- use time_manager, only: get_step_size
- use hycoef, only : hypd, hypi
- use cam_control_mod, only : adiabatic
- use eul_control_mod, only : eul_nsplit
-!
-! Input arguments
-!
- integer lat ! latitude index for S->N storage
- integer nlon
- integer, intent(in) :: nlon_fft ! first dimension of FFT work array
-
- real(r8), intent(in) :: psm1(plon) ! surface pressure (time n)
- real(r8), intent(in) :: psm2(plon) ! surface pressure (time n-1)
- real(r8), intent(in) :: u3m1(plon,plev) ! u-wind (time n)
- real(r8), intent(in) :: u3m2(plon,plev) ! u-wind (time n-1)
- real(r8), intent(in) :: v3m1(plon,plev) ! v-wind (time n)
- real(r8), intent(in) :: v3m2(plon,plev) ! v-wind (time n-1)
- real(r8), intent(in) :: t3m1(plon,plev) ! temperature (time n)
- real(r8), intent(in) :: q3m1(plon,plev,pcnst) ! constituent conc(time n: h2o first)
- real(r8), intent(inout) :: etadot(plon,plevp) ! vertical motion (3-d used by slt)
- real(r8), intent(in) :: etamid(plev) ! midpoint values of eta (a+b)
- real(r8), intent(in) :: ztodt ! 2*timestep unless nstep = 0
- real(r8), intent(in) :: detam(plev) ! maximum Courant number in vert.
-!
-! Input/Output arguments
-!
- real(r8), intent(inout) :: t2(plon,plev) ! t tend
- real(r8), intent(inout) :: fu(plon,plev) ! nonlinear term - u momentum eqn.
- real(r8), intent(inout) :: fv(plon,plev) ! nonlinear term - v momentum eqn.
- real(r8), intent(inout) :: divm1(plon,plev)
- real(r8), intent(inout) :: vortm2(plon,plev)
- real(r8), intent(inout) :: divm2(plon,plev)
- real(r8), intent(inout) :: vortm1(plon,plev)
- real(r8), intent(inout) :: phis(plon)
- real(r8), intent(inout) :: dpsl(plon)
- real(r8), intent(inout) :: dpsm(plon)
- real(r8), intent(inout) :: omga(plon,plev)
- real(r8), intent(inout) :: t3m2(plon,plev) ! temperature (time n-1)
- real(r8), intent(in) :: cwava ! weight for global water vapor int.
- real(r8), intent(in) :: flx_net(plon) ! net flux from physics
-!
-! Output arguments
-!
- real(r8), intent(out) :: fftbuf(nlon_fft,9,plev) ! buffer used for in-place FFTs
- real(r8), intent(out) :: vcour(plev) ! maximum Courant number in vert.
- real(r8), intent(out) :: vmax(plev) ! maximum wind speed squared (m^2/s^2)
- real(r8), intent(out) :: vmaxt(plev) ! maximum truncated wind speed (m^2/s^2)
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) :: dtime ! timestep size
- real(r8) :: bpstr(plon) !
- real(r8) pmid(plon,plev) ! pressure at model levels (time n)
- real(r8) rpmid(plon,plev) ! 1./pmid
- real(r8) pint(plon,plevp) ! pressure at model interfaces (n )
- real(r8) pdel(plon,plev) ! pdel(k) = pint (k+1)-pint (k)
- real(r8) rpdel(plon,plev) ! 1./pdel
- real(r8) tdyn(plon,plev) ! temperature for dynamics
- real(r8) logpsm1(plon) ! log(psm1)
- real(r8) logpsm2(plon) ! log(psm2)
- real(r8) engy(plon,plev) ! kinetic energy
- real(r8) vat (plon,plev) ! Vertical advection of temperature
- real(r8) ktoop(plon,plev) ! (Kappa*T)*(omega/P)
- real(r8) ut(plon,plev) ! (u*T) - heat flux - zonal
- real(r8) vt(plon,plev) ! (v*T) - heat flux - meridional
- real(r8) drhs(plon,plev) ! RHS of divergence eqn. (del^2 term)
- real(r8) lvcour ! local vertical courant number
- real(r8) dtdz ! dt/detam(k)
- real(r8) ddivdt(plon,plev) ! temporary workspace
- real(r8) ddpn(plon) ! complete sum of d*delta p
- real(r8) vpdsn(plon) ! complete sum V dot grad(ln(ps)) delta b
- real(r8) dpslat(plon,plev) ! Pressure gradient term
- real(r8) dpslon(plon,plev) ! Pressure gradient term
- real(r8) coslat ! cosine(latitude)
- real(r8) rcoslat ! 1./cosine(latitude)
- real(r8) rhypi ! 1./hypi(plevp)
-
- real(r8) wind ! u**2 + v**2 (m/s)
- real(r8) utfac ! asymmetric truncation factor for courant calculation
- real(r8) vtfac ! asymmetric truncation factor for courant calculation
-
- real(r8) tmp ! accumulator
- integer i,k,kk ! longitude,level,constituent indices
- integer, parameter :: tdyndex = 1 ! indices into fftbuf
- integer, parameter :: fudex = 2
- integer, parameter :: fvdex = 3
- integer, parameter :: utdex = 4
- integer, parameter :: vtdex = 5
- integer, parameter :: drhsdex = 6
- integer, parameter :: vortdyndex = 7
- integer, parameter :: divdyndex = 8
- integer, parameter :: bpstrdex = 9
-!
-! This group of arrays are glued together via equivalence to exbuf for
-! communication from LINEMSBC.
-!
-!
-!-----------------------------------------------------------------------
-!
-!
-! Compute maximum wind speed this latitude (used in Courant number estimate)
-!
- if (ptrm .lt. ptrn) then
- utfac = real(ptrm,r8)/real(ptrn,r8)
- vtfac = 1._r8
- else if (ptrn .lt. ptrm) then
- utfac = 1._r8
- vtfac = real(ptrn,r8)/real(ptrm,r8)
- else if (ptrn .eq. ptrm) then
- utfac = 1._r8
- vtfac = 1._r8
- end if
-
-!$OMP PARALLEL DO PRIVATE (K, I, WIND)
- do k=1,plev
- vmax(k) = 0._r8
- vmaxt(k) = 0._r8
- do i=1,nlon
- wind = u3m2(i,k)**2 + v3m2(i,k)**2
- vmax(k) = max(wind,vmax(k))
-!
-! Change to Courant limiter for non-triangular truncations.
-!
- wind = utfac*u3m2(i,k)**2 + vtfac*v3m2(i,k)**2
- vmaxt(k) = max(wind,vmaxt(k))
- end do
- end do
-!
-! Variables needed in tphysac
-!
- coslat = cos(clat(lat))
- rcoslat = 1._r8/coslat
-!
-! Set current time pressure arrays for model levels etc.
-!
- call plevs0(nlon,plon,plev,psm1,pint,pmid,pdel)
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- rpmid(i,k) = 1._r8/pmid(i,k)
- rpdel(i,k) = 1._r8/pdel(i,k)
- end do
- end do
-!
-! Accumulate statistics for diagnostic print
-!
- call stats(lat, pint, pdel, psm1, &
- vortm1, divm1, t3m1, q3m1(:,:,1), nlon )
-!
-! Compute log(surface pressure) for use by grmult and when adding tendency.
-!
-!$OMP PARALLEL DO PRIVATE (I)
- do i=1,nlon
- logpsm1(i) = log(psm1(i))
- logpsm2(i) = log(psm2(i))
- end do
-!
-! Compute integrals
-!
- call plevs0(nlon,plon,plev,psm2,pint,pmid,pdel)
- call engy_te (cwava,w(lat),t3m2,u3m2,v3m2,phis ,pdel, psm2, tmp ,nlon)
- engy1lat(lat) = tmp
- call plevs0(nlon,plon,plev,psm1,pint,pmid,pdel)
-!
-! Include top/bottom flux integral to energy integral
-!
- call flxint (w(lat) ,flx_net ,tmp ,nlon )
- engy1lat(lat) = engy1lat(lat) + tmp *ztodt
-!
-! Calculate non-linear terms in tendencies
-!
- if (adiabatic) t2(:,:) = 0._r8
- call outfld('FU ',fu ,plon,lat)
- call outfld('FV ',fv ,plon,lat)
- call grmult(rcoslat ,divm1 ,q3m1(1,1,1),t3m1 ,u3m1 , &
- v3m1 ,vortm1 ,t3m2 ,phis ,dpsl , &
- dpsm ,omga ,pdel ,pint(1,plevp),logpsm2, &
- logpsm1 ,rpmid ,rpdel ,fu ,fv , &
- t2 ,ut ,vt ,drhs ,pmid , &
- etadot ,etamid ,engy ,ddpn ,vpdsn , &
- dpslon ,dpslat ,vat ,ktoop ,nlon )
-!
-! Add tendencies to previous timestep values of surface pressure,
-! temperature, and (if spectral transport) moisture. Store *log* surface
-! pressure in bpstr array for transform to spectral space.
-!
- rhypi = 1._r8/hypi(plevp)
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- ddivdt(i,k) = ztodt*(0.5_r8*divm2(i,k) - divm1(i,k))
- tdyn(i,k) = t3m2(i,k) + ztodt*t2(i,k)
- end do
- end do
-
-!$OMP PARALLEL DO PRIVATE (I, K)
- do i=1,nlon
- bpstr(i) = logpsm2(i) - ztodt*(vpdsn(i)+ddpn(i))/psm1(i)
- do k=1,plev
- bpstr(i) = bpstr(i) - ddivdt(i,k)*hypd(k)*rhypi
- end do
- end do
-
-!$OMP PARALLEL DO PRIVATE (K, KK, I)
- do k=1,plev
- do kk=1,plev
- do i=1,nlon
- tdyn(i,k) = tdyn(i,k) - ddivdt(i,kk)*tau(kk,k)
- end do
- end do
- end do
-
-!
-! Compute maximum vertical Courant number this latitude.
-!
- dtime = get_step_size()/eul_nsplit
- vcour(:) = 0._r8
-!$OMP PARALLEL DO PRIVATE (K, DTDZ, I, LVCOUR)
- do k=2,plev
- dtdz = dtime/detam(k-1)
- do i=1,nlon
- lvcour = abs(etadot(i,k))*dtdz
- vcour(k) = max(lvcour,vcour(k))
- end do
- end do
-
- call outfld('ETADOT ',etadot,plon,lat)
- call outfld('VAT ',vat ,plon,lat)
- call outfld('KTOOP ',ktoop ,plon,lat)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! Apply cos(lat) to momentum terms before fft
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- fu(i,k) = coslat*fu(i,k)
- fv(i,k) = coslat*fv(i,k)
- ut(i,k) = coslat*ut(i,k)
- vt(i,k) = coslat*vt(i,k)
- end do
- end do
-
-!
-! Copy fields into FFT buffer
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
-!
-! undifferentiated terms
- fftbuf(i,tdyndex,k) = tdyn(i,k)
-! longitudinally and latitudinally differentiated terms
- fftbuf(i,fudex,k) = fu(i,k)
- fftbuf(i,fvdex,k) = fv(i,k)
- fftbuf(i,utdex,k) = ut(i,k)
- fftbuf(i,vtdex,k) = vt(i,k)
- fftbuf(i,drhsdex,k) = drhs(i,k)
-! vort,div
- fftbuf(i,vortdyndex,k) = vortm2(i,k)
- fftbuf(i,divdyndex,k) = divm2(i,k)
-!
- enddo
- enddo
-! ps
- do i=1,nlon
- fftbuf(i,bpstrdex,1) = bpstr(i)
- enddo
-
- return
-end subroutine linemsdyn_bft
-
-!-----------------------------------------------------------------------
-
-subroutine linemsdyn_fft(nlon_fft,nlon_fft2,fftbuf,fftbuf2)
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute FFT of non-linear dynamical terms
-! in preparation for Fourier -> spectral quadrature.
-!
-! Author:
-! Original version: CCM3
-! Modified: P. Worley, September 2002
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-
- use pmgrid, only: plon, plat
- use eul_control_mod, only : trig, ifax
-#if (defined SPMD)
- use mpishorthand, only: mpicom
-#endif
-
-!
-! Input arguments
-!
- integer, intent(in) :: nlon_fft ! first dimension of first FFT work array
- integer, intent(in) :: nlon_fft2 ! first dimension of second FFT work array
-!
-! Input/Output arguments
-!
- real(r8), intent(inout) :: fftbuf(nlon_fft,9,plev,beglat:endlat)
- ! buffer used for in-place FFTs
-!
-! Output arguments
-!
-#if (defined SPMD)
- real(r8), intent(out) :: fftbuf2(nlon_fft2,9,plev,plat)
- ! buffer for returning reorderd Fourier coefficients
-#else
- real(r8), intent(in) :: fftbuf2(1)
- ! buffer unused
-#endif
-!
-!---------------------------Local workspace-----------------------------
-!
-! The "work" array has a different size requirement depending upon whether
-! the proprietary Cray assembly language version of the FFT library
-! routines, or the all-Fortran version, is being used.
-!
-#if ( ! defined USEFFTLIB )
- real(r8) work((plon+1)*plev*9)
-#else
- real(r8) work((plon+1)*pcray) ! workspace array for fft991
-#endif
- integer lat ! latitude index
- integer inc ! increment for fft991
- integer isign ! flag indicates transform direction
- integer ntr ! number of transforms to perform
- integer k ! vertical level index
-!
- inc = 1
- isign = -1
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (LAT, NTR, K, WORK)
-#endif
- do lat=beglat,endlat
- ntr = 8
-!$OMP PARALLEL DO PRIVATE (K, WORK)
- do k=1,plev
- fftbuf(plon+1:nlon_fft,:,k,lat) = 0.0_r8
- call fft991(fftbuf(1,1,k,lat) ,work ,trig(1,lat),ifax(1,lat),inc ,&
- nlon_fft ,plon ,ntr ,isign )
- enddo
- ntr = 1
- fftbuf(plon+1:nlon_fft,9,1,lat) = 0.0_r8
- call fft991(fftbuf(1,9,1,lat) ,work ,trig(1,lat),ifax(1,lat),inc ,&
- nlon_fft ,plon ,ntr ,isign )
- enddo
-!
-#if ( defined SPMD )
-!
-! reorder Fourier coefficients
-!
- call t_barrierf ('sync_realloc4a', mpicom)
- call t_startf('realloc4a')
- call realloc4a(nlon_fft, nlon_fft2, fftbuf, fftbuf2)
- call t_stopf('realloc4a')
-#endif
-
- return
-end subroutine linemsdyn_fft
-
-!-----------------------------------------------------------------------
-
-subroutine linemsdyn_aft( &
- irow ,nlon_fft,fftbufs ,fftbufn , &
- grlps1 ,grt1 ,grz1 ,grd1 , &
- grfu1 ,grfv1 ,grut1 ,grvt1 ,grrh1 , &
- grlps2 ,grt2 ,grz2 ,grd2 ,grfu2 , &
- grfv2 ,grut2 ,grvt2 ,grrh2 )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Combine terms in preparation for Fourier -> spectral quadrature.
-!
-! Author:
-! Original version: CCM3
-! Modified: P. Worley, September 2002
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-
- use pspect, only: pmmax
-#if (defined SPMD)
- use comspe, only: numm, maxm
-#else
- use comspe, only: maxm
-#endif
-! Input arguments
-!
- integer, intent(in) :: irow ! latitude pair index
- integer, intent(in) :: nlon_fft ! first dimension of FFT work arrays
-
- real(r8), intent(in) :: fftbufs(nlon_fft,9,plev) ! southern latitude Fourier coefficients
- real(r8), intent(in) :: fftbufn(nlon_fft,9,plev) ! northern latitude Fourier coefficients
-!
-! Output arguments
-!
- real(r8), intent(out) :: grlps1(2*maxm) ! sym. undiff. term in lnps eqn.
- real(r8), intent(out) :: grlps2(2*maxm) ! antisym undiff. term in lnps eqn.
- real(r8), intent(out) :: grt1(2*maxm,plev) ! sym. undiff. term in t eqn.
- real(r8), intent(out) :: grt2(2*maxm,plev) ! antisym. undiff. term in t eqn.
- real(r8), intent(out) :: grz1(2*maxm,plev) ! sym. undiff. term in z eqn.
- real(r8), intent(out) :: grz2(2*maxm,plev) ! antisym. undiff. term in z eqn.
- real(r8), intent(out) :: grd1(2*maxm,plev) ! sym. undiff. term in d eqn.
- real(r8), intent(out) :: grd2(2*maxm,plev) ! antisym. undiff. term in d eqn.
- real(r8), intent(out) :: grfu1(2*maxm,plev) ! sym. nonlinear terms in u eqn.
- real(r8), intent(out) :: grfu2(2*maxm,plev) ! antisym. nonlinear terms in u eqn.
- real(r8), intent(out) :: grfv1(2*maxm,plev) ! sym. nonlinear terms in v eqn.
- real(r8), intent(out) :: grfv2(2*maxm,plev) ! antisym. nonlinear terms in v eqn.
- real(r8), intent(out) :: grut1(2*maxm,plev) ! sym. lambda deriv. term in t eqn.
- real(r8), intent(out) :: grut2(2*maxm,plev) ! antisym. lambda deriv. term in t eqn.
- real(r8), intent(out) :: grvt1(2*maxm,plev) ! sym. mu derivative term in t eqn.
- real(r8), intent(out) :: grvt2(2*maxm,plev) ! antisym. mu deriv. term in t eqn.
- real(r8), intent(out) :: grrh1(2*maxm,plev) ! sym. del**2 term in d eqn.
- real(r8), intent(out) :: grrh2(2*maxm,plev) ! antisym. del**2 term in d eqn.
-!
-!---------------------------Local workspace-----------------------------
-!
- integer i,k ! longitude,level indices
- integer mlength ! number of wavenumbers
- integer, parameter :: tdyndex = 1 ! indices into fftbuf
- integer, parameter :: fudex = 2
- integer, parameter :: fvdex = 3
- integer, parameter :: utdex = 4
- integer, parameter :: vtdex = 5
- integer, parameter :: drhsdex = 6
- integer, parameter :: vortdyndex = 7
- integer, parameter :: divdyndex = 8
- integer, parameter :: bpstrdex = 9
-!
-#if (defined SPMD)
- mlength = numm(iam)
-#else
- mlength = pmmax
-#endif
- do k=1,plev
- do i=1,2*mlength
-
- grt1(i,k) = 0.5_r8*(fftbufn(i,tdyndex,k)+fftbufs(i,tdyndex,k))
- grt2(i,k) = 0.5_r8*(fftbufn(i,tdyndex,k)-fftbufs(i,tdyndex,k))
-
- grz1(i,k) = 0.5_r8*(fftbufn(i,vortdyndex,k)+fftbufs(i,vortdyndex,k))
- grz2(i,k) = 0.5_r8*(fftbufn(i,vortdyndex,k)-fftbufs(i,vortdyndex,k))
-
- grd1(i,k) = 0.5_r8*(fftbufn(i,divdyndex,k)+fftbufs(i,divdyndex,k))
- grd2(i,k) = 0.5_r8*(fftbufn(i,divdyndex,k)-fftbufs(i,divdyndex,k))
-
- grfu1(i,k) = 0.5_r8*(fftbufn(i,fudex,k)+fftbufs(i,fudex,k))
- grfu2(i,k) = 0.5_r8*(fftbufn(i,fudex,k)-fftbufs(i,fudex,k))
-
- grfv1(i,k) = 0.5_r8*(fftbufn(i,fvdex,k)+fftbufs(i,fvdex,k))
- grfv2(i,k) = 0.5_r8*(fftbufn(i,fvdex,k)-fftbufs(i,fvdex,k))
-
- grut1(i,k) = 0.5_r8*(fftbufn(i,utdex,k)+fftbufs(i,utdex,k))
- grut2(i,k) = 0.5_r8*(fftbufn(i,utdex,k)-fftbufs(i,utdex,k))
-
- grvt1(i,k) = 0.5_r8*(fftbufn(i,vtdex,k)+fftbufs(i,vtdex,k))
- grvt2(i,k) = 0.5_r8*(fftbufn(i,vtdex,k)-fftbufs(i,vtdex,k))
-
- grrh1(i,k) = 0.5_r8*(fftbufn(i,drhsdex,k)+fftbufs(i,drhsdex,k))
- grrh2(i,k) = 0.5_r8*(fftbufn(i,drhsdex,k)-fftbufs(i,drhsdex,k))
-
- end do
- end do
-
- do i=1,2*mlength
- grlps1(i) = 0.5_r8*(fftbufn(i,bpstrdex,1)+fftbufs(i,bpstrdex,1))
- grlps2(i) = 0.5_r8*(fftbufn(i,bpstrdex,1)-fftbufs(i,bpstrdex,1))
- end do
-
- return
-end subroutine linemsdyn_aft
-
-!-----------------------------------------------------------------------
-
-end module linemsdyn
diff --git a/src/dynamics/eul/massfix.F90 b/src/dynamics/eul/massfix.F90
deleted file mode 100644
index f701e18a87..0000000000
--- a/src/dynamics/eul/massfix.F90
+++ /dev/null
@@ -1,37 +0,0 @@
-!-----------------------------------------------------------------------
-module massfix
-!-----------------------------------------------------------------------
-!
-! Purpose: Module for mass fixer, contains global integrals
-!
-!-----------------------------------------------------------------------
-!
-! Written by: Dani Bundy Coleman, Oct 2004
-!
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use constituents, only: pcnst
-
-!-----------------------------------------------------------------------
- implicit none
-!
-! By default everything is private to this module
-!
- private
-!
-! Public interfaces
-!
-
- public hw1, hw2, hw3, alpha ! Needs to be public for restart
-
-!
-! Module data
-!
- real(r8) :: hw1(pcnst) ! Pre-SLT global integral of constituent
- real(r8) :: hw2(pcnst) ! Post-SLT global integral of const.
- real(r8) :: hw3(pcnst) ! Global integral for denom. of expr. for alpha
- real(r8) :: alpha(pcnst) ! alpha(m) = ( hw1(m) - hw2(m) )/hw3(m)
-
-
-end module massfix
diff --git a/src/dynamics/eul/parslt.h b/src/dynamics/eul/parslt.h
deleted file mode 100644
index 5d9d96c317..0000000000
--- a/src/dynamics/eul/parslt.h
+++ /dev/null
@@ -1,13 +0,0 @@
-!
-! $Id$
-! $Author$
-!
-!
-! Parameters common to many SLT routines
-!
- integer ppdy ! length of interpolation grid stencil
- logical plimdr ! flag to limit derivatives
-!
- parameter(ppdy = 4, plimdr = .true.)
-!
-
diff --git a/src/dynamics/eul/pmgrid.F90 b/src/dynamics/eul/pmgrid.F90
deleted file mode 100644
index 1a9eccc8a6..0000000000
--- a/src/dynamics/eul/pmgrid.F90
+++ /dev/null
@@ -1,29 +0,0 @@
-module pmgrid
-
-! Parameters and variables related to the dynamics grid
-
- implicit none
-
- public
-
- integer, parameter :: plon = PLON ! number of longitudes
- integer, parameter :: plev = PLEV ! number of vertical levels
- integer, parameter :: plat = PLAT ! number of latitudes
- integer, parameter :: plevp = plev + 1 ! plev + 1
- integer, parameter :: plnlv = plon*plev ! Length of multilevel field slice
-
- integer :: beglat ! beg. index for latitudes owned by a given proc
- integer :: endlat ! end. index for latitudes owned by a given proc
- integer :: begirow ! beg. index for latitude pairs owned by a given proc
- integer :: endirow ! end. index for latitude pairs owned by a given proc
- integer :: numlats ! number of latitudes owned by a given proc
-
-#if ( ! defined SPMD )
- parameter (beglat = 1)
- parameter (endlat = plat)
- parameter (begirow = 1)
- parameter (endirow = plat/2)
- parameter (numlats = plat)
-#endif
-
-end module pmgrid
diff --git a/src/dynamics/eul/prognostics.F90 b/src/dynamics/eul/prognostics.F90
deleted file mode 100644
index 275635031e..0000000000
--- a/src/dynamics/eul/prognostics.F90
+++ /dev/null
@@ -1,113 +0,0 @@
-
-module prognostics
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Prognostic variables held in-core for convenient access.
-! q3 is specific humidity (water vapor) and other constituents.
-!
-! Author: G. Grant
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev, beglat, endlat
- use infnan, only: posinf, assignment(=)
- use constituents, only: pcnst
-
-
- implicit none
-
- private
-
- public ps, u3, v3, t3, q3, qminus, vort, div, dpsl, dpsm, dps, omga, phis, hadv, pdeld
- public n3, n3m1, n3m2, ptimelevels
- public initialize_prognostics
- public shift_time_indices
-
- integer, parameter :: ptimelevels = 3 ! number of time levels in the dycore
- integer :: n3 = 3
- integer :: n3m1 = 2
- integer :: n3m2 = 1
-
- real(r8), allocatable, target :: ps(:,:,:)
- real(r8), allocatable, target :: u3(:,:,:,:)
- real(r8), allocatable, target :: v3(:,:,:,:)
- real(r8), allocatable, target :: t3(:,:,:,:)
- real(r8), allocatable, target :: pdeld(:,:,:,:)
- real(r8), allocatable, target :: q3(:,:,:,:,:)
- real(r8), allocatable :: qminus(:,:,:,:)
- real(r8), allocatable :: hadv (:,:,:,:)
-
- real(r8), allocatable, target :: vort(:,:,:,:) ! vorticity
- real(r8), allocatable, target :: div(:,:,:,:) ! divergence
-
- real(r8), allocatable, target :: dpsl(:,:) ! longitudinal pressure gradient
- real(r8), allocatable, target :: dpsm(:,:) ! meridional pressure gradient
- real(r8), allocatable, target :: dps(:,:) ! pressure gradient
- real(r8), allocatable, target :: phis(:,:) ! surface geopotential
- real(r8), allocatable, target :: omga(:,:,:) ! vertical velocity
-
-CONTAINS
-
- subroutine initialize_prognostics
-!
-! Purpose: Allocate and initialize the prognostic arrays.
-!
-
- allocate (ps (plon ,beglat:endlat ,ptimelevels))
- allocate (u3 (plon,plev ,beglat:endlat,ptimelevels))
- allocate (v3 (plon,plev ,beglat:endlat,ptimelevels))
- allocate (t3 (plon,plev ,beglat:endlat,ptimelevels))
- allocate (q3 (plon,plev,pcnst,beglat:endlat,ptimelevels))
- allocate (qminus(plon,plev,pcnst,beglat:endlat ))
- allocate (hadv (plon,plev,pcnst,beglat:endlat ))
-
- allocate (vort (plon,plev,beglat:endlat,ptimelevels))
- allocate (div (plon,plev,beglat:endlat,ptimelevels))
-
- allocate (dpsl (plon,beglat:endlat))
- allocate (dpsm (plon,beglat:endlat))
- allocate (dps (plon,beglat:endlat))
- allocate (phis (plon,beglat:endlat))
- allocate (omga (plon,plev,beglat:endlat))
- allocate (pdeld (plon,plev,beglat:endlat,ptimelevels))
-
- ps(:,:,:) = posinf
- u3(:,:,:,:) = posinf
- v3(:,:,:,:) = posinf
- t3(:,:,:,:) = posinf
- pdeld(:,:,:,:) = posinf
- q3(:,:,:,:,:) = posinf
- qminus(:,:,:,:) = posinf
- hadv (:,:,:,:) = posinf
-
- vort(:,:,:,:) = posinf
- div (:,:,:,:) = posinf
-
- dpsl (:,:) = posinf
- dpsm (:,:) = posinf
- dps (:,:) = posinf
- phis (:,:) = posinf
- omga (:,:,:) = posinf
-
- return
- end subroutine initialize_prognostics
-
- subroutine shift_time_indices
-!
-! Purpose:
-! Shift the indices that keep track of which index stores
-! the relative times (current time, previous, time before previous etc).
-!
- integer :: itmp
-
- itmp = n3m2
-
- n3m2 = n3m1
- n3m1 = n3
- n3 = itmp
- end subroutine shift_time_indices
-
-end module prognostics
diff --git a/src/dynamics/eul/pspect.F90 b/src/dynamics/eul/pspect.F90
deleted file mode 100644
index f428af14fc..0000000000
--- a/src/dynamics/eul/pspect.F90
+++ /dev/null
@@ -1,18 +0,0 @@
-module pspect
-
-! Parameters related to spectral domain
-
-integer, parameter :: ptrm = PTRM ! M truncation parameter
-integer, parameter :: ptrn = PTRN ! N truncation parameter
-integer, parameter :: ptrk = PTRK ! K truncation parameter
-
-integer, parameter :: pmax = ptrn+1 ! number of diagonals
-integer, parameter :: pmaxp = pmax+1 ! Number of diagonals plus 1
-integer, parameter :: pnmax = ptrk+1 ! Number of values of N
-integer, parameter :: pmmax = ptrm+1 ! Number of values of M
-integer, parameter :: par0 = ptrm+ptrn-ptrk ! intermediate parameter
-integer, parameter :: par2 = par0*(par0+1)/2 ! intermediate parameter
-integer, parameter :: pspt = (ptrn+1)*pmmax-par2 ! Total num complex spectral coeffs retained
-integer, parameter :: psp = 2*pspt ! 2*pspt (real) size of coeff array per level
-
-end module pspect
diff --git a/src/dynamics/eul/quad.F90 b/src/dynamics/eul/quad.F90
deleted file mode 100644
index 0402a96623..0000000000
--- a/src/dynamics/eul/quad.F90
+++ /dev/null
@@ -1,278 +0,0 @@
-
-subroutine quad(lm ,zdt ,ztdtsq ,grlps1 ,grlps2 ,&
- grt1 ,grz1 ,grd1 ,grfu1 ,grfv1 ,&
- grvt1 ,grrh1 ,grt2 ,grz2 ,grd2 ,&
- grfu2 ,grfv2 ,grvt2 ,grrh2 )
-!-----------------------------------------------------------------------
-!
-! Perform gaussian quadrature for 1 Fourier wavenumber (m) to obtain the
-! spectral coefficients of ln(ps), temperature, vorticity, and divergence.
-! Add the tendency terms requiring meridional derivatives during the
-! transform.
-!
-!---------------------------Code history--------------------------------
-!
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, D. Williamson, J. Hack, August 1992
-! Reviewed: B. Boville, D. Williamson, April 1996
-! Modified: P. Worley, September 2002
-! Modified: NEC, April 2004
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use comspe
- use commap
- use physconst, only: rearth
- use spmd_utils, only : iam
- implicit none
-!
-! Input arguments
-!
- integer, intent(in) :: lm ! local Fourier wavenumber index
- real(r8), intent(in) :: zdt ! timestep(dt) unless nstep = 0
- real(r8), intent(in) :: ztdtsq(pnmax) ! 2*zdt*n(n+1)/(a^2)
-! where n IS the 2-d wavenumber
-!
-! Fourier coefficient arrays which have a latitude index on them for
-! multitasking. These arrays are defined in LINEMS and and in QUAD
-! to compute spectral coefficients. They contain a latitude index so
-! that the sums over latitude can be performed in a specified order.
-!
-! Suffixes 1 and 2 refer to symmetric and antisymmetric components
-! respectively.
-!
- real(r8), intent(in) :: grlps1(2*maxm,(plat+1)/2) ! ln(ps) - symmetric
- real(r8), intent(in) :: grlps2(2*maxm,(plat+1)/2) ! ln(ps) - antisymmetric
-!
-! symmetric components
-!
- real(r8), intent(in) :: grt1(2*maxm,plev,(plat+1)/2) ! temperature
- real(r8), intent(in) :: grz1(2*maxm,plev,(plat+1)/2) ! vorticity
- real(r8), intent(in) :: grd1(2*maxm,plev,(plat+1)/2) ! divergence
- real(r8), intent(in) :: grfu1(2*maxm,plev,(plat+1)/2) ! partial u momentum tendency (fu)
- real(r8), intent(in) :: grfv1(2*maxm,plev,(plat+1)/2) ! partial v momentum tendency (fv)
- real(r8), intent(in) :: grvt1(2*maxm,plev,(plat+1)/2) ! heat flux
- real(r8), intent(in) :: grrh1(2*maxm,plev,(plat+1)/2) ! rhs of div eqn (del^2 term)
-!
-! antisymmetric components
-!
- real(r8), intent(in) :: grt2(2*maxm,plev,(plat+1)/2) ! temperature
- real(r8), intent(in) :: grz2(2*maxm,plev,(plat+1)/2) ! vorticity
- real(r8), intent(in) :: grd2(2*maxm,plev,(plat+1)/2) ! divergence
- real(r8), intent(in) :: grfu2(2*maxm,plev,(plat+1)/2) ! partial u momentum tend (fu)
- real(r8), intent(in) :: grfv2(2*maxm,plev,(plat+1)/2) ! partial v momentum tend (fv)
- real(r8), intent(in) :: grvt2(2*maxm,plev,(plat+1)/2) ! heat flux
- real(r8), intent(in) :: grrh2(2*maxm,plev,(plat+1)/2) ! rhs of div eqn (del^2 term)
-!
-!---------------------------Local workspace-----------------------------
-!
- integer j ! latitude pair index
- integer m ! global wavenumber index
- integer n ! total wavenumber index
- integer ir,ii ! spectral indices
- integer lmr,lmc ! spectral indices
- integer k ! level index
- integer kv ! index for vectorization
-
- real(r8) zcsj ! cos**2(lat)*radius of earth
- real(r8) zrcsj ! 1./(a*cos^2(lat))
- real(r8) zdtrc ! dt/(a*cos^2(lat))
- real(r8) ztdtrc ! 2dt/(a*cos^2(lat))
- real(r8) zw((plat+1)/2) ! 2*w
- real(r8) ztdtrw((plat+1)/2) ! 2w*2dt/(a*cos^2(lat))
- real(r8) zwalp ! zw*alp
- real(r8) zwdalp ! zw*dalp
- real(r8) sqzwalp ! ztdtsq*zw*alp
-
- real(r8) tmpGR1odd(plev*6,(plat+1)/2) ! temporary space for Fourier coeffs
- real(r8) tmpGR2odd(plev*6,(plat+1)/2) !
- real(r8) tmpGR3odd(plev*6,(plat+1)/2) !
- real(r8) tmpGR1evn(plev*6,(plat+1)/2) !
- real(r8) tmpGR2evn(plev*6,(plat+1)/2) !
- real(r8) tmpGR3evn(plev*6,(plat+1)/2) !
-
- real(r8) tmpSPEodd(plev*6,2*ptrn) ! temporary space for spectral coeffs
- real(r8) tmpSPEevn(plev*6,2*ptrn) !
-!
-!-----------------------------------------------------------------------
-!
-! Compute constants
-!
-!$OMP PARALLEL DO PRIVATE(J, ZCSJ, ZRCSJ, ZDTRC, ZTDTRC)
- do j=1,plat/2
- zcsj = cs(j)*rearth
- zrcsj = 1._r8/zcsj
- zdtrc = zdt*zrcsj
- ztdtrc = 2._r8*zdtrc
- zw(j) = w(j)*2._r8
- ztdtrw(j) = ztdtrc*zw(j)
- end do
-!
-! Accumulate contributions to spectral coefficients of ln(p*), the only
-! single level field. Use symmetric or antisymmetric fourier cofficients
-! depending on whether the total wavenumber is even or odd.
-!
- m = locm(lm,iam)
- lmr = lnstart(lm)
- lmc = 2*lmr
- do n=1,2*nlen(m)
- alps(lmc+n) = 0._r8
- end do
-!$OMP PARALLEL DO PRIVATE(N, J, IR, II, ZWALP)
- do n=1,nlen(m),2
- ir = lmc + 2*n - 1
- ii = ir + 1
- do j=1,plat/2
- zwalp = zw(j)*lalp(lmr+n,j)
- alps(ir) = alps(ir) + grlps1(2*lm-1,j)*zwalp
- alps(ii) = alps(ii) + grlps1(2*lm ,j)*zwalp
- end do
- end do
-!$OMP PARALLEL DO PRIVATE(N, J, IR, II, ZWALP)
- do n=2,nlen(m),2
- ir = lmc + 2*n - 1
- ii = ir + 1
- do j=1,plat/2
- zwalp = zw(j)*lalp(lmr+n,j)
- alps(ir) = alps(ir) + grlps2(2*lm-1,j)*zwalp
- alps(ii) = alps(ii) + grlps2(2*lm ,j)*zwalp
- end do
- end do
-!
-! Accumulate contributions to spectral coefficients of the multilevel fields.
-! Use symmetric or antisymmetric fourier coefficients depending on whether
-! the total wavenumber is even or odd.
-!
-!
-! Initialize temporary storage for spectral coefficients
-!
- do n=1,nlen(m)
- do kv=1,plev*6
- tmpSPEodd(kv,n) = 0._r8
- tmpSPEevn(kv,n) = 0._r8
- end do
- end do
-!
-! Rearrange Fourier coefficients to temporal storage
-!
-!$OMP PARALLEL DO PRIVATE(J, K)
- do j = 1,plat/2
- do k=1,plev
-
- tmpGR1odd(k ,j) = grt1 (2*lm-1,k,j) ! first term for odd n
- tmpGR1odd(k+plev ,j) = grt1 (2*lm ,k,j)
- tmpGR1odd(k+plev*2,j) = grd1 (2*lm-1,k,j)
- tmpGR1odd(k+plev*3,j) = grd1 (2*lm ,k,j)
- tmpGR1odd(k+plev*4,j) = grz1 (2*lm-1,k,j)
- tmpGR1odd(k+plev*5,j) = grz1 (2*lm ,k,j)
-
- tmpGR2odd(k ,j) = grvt2(2*lm-1,k,j) ! second term for odd n
- tmpGR2odd(k+plev ,j) = grvt2(2*lm ,k,j)
- tmpGR2odd(k+plev*2,j) = -grfv2(2*lm-1,k,j)
- tmpGR2odd(k+plev*3,j) = -grfv2(2*lm ,k,j)
- tmpGR2odd(k+plev*4,j) = grfu2(2*lm-1,k,j)
- tmpGR2odd(k+plev*5,j) = grfu2(2*lm ,k,j)
-
- tmpGR3odd(k+plev*2,j) = grrh1(2*lm-1,k,j) ! additional term for odd n
- tmpGR3odd(k+plev*3,j) = grrh1(2*lm ,k,j)
-
- tmpGR1evn(k ,j) = grt2 (2*lm-1,k,j) ! first term for even n
- tmpGR1evn(k+plev ,j) = grt2 (2*lm ,k,j)
- tmpGR1evn(k+plev*2,j) = grd2 (2*lm-1,k,j)
- tmpGR1evn(k+plev*3,j) = grd2 (2*lm ,k,j)
- tmpGR1evn(k+plev*4,j) = grz2 (2*lm-1,k,j)
- tmpGR1evn(k+plev*5,j) = grz2 (2*lm ,k,j)
-
- tmpGR2evn(k ,j) = grvt1(2*lm-1,k,j) ! first term for even n
- tmpGR2evn(k+plev ,j) = grvt1(2*lm ,k,j)
- tmpGR2evn(k+plev*2,j) = -grfv1(2*lm-1,k,j)
- tmpGR2evn(k+plev*3,j) = -grfv1(2*lm ,k,j)
- tmpGR2evn(k+plev*4,j) = grfu1(2*lm-1,k,j)
- tmpGR2evn(k+plev*5,j) = grfu1(2*lm ,k,j)
-
- tmpGR3evn(k+plev*2,j) = grrh2(2*lm-1,k,j) ! additional term for even n
- tmpGR3evn(k+plev*3,j) = grrh2(2*lm ,k,j)
-
- end do
- end do
-!
-! Accumulate first and second terms
-!
-!$OMP PARALLEL DO PRIVATE(N, J, ZWDALP, ZWALP, KV)
- do n=1,nlen(m),2
- do j=1,plat/2
- zwdalp = ztdtrw(j)*ldalp(lmr+n,j)
- zwalp = zw(j) *lalp (lmr+n,j)
- do kv=1,plev*6
- tmpSPEodd(kv,n) = tmpSPEodd(kv,n) + &
- zwalp*tmpGR1odd(kv,j) + zwdalp*tmpGR2odd(kv,j)
- end do
- end do
- end do
-!$OMP PARALLEL DO PRIVATE(N, J, ZWDALP, ZWALP, KV)
- do n=2,nlen(m),2
- do j=1,plat/2
- zwdalp = ztdtrw(j)*ldalp(lmr+n,j)
- zwalp = zw(j) *lalp (lmr+n,j)
- do kv=1,plev*6
- tmpSPEevn(kv,n) = tmpSPEevn(kv,n) + &
- zwalp*tmpGR1evn(kv,j) + zwdalp*tmpGR2evn(kv,j)
- end do
- end do
- end do
-!
-! Add additional term for divergence
-!
-!$OMP PARALLEL DO PRIVATE(N, J, SQZWALP, KV)
- do n=1,nlen(m),2
- do j=1,plat/2
- sqzwalp = ztdtsq(n+m-1)*zw(j)*lalp (lmr+n,j)
- do kv=plev*2+1,plev*4
- tmpSPEodd(kv,n) = tmpSPEodd(kv,n) + sqzwalp*tmpGR3odd(kv,j)
- end do
- end do
- end do
-!$OMP PARALLEL DO PRIVATE(N, J, SQZWALP, KV)
- do n=2,nlen(m),2
- do j=1,plat/2
- sqzwalp = ztdtsq(n+m-1)*zw(j)*lalp (lmr+n,j)
- do kv=plev*2+1,plev*4
- tmpSPEevn(kv,n) = tmpSPEevn(kv,n) + sqzwalp*tmpGR3evn(kv,j)
- end do
- end do
- end do
-!
-! Save accumulated results
-!
-!$OMP PARALLEL DO PRIVATE(N, IR, II, K)
- do n=1,nlen(m),2
- ir = lmc+2*n-1
- ii = ir+1
- do k=1,plev
- t (ir,k) = tmpSPEodd(k ,n)
- t (ii,k) = tmpSPEodd(k+plev ,n)
- d (ir,k) = tmpSPEodd(k+plev*2,n)
- d (ii,k) = tmpSPEodd(k+plev*3,n)
- vz(ir,k) = tmpSPEodd(k+plev*4,n)
- vz(ii,k) = tmpSPEodd(k+plev*5,n)
- end do
- end do
-!$OMP PARALLEL DO PRIVATE(N, IR, II, K)
- do n=2,nlen(m),2
- ir = lmc+2*n-1
- ii = ir+1
- do k=1,plev
- t (ir,k) = tmpSPEevn(k ,n)
- t (ii,k) = tmpSPEevn(k+plev ,n)
- d (ir,k) = tmpSPEevn(k+plev*2,n)
- d (ii,k) = tmpSPEevn(k+plev*3,n)
- vz(ir,k) = tmpSPEevn(k+plev*4,n)
- vz(ii,k) = tmpSPEevn(k+plev*5,n)
- end do
- end do
-!
- return
-end subroutine quad
diff --git a/src/dynamics/eul/realloc4.F90 b/src/dynamics/eul/realloc4.F90
deleted file mode 100644
index 3a76a1272f..0000000000
--- a/src/dynamics/eul/realloc4.F90
+++ /dev/null
@@ -1,423 +0,0 @@
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Reallocation routines for the Fourier coefficients
-!
-! Method:
-! 1) After FFT preceding Legendre analysis, reallocate fftbuf
-! to decompose over wavenumber, recombining latitudes.
-! 2) Before FFT following Legendre synthesis, reallocate fftbuf
-! to recombine wavenumbers, decomposing over latitude.
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-subroutine realloc4a(nlon_fft_in, nlon_fft_out, fftbuf_in, fftbuf_out )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Reallocation routines for the Fourier coefficients
-!
-! Method:
-! After FFT preceding Legendre analysis, reallocate fftbuf
-! to decompose over wavenumber, combining latitudes.
-!
-! Author:
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, Oct 1995
-! J. Truesdale, Feb. 1996
-! Modified: P. Worley, September 2002, December 2003,
-! October 2004, April 2007
-!
-!-----------------------------------------------------------------------
-
-#ifdef SPMD
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use comspe
- use spmd_dyn
- use mpishorthand
- use spmd_utils, only : iam, npes, altalltoallv
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-#include <comsta.h>
-!------------------------------Parameters-------------------------------
-!
- integer, parameter :: msgtag = 1000
-!---------------------------Input arguments-----------------------------
-!
- integer, intent(in) :: nlon_fft_in ! first dimension of input array
- integer, intent(in) :: nlon_fft_out ! first dimension of output array
- real(r8), intent(in) :: fftbuf_in(nlon_fft_in,9,plev,beglat:endlat)
- ! buffer used for in-place FFTs
- real(r8), intent(out) :: fftbuf_out(nlon_fft_out,9,plev,plat)
- ! buffer used for reordered Fourier coefficients
-!
-!---------------------------Local workspace-----------------------------
-!
-! xxx_l: local decomposition
-! xxx_r: remote decomposition
- integer :: procid
- integer :: length_r, length_l
- integer :: bpos
- integer :: step, ifld, k, i
- integer :: lat_l, lat_r, beglat_r, endlat_r
-!
- logical, save :: first = .true.
- integer, allocatable, save :: sndcnts(:), sdispls(:)
- integer, allocatable, save :: rcvcnts(:), rdispls(:)
- integer, allocatable, save :: sndcnts_act(:), sdispls_act(:)
- integer, allocatable, save :: rcvcnts_act(:), rdispls_act(:)
- integer, allocatable, save :: pdispls(:)
-!-----------------------------------------------------------------------
- if (first) then
-! Compute send/recv/put counts and displacements
- allocate(sndcnts(0:npes-1))
- allocate(sdispls(0:npes-1))
- allocate(rcvcnts(0:npes-1))
- allocate(rdispls(0:npes-1))
- allocate(pdispls(0:npes-1))
-!
- sndcnts(:) = 0
- do step=1,realloc4_steps
- procid = realloc4_proc(step)
- length_r = 2*numm(procid)
- sndcnts(procid) = length_r*(plev*8 + 1)*numlats
- enddo
-!
- sdispls(0) = 0
- do procid=1,npes-1
- sdispls(procid) = sdispls(procid-1) + sndcnts(procid-1)
- enddo
-!
- length_l = 2*numm(iam)
- rcvcnts(:) = 0
- do step=1,realloc4_steps
- procid = realloc4_proc(step)
- rcvcnts(procid) = length_l*(plev*8 + 1)*nlat_p(procid)
- enddo
-!
- rdispls(0) = 0
- do procid=1,npes-1
- rdispls(procid) = rdispls(procid-1) + rcvcnts(procid-1)
- enddo
-!
- pdispls(:) = 0
- call mpialltoallint(rdispls, 1, pdispls, 1, mpicom)
-!
- allocate(sndcnts_act(0:dyn_npes-1))
- allocate(sdispls_act(0:dyn_npes-1))
- allocate(rcvcnts_act(0:dyn_npes-1))
- allocate(rdispls_act(0:dyn_npes-1))
-!
- do procid=0,dyn_npes-1
- sndcnts_act(procid) = sndcnts(procid*dyn_npes_stride)
- sdispls_act(procid) = sdispls(procid*dyn_npes_stride)
- enddo
-!
- do procid=0,dyn_npes-1
- rcvcnts_act(procid) = rcvcnts(procid*dyn_npes_stride)
- rdispls_act(procid) = rdispls(procid*dyn_npes_stride)
- enddo
-!
- first = .false.
- endif
-!
-! Copy local data to new location
- length_l = 2*numm(iam)
- do lat_l=beglat,endlat
-!$OMP PARALLEL DO PRIVATE(K, IFLD, I)
- do k=1,plev
- do ifld=1,8
- do i=1,length_l
- fftbuf_out(i,ifld,k,lat_l) = fftbuf_in(locrm(i,iam),ifld,k,lat_l)
- enddo
- enddo
- enddo
- do i=1,length_l
- fftbuf_out(i,9,1,lat_l) = fftbuf_in(locrm(i,iam),9,1,lat_l)
- enddo
- enddo
-!
-! Fill message buffer
-!$OMP PARALLEL DO PRIVATE (STEP, PROCID, LENGTH_R, BPOS, LAT_L, IFLD, K, I)
- do step=1,realloc4_steps
- procid = realloc4_proc(step)
- length_r = 2*numm(procid)
-!
- bpos = sdispls(procid)
- do lat_l=beglat,endlat
- do k=1,plev
- do ifld=1,8
- do i=1,length_r
- buf1(bpos+i) = fftbuf_in(locrm(i,procid),ifld,k,lat_l)
- enddo
- bpos = bpos+length_r
- enddo
- enddo
- do i=1,length_r
- buf1(bpos+i) = fftbuf_in(locrm(i,procid),9,1,lat_l)
- enddo
- bpos = bpos+length_r
- enddo
- enddo
-!
-! Get remote data
-!
- if (dyn_alltoall .eq. 0) then
- if (beglat <= endlat) then
- call mpialltoallv(buf1, sndcnts_act, sdispls_act, mpir8, &
- buf2, rcvcnts_act, rdispls_act, mpir8, &
- mpicom_dyn_active)
- endif
- else
- call altalltoallv(dyn_alltoall, iam, npes, &
- realloc4_steps, realloc4_proc, &
- buf1, spmdbuf_siz, sndcnts, sdispls, mpir8, &
- buf2, spmdbuf_siz, rcvcnts, rdispls, mpir8, &
- msgtag, pdispls, mpir8, buf2win, mpicom)
- endif
-!
-! Copy out of message buffers
-!
-!$OMP PARALLEL DO PRIVATE (STEP, PROCID, BEGLAT_R, ENDLAT_R, BPOS, LAT_R, IFLD, K, I)
- do step=1,realloc4_steps
- procid = realloc4_proc(step)
- beglat_r = cut(1,procid)
- endlat_r = cut(2,procid)
- bpos = rdispls(procid)
- do lat_r=beglat_r,endlat_r
- do k=1,plev
- do ifld=1,8
- do i=1,length_l
- fftbuf_out(i,ifld,k,lat_r) = buf2(bpos+i)
- enddo
- bpos = bpos+length_l
- enddo
- enddo
- do i=1,length_l
- fftbuf_out(i,9,1,lat_r) = buf2(bpos+i)
- enddo
- bpos = bpos+length_l
- enddo
-!
- end do
-#endif
- return
- end subroutine realloc4a
-
-subroutine realloc4b(nlon_fft_in, nlon_fft_out, fftbuf_in, fftbuf_out )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Reallocation routines for the Fourier coefficients
-!
-! Method:
-! Before FFT following Legendre synthesis, reallocate fftbuf
-! to combine wavenumbers, decomposing over latitude.
-!
-! Author: P. Worley, September 2002
-! Modified: P. Worley, December 2003, October 2004
-!
-!-----------------------------------------------------------------------
-
-#ifdef SPMD
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use comspe
- use spmd_dyn
- use mpishorthand
- use spmd_utils, only : iam, npes, altalltoallv
-
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-#include <comsta.h>
-!------------------------------Parameters-------------------------------
-!
- integer, parameter :: msgtag = 2000
-!---------------------------Input arguments--------------------------
-!
- integer, intent(in) :: nlon_fft_in ! first dimension of input array
- integer, intent(in) :: nlon_fft_out ! first dimension of output array
- real(r8), intent(in) :: fftbuf_in(nlon_fft_in,8,plevp,plat)
- ! buffer of Fourier coefficients to be reordered
- real(r8), intent(out) :: fftbuf_out(nlon_fft_out,8,plevp,beglat:endlat)
- ! buffer used for in-place FFTs
-!
-!---------------------------Local workspace-----------------------------
-!
-! xxx_l: local decomposition
-! xxx_r: remote decomposition
- integer :: procid
- integer :: length_r, length_l
- integer :: bpos
- integer :: step, ifld, k, i
- integer :: lat_l, lat_r
- integer :: beglat_r, endlat_r
-!
- logical, save :: first = .true.
- integer, allocatable, save :: sndcnts(:), sdispls(:)
- integer, allocatable, save :: rcvcnts(:), rdispls(:)
- integer, allocatable, save :: sndcnts_act(:), sdispls_act(:)
- integer, allocatable, save :: rcvcnts_act(:), rdispls_act(:)
- integer, allocatable, save :: pdispls(:)
-!-----------------------------------------------------------------------
- if (first) then
-! Compute send/recv counts and displacements
- allocate(sndcnts(0:npes-1))
- allocate(sdispls(0:npes-1))
- allocate(rcvcnts(0:npes-1))
- allocate(rdispls(0:npes-1))
- allocate(pdispls(0:npes-1))
-!
- length_l = 2*numm(iam)
- sndcnts(:) = 0
- do step=1,realloc4_steps
- procid = realloc4_proc(step)
- sndcnts(procid) = length_l*(8*plev + 4)*nlat_p(procid)
- enddo
-!
- sdispls(0) = 0
- do procid=1,npes-1
- sdispls(procid) = sdispls(procid-1) + sndcnts(procid-1)
- enddo
-!
- rcvcnts(:) = 0
- do step=1,realloc4_steps
- procid = realloc4_proc(step)
- length_r = 2*numm(procid)
- rcvcnts(procid) = length_r*(8*plev + 4)*numlats
- enddo
-!
- rdispls(0) = 0
- do procid=1,npes-1
- rdispls(procid) = rdispls(procid-1) + rcvcnts(procid-1)
- enddo
-!
- pdispls(:) = 0
- call mpialltoallint(rdispls, 1, pdispls, 1, mpicom)
-!
- allocate(sndcnts_act(0:dyn_npes-1))
- allocate(sdispls_act(0:dyn_npes-1))
- allocate(rcvcnts_act(0:dyn_npes-1))
- allocate(rdispls_act(0:dyn_npes-1))
-!
- do procid=0,dyn_npes-1
- sndcnts_act(procid) = sndcnts(procid*dyn_npes_stride)
- sdispls_act(procid) = sdispls(procid*dyn_npes_stride)
- enddo
-!
- do procid=0,dyn_npes-1
- rcvcnts_act(procid) = rcvcnts(procid*dyn_npes_stride)
- rdispls_act(procid) = rdispls(procid*dyn_npes_stride)
- enddo
-!
- first = .false.
- endif
-!
-! Copy local data to new location
- length_l = 2*numm(iam)
- do lat_l=beglat,endlat
-!$OMP PARALLEL DO PRIVATE(K, IFLD, I)
- do k=1,plev
- do ifld=1,8
- do i=1,length_l
- fftbuf_out(locrm(i,iam),ifld,k,lat_l) = fftbuf_in(i,ifld,k,lat_l)
- enddo
- enddo
- enddo
-!
-!$OMP PARALLEL DO PRIVATE(IFLD, I)
- do ifld=1,4
- do i=1,length_l
- fftbuf_out(locrm(i,iam),ifld,plevp,lat_l) = fftbuf_in(i,ifld,plevp,lat_l)
- enddo
- enddo
- enddo
-!
-! Fill message buffer
-!$OMP PARALLEL DO PRIVATE (STEP, PROCID, BEGLAT_R, ENDLAT_R, BPOS, LAT_R, K, IFLD, I)
- do step=1,realloc4_steps
- procid = realloc4_proc(step)
- beglat_r = cut(1,procid)
- endlat_r = cut(2,procid)
- bpos = sdispls(procid)
-!
- do lat_r=beglat_r,endlat_r
- do k=1,plev
- do ifld=1,8
- do i=1,length_l
- buf1(bpos+i) = fftbuf_in(i,ifld,k,lat_r)
- enddo
- bpos = bpos+length_l
- enddo
- enddo
- do ifld=1,4
- do i=1,length_l
- buf1(bpos+i) = fftbuf_in(i,ifld,plevp,lat_r)
- enddo
- bpos = bpos+length_l
- enddo
- enddo
- enddo
-!
-! Get remote data
-!
- if (dyn_alltoall .eq. 0) then
- if (beglat <= endlat) then
- call mpialltoallv(buf1, sndcnts_act, sdispls_act, mpir8, &
- buf2, rcvcnts_act, rdispls_act, mpir8, &
- mpicom_dyn_active)
- endif
- else
- call altalltoallv(dyn_alltoall, iam, npes, &
- realloc4_steps, realloc4_proc, &
- buf1, spmdbuf_siz, sndcnts, sdispls, mpir8, &
- buf2, spmdbuf_siz, rcvcnts, rdispls, mpir8, &
- msgtag, pdispls, mpir8, buf2win, mpicom)
- endif
-!
-! Copy out of message buffers
-!
-!$OMP PARALLEL DO PRIVATE (STEP, PROCID, LENGTH_R, BPOS, LAT_L, K, IFLD, I)
- do step=1,realloc4_steps
- procid = realloc4_proc(step)
- length_r = 2*numm(procid)
- bpos = rdispls(procid)
-
- do lat_l=beglat,endlat
- do k=1,plev
- do ifld=1,8
- do i=1,length_r
- fftbuf_out(locrm(i,procid),ifld,k,lat_l) = buf2(bpos+i)
- enddo
- bpos = bpos+length_r
- enddo
- enddo
-
- do ifld=1,4
- do i=1,length_r
- fftbuf_out(locrm(i,procid),ifld,plevp,lat_l) = buf2(bpos+i)
- enddo
- bpos = bpos+length_r
- enddo
-
- enddo
-!
- end do
-#endif
- return
- end subroutine realloc4b
-
diff --git a/src/dynamics/eul/realloc7.F90 b/src/dynamics/eul/realloc7.F90
deleted file mode 100644
index 1adc399b9f..0000000000
--- a/src/dynamics/eul/realloc7.F90
+++ /dev/null
@@ -1,213 +0,0 @@
-
-subroutine realloc7 (vmax2d, vmax2dt, vcour)
-
-!-----------------------------------------------------------------------
-!
-! Purpose: Reallocation routine for energy and log stats
-!
-! Method: MPI_Allgatherv (or point-to-point implementation)
-!
-! Author: J. Rosinski
-! Modified: P. Worley, September 2002, December 2003, October 2004
-!
-!-----------------------------------------------------------------------
-
-#ifdef SPMD
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plat, plev, numlats, beglat, endlat
- use mpishorthand
- use spmd_dyn
- use spmd_utils, only : iam, npes, altalltoallv
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-#include <comsta.h>
-!------------------------------Parameters-------------------------------
-!
- integer, parameter :: msgtag = 3000
-!---------------------------Input arguments-----------------------------
-!
- real(r8), intent(inout) :: vmax2d(plev,plat) ! Max. wind at each lvl, lat
- real(r8), intent(inout) :: vmax2dt(plev,plat) ! Max. truncated wind at each lvl, lat
- real(r8), intent(inout) :: vcour(plev,plat) ! Max. Courant number at each lvl, lat
-!
-!---------------------------Local workspace-----------------------------
-!
- integer procid
- integer bufpos
- integer procj
- integer step, j, k, jstrt
- integer beglat_p, endlat_p, numlats_p, jstrt_p
-!
- logical, save :: first = .true.
- integer, save :: sndcnt
- integer, allocatable, save :: sndcnts(:), sdispls(:)
- integer, allocatable, save :: rcvcnts(:), rdispls(:)
- integer, allocatable, save :: pdispls(:)
-!-----------------------------------------------------------------------
- if (first) then
-! Compute send/recv/put counts and displacements
- allocate(sndcnts(0:npes-1))
- allocate(sdispls(0:npes-1))
- allocate(rcvcnts(0:npes-1))
- allocate(rdispls(0:npes-1))
- allocate(pdispls(0:npes-1))
-!
-! Compute send count
- sndcnt = (plev*3 + 5)*numlats
- sndcnts(:) = 0
- do step=1,allgather_steps
- procid = allgather_proc(step)
- sndcnts(procid) = sndcnt
- enddo
-!
- sdispls(0) = 0
- do procid=1,npes-1
- sdispls(procid) = 0
- enddo
-!
-! Compute recv counts and displacements
- rcvcnts(:) = 0
- do step=1,allgather_steps
- procid = allgather_proc(step)
- rcvcnts(procid) = (plev*3 + 5)*nlat_p(procid)
- enddo
- rcvcnts(iam) = (plev*3 + 5)*numlats
-!
- rdispls(0) = 0
- do procid=1,npes-1
- rdispls(procid) = rdispls(procid-1) + rcvcnts(procid-1)
- enddo
-!
- pdispls(:) = 0
- call mpialltoallint(rdispls, 1, pdispls, 1, mpicom)
-!
- first = .false.
- endif
-!
-! Fill send buffer
- jstrt = beglat - 1
- bufpos = 0
-! psurf
- do j=1,numlats
- buf1(bufpos+j) = psurf(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-! stq
- do j=1,numlats
- buf1(bufpos+j) = stq(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-! rmst
- do j=1,numlats
- buf1(bufpos+j) = rmst(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-! rmsd
- do j=1,numlats
- buf1(bufpos+j) = rmsd(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-! rmsz
- do j=1,numlats
- buf1(bufpos+j) = rmsz(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-!vmax2d
- do j=beglat,endlat
- do k=1,plev
- buf1(bufpos+k) = vmax2d(k,j)
- enddo
- bufpos = bufpos + plev
- enddo
-! vmax2dt
- do j=beglat,endlat
- do k=1,plev
- buf1(bufpos+k) = vmax2dt(k,j)
- enddo
- bufpos = bufpos + plev
- enddo
-! vcour
- do j=beglat,endlat
- do k=1,plev
- buf1(bufpos+k) = vcour(k,j)
- enddo
- bufpos = bufpos + plev
- enddo
-!
-! Gather the data
-!
- if (dyn_allgather .eq. 0) then
- call mpiallgatherv(buf1, sndcnt, mpir8, &
- buf2, rcvcnts, rdispls, mpir8, &
- mpicom)
- else
- call altalltoallv(dyn_allgather, iam, npes, &
- allgather_steps, allgather_proc, &
- buf1, spmdbuf_siz, sndcnts, sdispls, mpir8, &
- buf2, spmdbuf_siz, rcvcnts, rdispls, mpir8, &
- msgtag, pdispls, mpir8, buf2win, mpicom)
- endif
-!
-! Copy out of message buffers
-!
-!$OMP PARALLEL DO PRIVATE (STEP, PROCID, BEGLAT_P, ENDLAT_P, NUMLATS_P, JSTRT_P, BUFPOS, J, K)
- do step=1,allgather_steps
- procid = allgather_proc(step)
- beglat_p = cut(1,procid)
- endlat_p = cut(2,procid)
- numlats_p = nlat_p(procid)
- bufpos = rdispls(procid)
-! psurf
- jstrt_p = beglat_p - 1
- do j=1,numlats_p
- psurf(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! stq
- do j=1,numlats_p
- stq(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! rmst
- do j=1,numlats_p
- rmst(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! rmsd
- do j=1,numlats_p
- rmsd(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! rmsz
- do j=1,numlats_p
- rmsz(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! vmax2d
- do j=beglat_p,endlat_p
- do k=1,plev
- vmax2d(k,j) = buf2(bufpos+k)
- enddo
- bufpos = bufpos + plev
- enddo
-! vmax2dt
- do j=beglat_p,endlat_p
- do k=1,plev
- vmax2dt(k,j) = buf2(bufpos+k)
- enddo
- bufpos = bufpos + plev
- enddo
-! vcour
- do j=beglat_p,endlat_p
- do k=1,plev
- vcour(k,j) = buf2(bufpos+k)
- enddo
- bufpos = bufpos + plev
- enddo
-!
- enddo
-#endif
- return
-end subroutine realloc7
-
diff --git a/src/dynamics/eul/restart_dynamics.F90 b/src/dynamics/eul/restart_dynamics.F90
deleted file mode 100644
index dc80678f1b..0000000000
--- a/src/dynamics/eul/restart_dynamics.F90
+++ /dev/null
@@ -1,553 +0,0 @@
-module restart_dynamics
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pio, only : var_desc_t, file_desc_t, pio_double, pio_unlimited, pio_def_var, &
- pio_def_dim, io_desc_t, pio_offset_kind, pio_put_var, pio_write_darray, &
- pio_setdebuglevel,pio_setframe, pio_initdecomp, pio_freedecomp, &
- pio_read_darray, pio_inq_varid, pio_get_var
- use prognostics, only: u3, v3, t3, q3, &
- pdeld, ps, vort, div, &
- dps, phis, dpsl, dpsm, omga, ptimelevels
- use scanslt, only: lammp, phimp, sigmp, qfcst
- use iop, only: dqfx3sav,divq3dsav,divt3dsav,t2sav,betasav,fusav,fvsav
- use cam_logfile, only: iulog
- use spmd_utils, only: masterproc
- use cam_history, only: write_camiop
-
- implicit none
- private
- save
- public :: read_restart_dynamics, init_restart_dynamics, write_restart_dynamics
-
- integer, parameter :: namlen=16
-
- type restart_var_t
- real(r8), pointer :: v1d(:) => null()
- real(r8), pointer :: v2d(:,:) => null()
- real(r8), pointer :: v3d(:, :, :) => null()
- real(r8), pointer :: v4d(:, :, :, :) => null()
- real(r8), pointer :: v5d(:, :, :, :, :) => null()
-
- type(var_desc_t), pointer :: vdesc => null()
- integer :: ndims
- integer :: timelevels
- character(len=namlen) :: name
- end type restart_var_t
-#if ( defined BFB_CAM_SCAM_IOP )
- integer, parameter :: restartvarcnt = 24
-#else
- integer, parameter :: restartvarcnt = 17
-#endif
- type(var_desc_t) :: timedesc, tmass0desc, fixmasdesc, hw1desc, hw2desc, hw3desc, alphadesc
-
- type(restart_var_t) :: restartvars(restartvarcnt)
- logical :: restart_varlist_initialized=.false.
-
-CONTAINS
-
- subroutine set_r_var(name, timelevels, index, v1, v2, v3, v4, v5)
- use cam_abortutils, only: endrun
-
- character(len=*), intent(in) :: name
- integer, intent(in) :: timelevels, index
- real(r8), target, optional :: v1(:), v2(:,:), v3(:,:,:), v4(:,:,:,:), v5(:,:,:,:,:)
-
- restartvars(index)%name=name
- restartvars(index)%timelevels = timelevels
- if(present(v1)) then
- restartvars(index)%ndims = 1
- restartvars(index)%v1d => v1
- else if(present(v2)) then
- restartvars(index)%ndims = 2
- restartvars(index)%v2d => v2
- else if(present(v3)) then
- restartvars(index)%ndims = 3
- restartvars(index)%v3d => v3
- else if(present(v4)) then
- restartvars(index)%ndims = 4
- restartvars(index)%v4d => v4
- else if(present(v5)) then
- restartvars(index)%ndims = 5
- restartvars(index)%v5d => v5
- else
- call endrun('bad ndims in call to set_r_var')
- end if
- allocate(restartvars(index)%vdesc)
-
- end subroutine set_r_var
-
- subroutine init_restart_varlist()
- use cam_abortutils, only: endrun
-
-
- integer :: vcnt=1
- integer :: i
-
-
-! Should only be called once
- if(restart_varlist_initialized) return
- restart_varlist_initialized=.true.
- call set_r_var('VORT', ptimelevels, vcnt, v4=vort)
-
- vcnt=vcnt+1
- call set_r_var('DIV', ptimelevels, vcnt, v4=div)
-
- vcnt=vcnt+1
- call set_r_var('DPSL', 1, vcnt, v2=dpsl)
-
- vcnt=vcnt+1
- call set_r_var('DPSM', 1, vcnt, v2=dpsm)
-
- vcnt=vcnt+1
- call set_r_var('DPS', 1, vcnt, v2=dps)
-
- vcnt=vcnt+1
- call set_r_var('PHIS', 1, vcnt, v2=phis)
-
- vcnt=vcnt+1
- call set_r_var('OMEGA', 1, vcnt, v3=omga)
-
- vcnt=vcnt+1
- call set_r_var('U', ptimelevels, vcnt, v4=u3)
-
- vcnt=vcnt+1
- call set_r_var('V', ptimelevels, vcnt, v4=v3)
-
- vcnt=vcnt+1
- call set_r_var('T', ptimelevels, vcnt, v4=t3)
-
- vcnt=vcnt+1
- call set_r_var('PS', ptimelevels, vcnt, v3=ps)
-
- vcnt=vcnt+1
- call set_r_var( 'Q', ptimelevels, vcnt, v5=Q3 )
-
- vcnt=vcnt+1
- call set_r_var('PDELD', ptimelevels, vcnt, v4=pdeld )
-
-
- vcnt=vcnt+1
- call set_r_var('LAMMP', 1, vcnt, v3=lammp )
- vcnt=vcnt+1
- call set_r_var('PHIMP', 1, vcnt, v3=phimp )
- vcnt=vcnt+1
- call set_r_var('SIGMP', 1, vcnt, v3=sigmp )
-
- vcnt=vcnt+1
- call set_r_var('Q_fcst', 1, vcnt, v4=qfcst )
-
-
- if (write_camiop) then
- !
- ! Write scam values
- !
- vcnt=vcnt+1
- call set_r_var('DQFX', 1, vcnt, v4=dqfx3sav )
-
- vcnt=vcnt+1
- call set_r_var('DIVQ', 1, vcnt, v4=divq3dsav )
-
- vcnt=vcnt+1
- call set_r_var('DIVT', 1, vcnt, v3=divt3dsav )
-
- vcnt=vcnt+1
- call set_r_var('T2', 1, vcnt, v3=t2sav )
-
- vcnt=vcnt+1
- call set_r_var('FU', 1, vcnt, v3=fusav )
-
- vcnt=vcnt+1
- call set_r_var('FV', 1, vcnt, v3=fvsav )
-
- vcnt=vcnt+1
- call set_r_var('BETA', 1, vcnt, v1=betasav )
-
- end if
-
- if(vcnt.ne.restartvarcnt) then
- write(iulog,*) 'vcnt= ',vcnt, ' restartvarcnt=',restartvarcnt
- call endrun('bad restartvarcnt')
- end if
-
- end subroutine init_restart_varlist
-
-
-
-subroutine init_restart_dynamics(File, dyn_out)
-
- use dyn_comp, only: dyn_export_t
- use constituents, only: pcnst
- use hycoef, only: init_restart_hycoef
- use cam_grid_support, only: cam_grid_write_attr, cam_grid_id
- use cam_grid_support, only: cam_grid_header_info_t
-
- ! Input arguments
- type(File_desc_t), intent(inout) :: File
- type(Dyn_export_t), intent(in) :: dyn_out
-
- integer :: hdimids(2)
- integer :: vdimids(2)
- character(len=namlen) :: name
-
- integer :: alldims(4), alldims2d(3), qdims(5)
- integer :: timelevels_dimid, i, ierr
- type(var_desc_t), pointer :: vdesc
- integer :: grid_id
- integer :: ndims, timelevels
- type(cam_grid_header_info_t) :: info
-
- call init_restart_hycoef(File, vdimids)
-
- ! Grid attributes
- grid_id = cam_grid_id('gauss_grid')
- call cam_grid_write_attr(File, grid_id, info)
- hdimids(1) = info%get_hdimid(1)
- hdimids(2) = info%get_hdimid(2)
-
- ierr = PIO_Def_Dim(File,'timelevels',PIO_UNLIMITED,timelevels_dimid)
-
- ierr = PIO_Def_Dim(File,'pcnst',pcnst, qdims(4))
-
- ierr = PIO_Def_Var(File, 'time', pio_double, (/timelevels_dimid/), timedesc)
-
- ierr = PIO_Def_var(File, 'tmass0', pio_double, tmass0desc)
- ierr = PIO_Def_var(File, 'fixmas', pio_double, fixmasdesc)
- ierr = PIO_Def_var(File, 'hw1', pio_double, qdims(4:4), hw1desc)
- ierr = PIO_Def_var(File, 'hw2', pio_double, qdims(4:4), hw2desc)
- ierr = PIO_Def_var(File, 'hw3', pio_double, qdims(4:4), hw3desc)
- ierr = PIO_Def_var(File, 'alpha', pio_double, qdims(4:4), alphadesc)
-
-
-
-
- alldims(1:2) = hdimids(1:2)
- alldims(3) = vdimids(1)
- alldims(4) = timelevels_dimid
-
- alldims2d(1:2) = hdimids(1:2)
- alldims2d(3) = timelevels_dimid
-
- qdims(1:2) = hdimids(1:2)
- qdims(3) = vdimids(1)
- qdims(5) = timelevels_dimid
-
- call init_restart_varlist()
-
- do i=1,restartvarcnt
-
- call get_restart_var(i, name, timelevels, ndims, vdesc)
- if(timelevels>1) then
- if(ndims==3) then
- ierr = PIO_Def_Var(File, name, pio_double, alldims2d, vdesc)
- else if(ndims==4) then
- ierr = PIO_Def_Var(File, name, pio_double, alldims, vdesc)
- else if(ndims==5) then
- ierr = PIO_Def_Var(File, name, pio_double, qdims, vdesc)
- end if
- else
- if(ndims==1) then
-! broken i think
- ierr = PIO_Def_Var(File, name, pio_double, hdimids(2:2), vdesc)
- else if(ndims==2) then
- ierr = PIO_Def_Var(File, name, pio_double, alldims2d(1:2), vdesc)
- else if(ndims==3) then
- ierr = PIO_Def_Var(File, name, pio_double, alldims(1:3), vdesc)
- else if(ndims==4) then
- ierr = PIO_Def_Var(File, name, pio_double, qdims(1:4), vdesc)
- end if
- end if
- end do
-
-
- end subroutine init_restart_dynamics
-
-
- subroutine write_restart_dynamics (File, dyn_out)
- use cam_pio_utils, only : pio_subsystem
- use dyn_comp, only : dyn_export_t
- use time_manager, only: get_curr_time, get_step_size
- use prognostics, only: ptimelevels, n3m2, n3m1, n3
- use pmgrid, only: plon, plat
- use ppgrid, only: pver
- use massfix, only: alpha, hw1, hw2, hw3
- use constituents, only: pcnst
- use eul_control_mod, only: fixmas, tmass0
- use hycoef, only: write_restart_hycoef
- use cam_grid_support, only: cam_grid_write_var
- use dyn_grid, only: dyn_decomp
-
-
- !
- ! Input arguments
- !
- type(File_desc_t), intent(inout) :: File ! Unit number
- type(Dyn_export_t), intent(in) :: dyn_out ! Not used in eul dycore
-
- !
- ! Local workspace
- !
- integer :: ierr ! error status
- integer :: ndcur, nscur
- real(r8) :: time, dtime, mold(1)
- integer :: i, s3d(1), s2d(1), ct
- integer(kind=pio_offset_kind) :: t
- type(io_desc_t) :: iodesc4d, iodesc3d, iodesc2d
- integer, pointer :: ldof(:)
- integer :: ndims, timelevels
- type(var_desc_t), pointer :: vdesc
- character(len=namlen) :: name
- !
-
- ! Write grid vars
- call cam_grid_write_var(File, dyn_decomp)
-
- call write_restart_hycoef(File)
-
- call get_curr_time(ndcur, nscur)
- dtime = get_step_size()
-
- ldof => get_restart_decomp(plon, plat, pver)
- call pio_initdecomp(pio_subsystem, pio_double, (/plon,plat,pver/), ldof, iodesc3d)
- deallocate(ldof)
-
- ldof => get_restart_decomp(plon, plat, pver*pcnst)
- call pio_initdecomp(pio_subsystem, pio_double, (/plon,plat,pver,pcnst/), ldof, iodesc4d)
- deallocate(ldof)
-
- ldof => get_restart_decomp(plon, plat, 1)
- call pio_initdecomp(pio_subsystem, pio_double, (/plon,plat/), ldof, iodesc2d)
- deallocate(ldof)
-
- ierr = pio_put_var(File, tmass0desc, (/tmass0/))
- ierr = pio_put_var(File, fixmasdesc, (/fixmas/))
-
- ierr = pio_put_var(File, hw1desc, hw1)
- ierr = pio_put_var(File, hw2desc, hw2)
- ierr = pio_put_var(File, hw3desc, hw3)
- ierr = pio_put_var(File, alphadesc, alpha)
-
-
- do t=1,ptimelevels
- time = ndcur+(real(nscur,kind=r8)+ (t-2)*dtime)/86400._r8
- ierr = pio_put_var(File,timedesc%varid, (/int(t)/), time)
- end do
- do i=1,restartvarcnt
- call get_restart_var(i, name, timelevels, ndims, vdesc)
- if(timelevels==1) then
- if(ndims==2) then
- call pio_write_darray(File, vdesc, iodesc2d, transfer(restartvars(i)%v2d(:,:), mold), ierr)
- else if(ndims==3) then
- call pio_write_darray(File, vdesc, iodesc3d, transfer(restartvars(i)%v3d(:,:,:), mold), ierr)
- else if(ndims==4) then
- call pio_write_darray(File, vdesc, iodesc4d, transfer(restartvars(i)%v4d(:,:,:,:), mold), ierr)
- end if
- else
- do t=1,timelevels
- if(t==1) ct=n3m2
- if(t==2) ct=n3m1
- if(t==3) ct=n3
-
- call pio_setframe(File, vdesc, t)
- if(ndims==3) then
- call pio_write_darray(File, vdesc, iodesc2d, transfer(restartvars(i)%v3d(:,:,ct), mold), ierr)
- else if(ndims==4) then
- call pio_write_darray(File, vdesc, iodesc3d, transfer(restartvars(i)%v4d(:,:,:,ct), mold), ierr)
- else if(ndims==5) then
- call pio_write_darray(File, vdesc, iodesc4d, transfer(restartvars(i)%v5d(:,:,:,:,ct), mold), ierr)
- end if
-
- end do
-
- end if
- end do
- call pio_freedecomp(File, iodesc2d)
- call pio_freedecomp(File, iodesc3d)
- call pio_freedecomp(File, iodesc4d)
-
- return
- end subroutine write_restart_dynamics
-
- subroutine get_restart_var(i,name, timelevels, ndims, vdesc)
- integer, intent(in) :: i
- character(len=namlen), intent(out) :: name
- integer, intent(out) :: ndims, timelevels
- type(var_desc_t), pointer :: vdesc
-
- name = restartvars(i)%name
- timelevels = restartvars(i)%timelevels
- ndims = restartvars(i)%ndims
- if(.not.associated(restartvars(i)%vdesc)) then
- allocate(restartvars(i)%vdesc)
- end if
- vdesc => restartvars(i)%vdesc
-
- end subroutine get_restart_var
-
- !#######################################################################
-
- subroutine read_restart_dynamics (File, dyn_in, dyn_out)
-
- use dyn_comp, only : dyn_init, dyn_import_t, dyn_export_t
- use cam_pio_utils, only : pio_subsystem
-
- use pmgrid, only: plon, plat, beglat, endlat
- use ppgrid, only: pver
-
- use iop, only: init_iop_fields
- use massfix, only: alpha, hw1, hw2, hw3
- use prognostics, only: n3m2, n3m1, n3
-
- use constituents, only: pcnst
- use eul_control_mod, only: fixmas, tmass0
-
- !
- ! Input arguments
- !
- type(file_desc_t), intent(inout) :: File ! PIO file handle
- type(dyn_import_t), intent(out) :: dyn_in
- type(dyn_export_t), intent(out) :: dyn_out
- !
- ! Local workspace
- !
- type(io_desc_t) :: iodesc4d, iodesc3d, iodesc2d
- integer, pointer :: ldof(:)
- integer :: ioerr ! error status
- real(r8), allocatable :: tmp(:)
- !
- integer :: dims3d(3), dims2d(2), dims4d(4)
- integer :: ierr, ct
- integer(kind=pio_offset_kind) :: t
- character(len=namlen) :: name
- integer :: ndims, timelevels, i, s2d, s3d, s4d
- type(var_desc_t), pointer :: vdesc
-
- call dyn_init(dyn_in, dyn_out)
-
- dims4d(1) = plon
- dims4d(2) = pver
- dims4d(3) = pcnst
- dims4d(4) = endlat-beglat+1
- s4d=dims4d(1)*dims4d(2)*dims4d(3)*dims4d(4)
- dims3d(1) = plon
- dims3d(2) = pver
- dims3d(3) = endlat-beglat+1
- s3d=dims3d(1)*dims3d(2)*dims3d(3)
- dims2d(1) = plon
- dims2d(2) = dims3d(3)
- s2d=dims2d(1)*dims2d(2)
-
- allocate(tmp(s4d))
-
- ldof => get_restart_decomp(plon, plat, pver*pcnst)
- call pio_initdecomp(pio_subsystem, pio_double, (/plon,plat,pver,pcnst/), ldof, iodesc4d)
- deallocate(ldof)
- ldof => get_restart_decomp(plon, plat, pver)
- call pio_initdecomp(pio_subsystem, pio_double, (/plon,plat,pver/), ldof, iodesc3d)
- deallocate(ldof)
- ldof => get_restart_decomp(plon, plat, 1)
- call pio_initdecomp(pio_subsystem, pio_double, (/plon,plat/), ldof, iodesc2d)
- deallocate(ldof)
-
- ierr = PIO_Inq_varid(File, 'tmass0', tmass0desc)
- ierr = pio_get_var(File, tmass0desc, tmass0)
- ierr = PIO_Inq_varid(File,'fixmas', fixmasdesc)
- ierr = pio_get_var(File, fixmasdesc, fixmas)
-
- ierr = PIO_Inq_varid(File, 'hw1', hw1desc)
- ierr = pio_get_var(File, hw1desc, hw1)
- ierr = PIO_Inq_varid(File, 'hw2', hw2desc)
- ierr = pio_get_var(File, hw2desc, hw2)
- ierr = PIO_Inq_varid(File, 'hw3', hw3desc)
- ierr = pio_get_var(File, hw3desc, hw3)
- ierr = PIO_Inq_varid(File,'alpha', alphadesc)
- ierr = pio_get_var(File, alphadesc, alpha)
-
- call init_restart_varlist()
-
- if (write_camiop) call init_iop_fields()
-
- do i=1,restartvarcnt
- call get_restart_var(i, name, timelevels, ndims, vdesc)
-
-
- ierr = PIO_Inq_varid(File, name, vdesc)
- if(timelevels == 1) then
- if(ndims==2) then
- call pio_read_darray(File, vdesc, iodesc2d, tmp(1:s2d), ierr)
- restartvars(i)%v2d(:,:) = reshape(tmp(1:s2d), dims2d)
- else if(ndims==3) then
- call pio_read_darray(File, restartvars(i)%vdesc, iodesc3d, tmp(1:s3d), ierr)
- restartvars(i)%v3d(:,:,:) = reshape(tmp(1:s3d), dims3d)
- else if(ndims==4) then
- call pio_read_darray(File, restartvars(i)%vdesc, iodesc4d, tmp, ierr)
- restartvars(i)%v4d(:,:,:,:) = reshape(tmp, dims4d)
- end if
-
- else
- do t=1,timelevels
- if(t==1) ct=n3m2
- if(t==2) ct=n3m1
- if(t==3) ct=n3
- call pio_setframe(File, vdesc, t)
- if(ndims==3) then
- call pio_read_darray(File, vdesc, iodesc2d, tmp(1:s2d), ierr)
- restartvars(i)%v3d(:,:,ct) = reshape(tmp(1:s2d), dims2d)
- else if(ndims==4) then
- call pio_read_darray(File, vdesc, iodesc3d, tmp(1:s3d), ierr)
- restartvars(i)%v4d(:,:,:,ct) = reshape(tmp(1:s3d), dims3d)
- else if(ndims==5) then
- call pio_read_darray(File, vdesc, iodesc4d, tmp, ierr)
- restartvars(i)%v5d(:,:,:,:,ct) = reshape(tmp, dims4d)
- end if
-
- end do
- end if
- end do
- deallocate(tmp)
- call pio_freedecomp(File, iodesc2d)
- call pio_freedecomp(File, iodesc3d)
- call pio_freedecomp(File, iodesc4d)
-
- return
-
- end subroutine read_restart_dynamics
- function get_restart_decomp(hdim1, hdim2, nlev) result(ldof)
- use dyn_grid, only : get_dyn_grid_parm
-
- integer, intent(in) :: hdim1, hdim2, nlev
- integer, pointer :: ldof(:)
- integer :: i, k, j
- integer :: lcnt
- integer, allocatable :: gcols(:)
-
- integer :: beglatxy, beglonxy, endlatxy, endlonxy, plat
-
-
- beglonxy = get_dyn_grid_parm('beglonxy')
- endlonxy = get_dyn_grid_parm('endlonxy')
- beglatxy = get_dyn_grid_parm('beglatxy')
- endlatxy = get_dyn_grid_parm('endlatxy')
-
- plat = get_dyn_grid_parm('plat')
-
-
- lcnt=(endlatxy-beglatxy+1)*nlev*(endlonxy-beglonxy+1)
-
- allocate(ldof(lcnt))
- lcnt=0
- ldof(:)=0
- do j=beglatxy,endlatxy
- do k=1,nlev
- do i=beglonxy, endlonxy
- lcnt=lcnt+1
- ldof(lcnt)=i+(j-(plat-hdim2+1))*hdim1+(k-1)*hdim1*hdim2
- end do
- end do
- end do
-
- end function get_restart_decomp
-
-
-
-
-end module restart_dynamics
diff --git a/src/dynamics/eul/scan2.F90 b/src/dynamics/eul/scan2.F90
deleted file mode 100644
index a282a92058..0000000000
--- a/src/dynamics/eul/scan2.F90
+++ /dev/null
@@ -1,774 +0,0 @@
-!-----------------------------------------------------------------------
-module scan2
-!-----------------------------------------------------------------------
-!
-! Purpose: Module for second gaussian latitude scan, to convert from
-! spectral coefficients to grid point values.
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plat, plev, plon, beglat, endlat, plevp
- use constituents, only: pcnst
- use scmforecast, only: forecast
- use perf_mod
-!-----------------------------------------------------------------------
- implicit none
-!
-! By default everything is private to this module
-!
- private
-!
-! Public interfaces
-!
- public scan2run ! Public run method
-
-!
-! Private module data
-!
- integer, parameter :: plondfft = plon + 2
-
-!-----------------------------------------------------------------------
-contains
-!-----------------------------------------------------------------------
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine scan2run (ztodt, cwava, etamid,t2 ,fu ,fv )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Second gaussian latitude scan, converts from spectral coefficients to
-! grid point values, from poles to equator, with read/calculate/write cycle.
-!
-! Method:
-! The latitude pair loop in this routine is multitasked.
-!
-! The grid point values of ps, t, u, v, z (vorticity), and d (divergence)
-! are calculated and stored for each latitude from the spectral coefficients.
-! In addition, the pressure-surface corrections to the horizontal diffusion
-! are applied and the global integrals of the constituent fields are
-! computed for the mass fixer.
-!
-! Author:
-! Original version: CCM1
-!
-!-----------------------------------------------------------------------
- use prognostics, only: ps, u3, v3, q3, t3, dps, dpsl, dpsm, vort, &
- qminus, div, n3, n3m1, n3m2, phis, omga, &
- shift_time_indices, hadv, pdeld
- use comspe, only: maxm
- use scanslt, only: hw1lat, engy1lat, qfcst
-#ifdef SPMD
- use mpishorthand, only: mpicom, mpir8
-#endif
- use physconst, only: cpair
- use scamMod, only: fixmascam,alphacam,betacam, single_column, scm_cambfb_mode
- use pspect, only: pnmax
- use tfilt_massfix, only: tfilt_massfixrun
- use massfix, only: hw1,hw2,hw3,alpha
- use cam_control_mod, only: ideal_phys, adiabatic
- use eul_control_mod, only: qmassf, tmass, tmass0, fixmas, tmassf
-
-!-----------------------------------------------------------------------
-!
-! Input arguments
-!
- real(r8), intent(in) :: ztodt ! twice the timestep unless nstep = 0
- real(r8), intent(in) :: cwava(plat) ! weight applied to global integrals
- real(r8), intent(in) :: etamid(plev) ! vertical coords at midpoints
- real(r8), optional, intent(inout) :: t2(plon,plev,beglat:endlat) ! tot dT/dt to to physics
- real(r8), optional, intent(inout) :: fu(plon,plev,beglat:endlat) ! u wind tend
- real(r8), optional, intent(inout) :: fv(plon,plev,beglat:endlat) ! v wind tend
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) engy1 ! component of global energy integral (for time step n)
- real(r8) engy2 ! component of global energy integral (for time step n+1)
- real(r8) engy2a ! component of global energy integral (for time step n+1)
- real(r8) engy2b ! component of global energy integral (for time step n+1)
- real(r8) difft ! component of global delta-temp integral ( (n+1) - n )
- real(r8) diffta ! component of global delta-temp integral ( (n+1) - n )
- real(r8) difftb ! component of global delta-temp integral ( (n+1) - n )
- real(r8) hw2a(pcnst) ! component of constituent global mass integral (mass weighting is
- ! based upon the "A" portion of the hybrid grid)
- real(r8) hw2b(pcnst) ! component of constituent global mass integral (mass weighting is
- ! based upon the "B" portion of the hybrid grid)
- real(r8) hw3a(pcnst) ! component of constituent global mass integral (mass weighting is
- ! based upon the "A" portion of the hybrid grid)
- real(r8) hw3b(pcnst) ! component of constituent global mass integral (mass weighting is
- ! based upon the "B" portion of the hybrid grid)
- real(r8) hwxa(pcnst,4)
- real(r8) hwxb(pcnst,4)
- real(r8) engy2alat(plat) ! lat contribution to total energy integral
- real(r8) engy2blat(plat) ! lat contribution to total energy integral
- real(r8) difftalat(plat) ! lat contribution to delta-temperature integral
- real(r8) difftblat(plat) ! lat contribution to delta-temperature integral
- real(r8) hw2al(pcnst,plat) ! |------------------------------------
- real(r8) hw2bl(pcnst,plat) ! | latitudinal contributions to the
- real(r8) hw3al(pcnst,plat) ! | components of global mass integrals
- real(r8) hw3bl(pcnst,plat) ! |
- real(r8) hwxal(pcnst,4,plat) ! |
- real(r8) hwxbl(pcnst,4,plat) ! |-----------------------------------
-!
-! Symmetric fourier coefficient arrays for all variables transformed
-! from spherical harmonics (see subroutine grcalc)
-!
- real(r8) grdpss(2*maxm,(plat+1)/2) ! sum(n) of K(4)*(n(n+1)/a**2)**2*2dt*lnps(n,m)*P(n,m)
- real(r8) grzs(2*maxm,plev,(plat+1)/2) ! sum(n) of z(n,m)*P(n,m)
- real(r8) grds(2*maxm,plev,(plat+1)/2) ! sum(n) of d(n,m)*P(n,m)
- real(r8) gruhs(2*maxm,plev,(plat+1)/2) ! sum(n) of K(2i)*z(n,m)*H(n,m)*a/(n(n+1))
- real(r8) grvhs(2*maxm,plev,(plat+1)/2) ! sum(n) of K(2i)*d(n,m)*H(n,m)*a/(n(n+1))
- real(r8) grths(2*maxm,plev,(plat+1)/2) ! sum(n) of K(2i)*t(n,m)*P(n,m)
- real(r8) grpss(2*maxm,(plat+1)/2) ! sum(n) of lnps(n,m)*P(n,m)
- real(r8) grus(2*maxm,plev,(plat+1)/2) ! sum(n) of z(n,m)*H(n,m)*a/(n(n+1))
- real(r8) grvs(2*maxm,plev,(plat+1)/2) ! sum(n) of d(n,m)*H(n,m)*a/(n(n+1))
- real(r8) grts(2*maxm,plev,(plat+1)/2) ! sum(n) of t(n,m)*P(n,m)
- real(r8) grpls(2*maxm,(plat+1)/2) ! sum(n) of lnps(n,m)*P(n,m)*m/a
- real(r8) grpms(2*maxm,(plat+1)/2) ! sum(n) of lnps(n,m)*H(n,m)
-!
-! Antisymmetric fourier coefficient arrays for all variables transformed
-! from spherical harmonics (see grcalc)
-!
- real(r8) grdpsa(2*maxm,(plat+1)/2) ! sum(n) of K(4)*(n(n+1)/a**2)**2*2dt*lnps(n,m)*P(n,m)
- real(r8) grza(2*maxm,plev,(plat+1)/2) ! sum(n) of z(n,m)*P(n,m)
- real(r8) grda(2*maxm,plev,(plat+1)/2) ! sum(n) of d(n,m)*P(n,m)
- real(r8) gruha(2*maxm,plev,(plat+1)/2) ! sum(n)K(2i)*z(n,m)*H(n,m)*a/(n(n+1))
- real(r8) grvha(2*maxm,plev,(plat+1)/2) ! sum(n)K(2i)*d(n,m)*H(n,m)*a/(n(n+1))
- real(r8) grtha(2*maxm,plev,(plat+1)/2) ! sum(n) of K(2i)*t(n,m)*P(n,m)
- real(r8) grpsa(2*maxm,(plat+1)/2) ! sum(n) of lnps(n,m)*P(n,m)
- real(r8) grua(2*maxm,plev,(plat+1)/2) ! sum(n) of z(n,m)*H(n,m)*a/(n(n+1))
- real(r8) grva(2*maxm,plev,(plat+1)/2) ! sum(n) of d(n,m)*H(n,m)*a/(n(n+1))
- real(r8) grta(2*maxm,plev,(plat+1)/2) ! sum(n) of t(n,m)*P(n,m)
- real(r8) grpla(2*maxm,(plat+1)/2) ! sum(n) of lnps(n,m)*P(n,m)*m/a
- real(r8) grpma(2*maxm,(plat+1)/2) ! sum(n) of lnps(n,m)*H(n,m)
- real(r8) residual ! residual energy integral
- real(r8) beta ! energy fixer coefficient
-!
- integer m,n ! indices
- integer lat,j,irow ! latitude indices
- integer nlon_fft_in ! FFT work array inner dimension
- integer nlon_fft_out ! FFT work array inner dimension
-!
-! FFT buffers
-!
- real(r8), allocatable:: fftbuf_in(:,:,:,:) ! fftbuf_in(nlon_fft_in,8,plevp,plat)
- real(r8), allocatable:: fftbuf_out(:,:,:,:) ! fftbuf_out(nlon_fft_out,8,plevp,beglat:endlat)
-!
-! Temporal space for rearranged spectral coeffs. The rearrangement will
-! be made in prepGRcalc and the rearranged coeffs will be transformed
-! to Fourier coeffs in grcalca and grcalcs.
-!
- real(r8) tmpSPEcoef(plev*24,pnmax,maxm)
-
-!
-!-----------------------------------------------------------------------
- if (.not. single_column) then
-
- call t_startf ('grcalc')
-
- call prepGRcalc(tmpSPEcoef)
-
-#if ( defined SPMD )
-
-!$OMP PARALLEL DO PRIVATE (J)
- do j=1,plat/2
- call grcalcs (j, ztodt, grts(1,1,j), grths(1,1,j), grds(1,1,j), &
- grzs(1,1,j), grus(1,1,j), gruhs(1,1,j), grvs(1,1,j), grvhs(1,1,j), &
- grpss(1,j), grdpss(1,j), grpms(1,j), grpls(1,j), tmpSPEcoef)
-
- call grcalca (j, ztodt, grta(1,1,j), grtha(1,1,j), grda(1,1,j), &
- grza(1,1,j), grua(1,1,j), gruha(1,1,j), grva(1,1,j), grvha(1,1,j), &
- grpsa(1,j), grdpsa(1,j), grpma(1,j), grpla(1,j), tmpSPEcoef)
- end do
-
-#else
-
-!$OMP PARALLEL DO PRIVATE (LAT, J)
- do lat=beglat,endlat
- if (lat > plat/2) then
- j = plat - lat + 1
- call grcalcs (j, ztodt, grts(1,1,j), grths(1,1,j), grds(1,1,j), &
- grzs(1,1,j), grus(1,1,j), gruhs(1,1,j), grvs(1,1,j), grvhs(1,1,j), &
- grpss(1,j), grdpss(1,j), grpms(1,j), grpls(1,j), tmpSPEcoef)
- else
- j = lat
- call grcalca (j, ztodt, grta(1,1,j), grtha(1,1,j), grda(1,1,j), &
- grza(1,1,j), grua(1,1,j), gruha(1,1,j), grva(1,1,j), grvha(1,1,j), &
- grpsa(1,j), grdpsa(1,j), grpma(1,j), grpla(1,j), tmpSPEcoef)
- end if
- end do
-
-#endif
-
- call t_stopf ('grcalc')
-
- call t_startf('spegrd_alloc')
-#if ( defined SPMD )
- nlon_fft_in = 2*maxm
- allocate(fftbuf_in(nlon_fft_in,8,plevp,plat))
-#else
- nlon_fft_in = 1
- allocate(fftbuf_in(1,1,1,1))
-#endif
-
- nlon_fft_out = plondfft
- allocate(fftbuf_out(nlon_fft_out,8,plevp,beglat:endlat))
- call t_stopf('spegrd_alloc')
-!
- call t_startf('spegrd_bft')
-!$OMP PARALLEL DO PRIVATE (LAT, IROW)
- do lat=1,plat
- irow = lat
- if (lat > plat/2) irow = plat - lat + 1
-#if ( defined SPMD )
- call spegrd_bft (lat, nlon_fft_in, &
- grdpss(1,irow), grzs(1,1,irow), grds(1,1,irow), gruhs(1,1,irow), grvhs(1,1,irow), &
- grths(1,1,irow), grpss(1,irow), grus(1,1,irow), grvs(1,1,irow), grts(1,1,irow), &
- grpls(1,irow), grpms(1,irow), grdpsa(1,irow), grza(1,1,irow), grda(1,1,irow), &
- gruha(1,1,irow), grvha(1,1,irow), grtha(1,1,irow), grpsa(1,irow), grua(1,1,irow), &
- grva(1,1,irow), grta(1,1,irow), grpla(1,irow), grpma(1,irow), fftbuf_in(1,1,1,lat) )
-#else
- call spegrd_bft (lat, nlon_fft_out, &
- grdpss(1,irow), grzs(1,1,irow), grds(1,1,irow), gruhs(1,1,irow), grvhs(1,1,irow), &
- grths(1,1,irow), grpss(1,irow), grus(1,1,irow), grvs(1,1,irow), grts(1,1,irow), &
- grpls(1,irow), grpms(1,irow), grdpsa(1,irow), grza(1,1,irow), grda(1,1,irow), &
- gruha(1,1,irow), grvha(1,1,irow), grtha(1,1,irow), grpsa(1,irow), grua(1,1,irow), &
- grva(1,1,irow), grta(1,1,irow), grpla(1,irow), grpma(1,irow), fftbuf_out(1,1,1,lat) )
-#endif
- end do
- call t_stopf('spegrd_bft')
-
- call t_startf('spegrd_ift')
- call spegrd_ift ( nlon_fft_in, nlon_fft_out, fftbuf_in, fftbuf_out )
- call t_stopf('spegrd_ift')
-
- call t_startf('spegrd_aft')
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (LAT)
-#endif
- do lat=beglat,endlat
- call spegrd_aft (ztodt, lat, plon, nlon_fft_out, &
- cwava(lat), qfcst(1,1,1,lat), etamid, ps(1,lat,n3), &
- u3(1,1,lat,n3), v3(1,1,lat,n3), t3(1,1,lat,n3), &
- qminus(1,1,1,lat), vort(1,1,lat,n3), div(1,1,lat,n3), hw2al(1,lat), hw2bl(1,lat), &
- hw3al(1,lat), hw3bl(1,lat), hwxal(1,1,lat), hwxbl(1,1,lat), q3(1,1,1,lat,n3m1), &
- dps(1,lat), dpsl(1,lat), dpsm(1,lat), t3(1,1,lat,n3m2) ,engy2alat(lat), engy2blat(lat), &
- difftalat(lat), difftblat(lat), phis(1,lat), fftbuf_out(1,1,1,lat) )
-
- end do
- call t_stopf('spegrd_aft')
-!
- call t_startf('spegrd_dealloc')
- deallocate(fftbuf_in)
- deallocate(fftbuf_out)
- call t_stopf('spegrd_dealloc')
-!
-#ifdef SPMD
- call t_barrierf ('sync_realloc5', mpicom)
- call t_startf('realloc5')
- call realloc5 (hw2al ,hw2bl ,hw3al ,hw3bl ,tmass , &
- hw1lat ,hwxal ,hwxbl ,engy1lat,engy2alat, &
- engy2blat, difftalat, difftblat)
- call t_stopf('realloc5')
-#endif
-
-!
-! Accumulate and normalize global integrals for mass fixer (dry mass of
-! atmosphere is held constant).
-!
- call t_startf ('scan2_single')
- tmassf = 0._r8
- do lat=1,plat
- tmassf = tmassf + tmass(lat)
- end do
- tmassf = tmassf*.5_r8
-!
-! Initialize moisture, mass, energy, and temperature integrals
-!
- hw1(1) = 0._r8
- engy1 = 0._r8
- engy2a = 0._r8
- engy2b = 0._r8
- diffta = 0._r8
- difftb = 0._r8
- do m=1,pcnst
- hw2a(m) = 0._r8
- hw2b(m) = 0._r8
- hw3a(m) = 0._r8
- hw3b(m) = 0._r8
- do n=1,4
- hwxa(m,n) = 0._r8
- hwxb(m,n) = 0._r8
- end do
- end do
-!
-! Sum water and energy integrals over latitudes
-!
- do lat=1,plat
- engy1 = engy1 + engy1lat (lat)
- engy2a = engy2a + engy2alat(lat)
- engy2b = engy2b + engy2blat(lat)
- diffta = diffta + difftalat(lat)
- difftb = difftb + difftblat(lat)
- hw1(1) = hw1(1) + hw1lat(1,lat)
- hw2a(1) = hw2a(1) + hw2al(1,lat)
- hw2b(1) = hw2b(1) + hw2bl(1,lat)
- hw3a(1) = hw3a(1) + hw3al(1,lat)
- hw3b(1) = hw3b(1) + hw3bl(1,lat)
- end do
-!
-! Compute atmospheric mass fixer coefficient
-!
- qmassf = hw1(1)
- if (adiabatic .or. ideal_phys) then
- fixmas = tmass0/tmassf
- else
- fixmas = (tmass0 + qmassf)/tmassf
- end if
-!
-! Compute alpha for water ONLY
-!
- hw2(1) = hw2a(1) + fixmas*hw2b(1)
- hw3(1) = hw3a(1) + fixmas*hw3b(1)
- if(hw3(1) .ne. 0._r8) then
- alpha(1) = ( hw1(1) - hw2(1) )/hw3(1)
- else
- alpha(1) = 1._r8
- endif
-!
-! Compute beta for energy
-!
- engy2 = engy2a + fixmas*engy2b
- difft = diffta + fixmas*difftb
- residual = (engy2 - engy1)/ztodt
- if(difft .ne. 0._r8) then
- beta = -residual*ztodt/(cpair*difft)
- else
- beta = 0._r8
- endif
-!! write(iulog,125) residual,beta
-!!125 format(' resid, beta = ',25x,2f25.15)
-!
-! Compute alpha for non-water constituents
-!
- do m = 2,pcnst
- hw1(m) = 0._r8
- do lat=1,plat
- hw1(m) = hw1(m) + hw1lat(m,lat)
- end do
- do n = 1,4
- do lat=1,plat
- hwxa(m,n) = hwxa(m,n) + hwxal(m,n,lat)
- hwxb(m,n) = hwxb(m,n) + hwxbl(m,n,lat)
- end do
- end do
- hw2a(m) = hwxa(m,1) - alpha(1)*hwxa(m,2)
- hw2b(m) = hwxb(m,1) - alpha(1)*hwxb(m,2)
- hw3a(m) = hwxa(m,3) - alpha(1)*hwxa(m,4)
- hw3b(m) = hwxb(m,3) - alpha(1)*hwxb(m,4)
- hw2 (m) = hw2a(m) + fixmas*hw2b(m)
- hw3 (m) = hw3a(m) + fixmas*hw3b(m)
- if(hw3(m) .ne. 0._r8) then
- alpha(m) = ( hw1(m) - hw2(m) )/hw3(m)
- else
- alpha(m) = 1._r8
- end if
- end do
-
- call t_stopf ('scan2_single')
-
-
-else
-
- do lat=beglat,endlat
- j = lat
- irow = lat
- if (lat > plat/2) irow = plat - lat + 1
- call forecast( lat , plon , ztodt , &
- ps(1,lat,n3m1) , ps(1,lat,n3m2) , ps(1,lat,n3) , &
- u3(1,1,j,n3) , u3(1,1,j,n3m1) , u3(1,1,j,n3m2) , &
- v3(1,1,j,n3) , v3(1,1,j,n3m1) , v3(1,1,j,n3m2) , &
- t3(1,1,j,n3) , t3(1,1,j,n3m1) , t3(1,1,j,n3m2) , &
- q3(1,1,1,j,n3) , q3(1,1,1,j,n3m1) , q3(1,1,1,j,n3m2) , &
- t2(1,1,lat) , fu(1,1,lat) , fv(1,1,lat) , &
- qminus(1,1,1,j) , qfcst(1,1,1,lat) )
- end do
-!
-! Initialize fixer variables for routines not called in scam version of
-! model
-!
- engy2alat=0._r8
- engy2blat=0._r8
- difftalat=0._r8
- difftblat=0._r8
- engy2b=0._r8
-
-!
-! read in fixer for scam
-!
- if ( scm_cambfb_mode ) then
- fixmas=fixmascam
- beta=betacam
- do m = 1, pcnst
- alpha(m)=alphacam(m)
- end do
- else
- fixmas=1._r8
- beta=0._r8
- alpha(:)=0._r8
- endif
-endif ! if not SCAM
-
-call t_startf ('tfilt_massfix')
-
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (LAT)
-#endif
- do lat=beglat,endlat
-
- call tfilt_massfixrun (ztodt, lat, u3(1,1,lat,n3m1),u3(1,1,lat,n3), &
- v3(1,1,lat,n3m1), v3(1,1,lat,n3), t3(1,1,lat,n3m1), t3(1,1,lat,n3), &
- q3(1,1,1,lat,n3m1), &
- q3(1,1,1,lat,n3), ps(1,lat,n3m1), ps(1,lat,n3), alpha, &
- etamid, qfcst(1,1,1,lat), vort(1,1,lat,n3), div(1,1,lat,n3), &
- vort(1,1,lat,n3m2), &
- div(1,1,lat,n3m2), qminus(1,1,1,lat), ps(1,lat,n3m2), &
- u3(1,1,lat,n3m2), &
- v3(1,1,lat,n3m2), t3(1,1,lat,n3m2), q3(1,1,1,lat,n3m2), vort(1,1,lat,n3m1), &
- div(1,1,lat,n3m1), &
- omga(1,1,lat), dpsl(1,lat), dpsm(1,lat), beta, hadv(1,1,1,lat) ,plon, &
- pdeld(:,:,lat,n3), pdeld(:,:,lat,n3m1), pdeld(:,:,lat,n3m2))
-
- end do
- call t_stopf ('tfilt_massfix')
-!
-! Shift time pointers
-!
- call shift_time_indices ()
-
- return
-end subroutine scan2run
-
-!
-!-----------------------------------------------------------------------
-!
-
-#ifdef SPMD
-subroutine realloc5 (hw2al ,hw2bl ,hw3al ,hw3bl ,tmass , &
- hw1lat ,hwxal ,hwxbl ,engy1lat,engy2alat, &
- engy2blat,difftalat,difftblat )
-!-----------------------------------------------------------------------
-!
-! Purpose: Reallocation routine for slt variables.
-!
-! Method: MPI_Allgatherv (or point-to-point implementation)
-!
-! Author: J. Rosinski
-! Standardized: J. Rosinski, Oct 1995
-! J. Truesdale, Feb. 1996
-! Modified: P. Worley, December 2003, October 2004
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
- use pmgrid, only: numlats, plat
- use mpishorthand, only: mpicom, mpir8
- use spmd_dyn
- use spmd_utils, only : iam, npes, altalltoallv
-!---------------------------------Parameters----------------------------------
- integer, parameter :: msgtag = 5000
-!---------------------------------Commons-------------------------------------
-#include <comsta.h>
-!-----------------------------------------------------------------------
-!
-! Input arguments
-!
- real(r8), intent(inout) :: hw2al(pcnst,plat)
- real(r8), intent(inout) :: hw2bl(pcnst,plat)
- real(r8), intent(inout) :: hw3al(pcnst,plat)
- real(r8), intent(inout) :: hw3bl(pcnst,plat)
- real(r8), intent(inout) :: tmass (plat)
- real(r8), intent(inout) :: hw1lat(pcnst,plat)
- real(r8), intent(inout) :: hwxal(pcnst,4,plat)
- real(r8), intent(inout) :: hwxbl(pcnst,4,plat)
-! ! -
- real(r8), intent(inout) :: engy1lat (plat) ! lat contribution to total energy (n)
- real(r8), intent(inout) :: engy2alat(plat) ! lat contribution to total energy (n+1)
- real(r8), intent(inout) :: engy2blat(plat) ! lat contribution to total energy (n+1)
- real(r8), intent(inout) :: difftalat(plat) ! lat contribution to delta-T integral
- real(r8), intent(inout) :: difftblat(plat) ! lat contribution to delta-T integral
-!
-!---------------------------Local workspace-----------------------------
-!
- integer procid
- integer bufpos
- integer procj
- integer step, i, j, m, jstrt
- integer beglat_p, endlat_p, numlats_p, jstrt_p
-!
- logical, save :: first = .true.
- integer, save :: sndcnt
- integer, allocatable, save :: sndcnts(:), sdispls(:)
- integer, allocatable, save :: rcvcnts(:), rdispls(:)
- integer, allocatable, save :: pdispls(:)
-!-----------------------------------------------------------------------
- if (first) then
-! Compute send/recv/put counts and displacements
- allocate(sndcnts(0:npes-1))
- allocate(sdispls(0:npes-1))
- allocate(rcvcnts(0:npes-1))
- allocate(rdispls(0:npes-1))
- allocate(pdispls(0:npes-1))
-!
-! Compute send count
- sndcnt = (pcnst*(5 + 2*4) + 6)*numlats
- sndcnts(:) = 0
- do step=1,allgather_steps
- procid = allgather_proc(step)
- sndcnts(procid) = sndcnt
- enddo
-!
- sdispls(0) = 0
- do procid=1,npes-1
- sdispls(procid) = 0
- enddo
-!
-! Compute recv counts and displacements
- rcvcnts(:) = 0
- do step=1,allgather_steps
- procid = allgather_proc(step)
- rcvcnts(procid) = (pcnst*(5 + 2*4) + 6)*nlat_p(procid)
- enddo
- rcvcnts(iam) = (pcnst*(5 + 2*4) + 6)*numlats
-!
- rdispls(0) = 0
- do procid=1,npes-1
- rdispls(procid) = rdispls(procid-1) + rcvcnts(procid-1)
- enddo
-!
- pdispls(:) = 0
- call mpialltoallint(rdispls, 1, pdispls, 1, mpicom)
-!
- first = .false.
- endif
-!
-! Fill send buffer
- jstrt = beglat - 1
- bufpos = 0
-! tmass
- do j=1,numlats
- buf1(bufpos+j) = tmass(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-! engy1lat
- do j=1,numlats
- buf1(bufpos+j) = engy1lat(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-! engy2alat
- do j=1,numlats
- buf1(bufpos+j) = engy2alat(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-! engy2blat
- do j=1,numlats
- buf1(bufpos+j) = engy2blat(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-! difftalat
- do j=1,numlats
- buf1(bufpos+j) = difftalat(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-! difftblat
- do j=1,numlats
- buf1(bufpos+j) = difftblat(jstrt+j)
- enddo
- bufpos = bufpos + numlats
-!hw1lat
- do j=beglat,endlat
- do m=1,pcnst
- buf1(bufpos+m) = hw1lat(m,j)
- enddo
- bufpos = bufpos + pcnst
- enddo
-!hw2al
- do j=beglat,endlat
- do m=1,pcnst
- buf1(bufpos+m) = hw2al(m,j)
- enddo
- bufpos = bufpos + pcnst
- enddo
-!hw2bl
- do j=beglat,endlat
- do m=1,pcnst
- buf1(bufpos+m) = hw2bl(m,j)
- enddo
- bufpos = bufpos + pcnst
- enddo
-!hw3al
- do j=beglat,endlat
- do m=1,pcnst
- buf1(bufpos+m) = hw3al(m,j)
- enddo
- bufpos = bufpos + pcnst
- enddo
-!hw3bl
- do j=beglat,endlat
- do m=1,pcnst
- buf1(bufpos+m) = hw3bl(m,j)
- enddo
- bufpos = bufpos + pcnst
- enddo
-!hwxal
- do j=beglat,endlat
- do i=1,4
- do m=1,pcnst
- buf1(bufpos+m) = hwxal(m,i,j)
- enddo
- bufpos = bufpos + pcnst
- enddo
- enddo
-!hwxbl
- do j=beglat,endlat
- do i=1,4
- do m=1,pcnst
- buf1(bufpos+m) = hwxbl(m,i,j)
- enddo
- bufpos = bufpos + pcnst
- enddo
- enddo
-!
-! Gather the data
-!
- if (dyn_allgather .eq. 0) then
- call mpiallgatherv(buf1, sndcnt, mpir8, &
- buf2, rcvcnts, rdispls, mpir8, &
- mpicom)
- else
- call altalltoallv(dyn_allgather, iam, npes, &
- allgather_steps, allgather_proc, &
- buf1, spmdbuf_siz, sndcnts, sdispls, mpir8, &
- buf2, spmdbuf_siz, rcvcnts, rdispls, mpir8, &
- msgtag, pdispls, mpir8, buf2win, mpicom)
- endif
-!
-! Copy out of message buffers
-!
-!$OMP PARALLEL DO PRIVATE (STEP, PROCID, BEGLAT_P, ENDLAT_P, NUMLATS_P, BUFPOS, JSTRT_P, I, J, M)
- do step=1,allgather_steps
- procid = allgather_proc(step)
- beglat_p = cut(1,procid)
- endlat_p = cut(2,procid)
- numlats_p = nlat_p(procid)
- bufpos = rdispls(procid)
-! tmass
- jstrt_p = beglat_p - 1
- do j=1,numlats_p
- tmass(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! engy1lat
- jstrt_p = beglat_p - 1
- do j=1,numlats_p
- engy1lat(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! engy2alat
- jstrt_p = beglat_p - 1
- do j=1,numlats_p
- engy2alat(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! engy2blat
- jstrt_p = beglat_p - 1
- do j=1,numlats_p
- engy2blat(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! difftalat
- jstrt_p = beglat_p - 1
- do j=1,numlats_p
- difftalat(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! difftblat
- jstrt_p = beglat_p - 1
- do j=1,numlats_p
- difftblat(jstrt_p+j) = buf2(bufpos+j)
- enddo
- bufpos = bufpos + numlats_p
-! hw1lat
- do j=beglat_p,endlat_p
- do m=1,pcnst
- hw1lat(m,j) = buf2(bufpos+m)
- enddo
- bufpos = bufpos + pcnst
- enddo
-! hw2al
- do j=beglat_p,endlat_p
- do m=1,pcnst
- hw2al(m,j) = buf2(bufpos+m)
- enddo
- bufpos = bufpos + pcnst
- enddo
-! hw2bl
- do j=beglat_p,endlat_p
- do m=1,pcnst
- hw2bl(m,j) = buf2(bufpos+m)
- enddo
- bufpos = bufpos + pcnst
- enddo
-! hw3al
- do j=beglat_p,endlat_p
- do m=1,pcnst
- hw3al(m,j) = buf2(bufpos+m)
- enddo
- bufpos = bufpos + pcnst
- enddo
-! hw3bl
- do j=beglat_p,endlat_p
- do m=1,pcnst
- hw3bl(m,j) = buf2(bufpos+m)
- enddo
- bufpos = bufpos + pcnst
- enddo
-! hwxal
- do j=beglat_p,endlat_p
- do i=1,4
- do m=1,pcnst
- hwxal(m,i,j) = buf2(bufpos+m)
- enddo
- bufpos = bufpos + pcnst
- enddo
- enddo
-! hwxbl
- do j=beglat_p,endlat_p
- do i=1,4
- do m=1,pcnst
- hwxbl(m,i,j) = buf2(bufpos+m)
- enddo
- bufpos = bufpos + pcnst
- enddo
- enddo
-!
- end do
-!
- return
-end subroutine realloc5
-#endif
-
-!
-!-----------------------------------------------------------------------
-!
-
-
-end module scan2
diff --git a/src/dynamics/eul/scandyn.F90 b/src/dynamics/eul/scandyn.F90
deleted file mode 100644
index 1165957729..0000000000
--- a/src/dynamics/eul/scandyn.F90
+++ /dev/null
@@ -1,207 +0,0 @@
-
-subroutine scandyn (ztodt, etadot, etamid, grlps1, grt1, &
- grz1, grd1, grfu1, grfv1, grut1, &
- grvt1, grrh1, grlps2, grt2, grz2, &
- grd2, grfu2, grfv2, grut2, grvt2, &
- grrh2, vcour, vmax2d, vmax2dt, detam, &
- cwava, flx_net, t2, fu, fv)
-!-----------------------------------------------------------------------
-!
-! Purpose:
-!
-! Method:
-! "After coupling" gaussian latitude scan for which some of the physics
-! and nonlinear dynamics calculations are completed. The main loop over
-! latitude in this routine is multitasked.
-!
-! Note: the "ifdef" constructs in this routine are associated with the
-! message-passing version of CAM. Messages are sent which
-! have no relevance to the shared-memory case.
-!
-! Author:
-! Original version: CCM3
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plat, plev, beglat, endlat, plevp
- use prognostics, only: u3, v3, q3, t3, div, vort, phis, omga, dpsl, &
- dpsm, ps, n3m1, n3, n3m2, qminus, pdeld
- use constituents, only: pcnst
- use scanslt, only: hw1lat
- use comspe, only: maxm
- use linemsdyn, only: linemsdyn_bft, linemsdyn_fft, linemsdyn_aft, &
- plondfft
- use commap, only: w
- use qmassa, only: qmassarun
- use perf_mod
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-!
-! Input arguments
-!
- real(r8), intent(in) :: ztodt ! two delta t unless nstep =0
- real(r8), intent(inout) :: etadot(plon,plevp,beglat:endlat) ! vertical motion (slt)
- real(r8), intent(in) :: etamid(plev) ! hybrd coord value at levels
- real(r8), intent(in) :: detam(plev)
-!
-! Fourier coefficient arrays which have a latitude index on them for
-! multitasking. These arrays are defined in LINEMSDYN and and used in QUAD
-! to compute spectral coefficients. They contain a latitude index so
-! that the sums over latitude can be performed in a specified order.
-!
- real(r8), intent(in) :: cwava(plat) ! weight applied to global integrals
- real(r8), intent(in) :: flx_net(plon,beglat:endlat) ! net flx from physics
- real(r8), intent(inout) :: t2(plon,plev,beglat:endlat) ! tot dT/dt to to physics
- real(r8), intent(inout) :: fu(plon,plev,beglat:endlat) ! u wind tend
- real(r8), intent(inout) :: fv(plon,plev,beglat:endlat) ! v wind tend
-!
-! Output arguments
-!
- real(r8), intent(out) :: grlps1(2*maxm,(plat+1)/2) ! sym. undiff. term in lnps eqn.
- real(r8), intent(out) :: grlps2(2*maxm,(plat+1)/2) ! antisym undiff. term in lnps eqn.
- real(r8), intent(out) :: grt1(2*maxm,plev,(plat+1)/2) ! sym. undiff. term in t eqn.
- real(r8), intent(out) :: grt2(2*maxm,plev,(plat+1)/2) ! antisym. undiff. term in t eqn.
- real(r8), intent(out) :: grz1(2*maxm,plev,(plat+1)/2) ! sym. undiff. term in z eqn.
- real(r8), intent(out) :: grz2(2*maxm,plev,(plat+1)/2) ! antisym. undiff. term in z eqn.
- real(r8), intent(out) :: grd1(2*maxm,plev,(plat+1)/2) ! sym. undiff. term in d eqn.
- real(r8), intent(out) :: grd2(2*maxm,plev,(plat+1)/2) ! antisym. undiff. term in d eqn.
- real(r8), intent(out) :: grfu1(2*maxm,plev,(plat+1)/2) ! sym. nonlinear terms in u eqn.
- real(r8), intent(out) :: grfu2(2*maxm,plev,(plat+1)/2) ! antisym. nonlinear terms in u eqn.
- real(r8), intent(out) :: grfv1(2*maxm,plev,(plat+1)/2) ! sym. nonlinear terms in v eqn.
- real(r8), intent(out) :: grfv2(2*maxm,plev,(plat+1)/2) ! antisym. nonlinear terms in v eqn.
- real(r8), intent(out) :: grut1(2*maxm,plev,(plat+1)/2) ! sym. lambda deriv. term in t eqn.
- real(r8), intent(out) :: grut2(2*maxm,plev,(plat+1)/2) ! antisym. lambda deriv. term in t eqn.
- real(r8), intent(out) :: grvt1(2*maxm,plev,(plat+1)/2) ! sym. mu derivative term in t eqn.
- real(r8), intent(out) :: grvt2(2*maxm,plev,(plat+1)/2) ! antisym. mu deriv. term in t eqn.
- real(r8), intent(out) :: grrh1(2*maxm,plev,(plat+1)/2) ! sym. del**2 term in d eqn.
- real(r8), intent(out) :: grrh2(2*maxm,plev,(plat+1)/2) ! antisym. del**2 term in d eqn.
- real(r8), intent(out) :: vcour(plev,plat) ! maximum Courant number in vert.
- real(r8), intent(out) :: vmax2d(plev,plat) ! max. wind at each level, latitude
- real(r8), intent(out) :: vmax2dt(plev,plat) ! max. truncated wind at each lvl,lat
-
-! Local variables
-
- integer irow ! latitude pair index
- integer lat,latn,lats ! latitude indices
- integer nlon_fft_in ! FFT work array inner dimension
- integer nlon_fft_out ! FFT work array inner dimension
- real(r8) pmid(plon,plev) ! pressure at model levels
- real(r8) pint(plon,plevp) ! pressure at interfaces
- real(r8) pdel(plon,plev) ! pressure difference between
- integer :: m ! constituent index
-!
-! FFT buffers
-!
- real(r8), allocatable:: fftbuf_in(:,:,:,:) ! fftbuf_in(nlon_fft_in,9,plev,beglat:endlat)
- real(r8), allocatable:: fftbuf_out(:,:,:,:) ! fftbuf_out(nlon_fft_out,9,plev,plat)
-!
- call t_startf ('scandyn_alloc')
- nlon_fft_in = plondfft
- allocate(fftbuf_in(nlon_fft_in,9,plev,beglat:endlat))
-
-#if ( defined SPMD )
-#ifdef NEC_SX
- nlon_fft_out = 2*maxm + 1
-#else
- nlon_fft_out = 2*maxm
-#endif
- allocate(fftbuf_out(nlon_fft_out,9,plev,plat))
-#else
- nlon_fft_out = 1
- allocate(fftbuf_out(1,1,1,1))
-#endif
- call t_stopf ('scandyn_alloc')
-!
- call t_startf ('linemsdyn_bft')
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (LAT)
-#endif
- do lat=beglat,endlat
-
- call linemsdyn_bft (lat, plon, nlon_fft_in, &
- ps(1,lat,n3m1), ps(1,lat,n3m2), u3(1,1,lat,n3m1), &
- u3(1,1,lat,n3m2), v3(1,1,lat,n3m1), v3(1,1,lat,n3m2), t3(1,1,lat,n3m1), t3(1,1,lat,n3m2), &
- q3(1,1,1,lat,n3m1), etadot(1,1,lat), etamid, &
- ztodt, vcour(1,lat), vmax2d(1,lat), vmax2dt(1,lat), &
- detam, t2(1,1,lat), fu(1,1,lat), fv(1,1,lat), &
- div(1,1,lat,n3m1), vort(1,1,lat,n3m2), div(1,1,lat,n3m2), vort(1,1,lat,n3m1), &
- phis(1,lat), dpsl(1,lat), dpsm(1,lat), omga(1,1,lat), &
- cwava(lat), flx_net(1,lat), fftbuf_in(1,1,1,lat) )
- end do
- call t_stopf ('linemsdyn_bft')
-
- call t_startf ('linemsdyn_fft')
- call linemsdyn_fft (nlon_fft_in,nlon_fft_out,fftbuf_in,fftbuf_out)
- call t_stopf ('linemsdyn_fft')
-
- call t_startf ('linemsdyn_aft')
-!$OMP PARALLEL DO PRIVATE (IROW, LATN, LATS)
- do irow=1,plat/2
-
- lats = irow
- latn = plat - irow + 1
-#if ( defined SPMD )
- call linemsdyn_aft (irow, nlon_fft_out, fftbuf_out(1,1,1,lats), fftbuf_out(1,1,1,latn), &
- grlps1(1,irow), grt1(1,1,irow), grz1(1,1,irow), grd1(1,1,irow), &
- grfu1(1,1,irow), grfv1(1,1,irow), &
- grut1(1,1,irow), grvt1(1,1,irow), grrh1(1,1,irow), grlps2(1,irow),grt2(1,1,irow), &
- grz2(1,1,irow), grd2(1,1,irow), grfu2(1,1,irow), grfv2(1,1,irow), grut2(1,1,irow), &
- grvt2(1,1,irow), grrh2(1,1,irow) )
-#else
- call linemsdyn_aft (irow, nlon_fft_in, fftbuf_in(1,1,1,lats), fftbuf_in(1,1,1,latn), &
- grlps1(1,irow), grt1(1,1,irow), grz1(1,1,irow), grd1(1,1,irow), &
- grfu1(1,1,irow), grfv1(1,1,irow), &
- grut1(1,1,irow), grvt1(1,1,irow), grrh1(1,1,irow), grlps2(1,irow),grt2(1,1,irow), &
- grz2(1,1,irow), grd2(1,1,irow), grfu2(1,1,irow), grfv2(1,1,irow), grut2(1,1,irow), &
- grvt2(1,1,irow), grrh2(1,1,irow) )
-#endif
- end do
- call t_stopf ('linemsdyn_aft')
-!
- call t_startf ('scandyn_dealloc')
- deallocate(fftbuf_in)
- deallocate(fftbuf_out)
- call t_stopf ('scandyn_dealloc')
-
-!
- call t_startf ('moisture_mass')
-!
-! Initialize moisture mass integrals.
-!
- hw1lat = 0.0_r8
-!
-! Calculate total mass of moisture in fields advected
-!
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (LAT, IROW)
-#endif
- do lat=beglat,endlat
- if(lat.le.plat/2) then
- irow = lat
- else
- irow = plat + 1 - lat
- end if
-!
-! Only pdel is needed pint and pmid are not.
-!
- call plevs0 (plon,plon,plev,ps(1,lat,n3m2), pint, pmid, pdel)
-!
-! Calculate mass of moisture in field being advected
-!
-
-! q3 is plon,plev,pcnst,beglat:endlat,ptimelevs
-! qminus is plon,plev,pcnst,beglat:endlat
- call qmassarun (cwava(lat),w(irow) ,qminus(1,1,1,lat),pdel , &
- hw1lat(1,lat),plon, q3(1,1,1,lat,n3m2), lat, &
- pdeld(:,:,lat,n3m2 ))
- end do
- call t_stopf ('moisture_mass')
-
- return
-end subroutine scandyn
-
diff --git a/src/dynamics/eul/scanslt.F90 b/src/dynamics/eul/scanslt.F90
deleted file mode 100644
index 40390729a0..0000000000
--- a/src/dynamics/eul/scanslt.F90
+++ /dev/null
@@ -1,1430 +0,0 @@
-module scanslt
-!-----------------------------------------------------------------------
-!
-! Module to handle Semi-Lagrangian transport in the context of
-! Eulerian Spectral dynamics.
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plat, plev, beglat, endlat, plevp
- use constituents, only: pcnst
- use cam_abortutils, only: endrun
- use scamMod, only: single_column
- use perf_mod
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
- private
-!
-! Public interfaces
-!
- public scanslt_initial ! Advection initialization method
- public scanslt_run ! Advection run method
- public scanslt_final ! Advection finalization method
- public scanslt_alloc ! Allocate some slt data needed for restarting
-!
-! Public extended grid parameters
-!
- integer, public, parameter :: nxpt = 1 ! no. of pts outside active domain of interpolant
- integer, public, parameter :: jintmx = 2 ! number of extra latitudes in polar region
- integer, public, parameter :: i1 = 1 + nxpt ! model starting longitude index
- integer, public, parameter :: j1 = 1 + nxpt + jintmx ! model starting latitude index
- integer, public, parameter :: plond = plon + 1 + 2*nxpt ! slt extended domain longitude
- integer, public, parameter :: plond1 = plond - i1 +1 ! slt extended domain longitude starting at i1
- integer, public, parameter :: platd = plat + 2*nxpt + 2*jintmx ! slt extended domain lat.
- integer, public, parameter :: numbnd = nxpt + jintmx ! no.of lats passed N and S of forecast lat
- integer, public, parameter :: plndlv = plond*plev ! Length of multilevel 3-d field slice
-
- integer, public :: beglatex ! extended grid beglat
- integer, public :: endlatex ! extended grid endlat
- integer, public :: numlatsex ! number of latitudes owned by a given proc extended grid
-
-#if ( ! defined SPMD )
- parameter (beglatex = 1)
- parameter (endlatex = platd)
- parameter (numlatsex= platd)
-#endif
-
- public engy1lat ! For calculation of total energy
- public hw1lat ! For calculation of total moisture
-!
-! Public data structures
-!
- public advection_state
-
- ! advection data structure of data that will be on the extended grid for SLT
- type advection_state
- real(r8), pointer :: u3(:,:,:) => null() ! u-wind
- real(r8), pointer :: v3(:,:,:) => null() ! v-wind
- real(r8), pointer :: qminus(:,:,:,:) => null() ! constituents on previous step
- end type advection_state
-
- public lammp, phimp, sigmp, qfcst ! Needed for restart
-!
- integer, public :: nlonex(platd) = huge(1) ! num longitudes per lat (extended grid)
- real(r8) :: hw1lat (pcnst,plat) ! lat contribution to const. mass integral
- real(r8) :: engy1lat(plat) ! lat contribution to total energy integral
- real(r8), allocatable, target :: lammp(:,:,:) ! Lamda midpoint coordinate
- real(r8), allocatable, target :: phimp(:,:,:) ! Phi midpoint coordinate
- real(r8), allocatable, target :: sigmp(:,:,:) ! Sigma midpoint coordinate
- real(r8), allocatable, target :: qfcst(:,:,:,:) ! slt forecast of moisture and constituents
-!
-! Private data
-!
- integer, parameter :: pmap = 20000
-! ! max dimension of evenly spaced vert.
-! ! grid used by SLT code to map the departure pts into true
-! ! model levels.
-!
- real(r8) :: etaint(plevp) ! vertical coords at interfaces
- real(r8) :: dlam(platd) ! longitudinal grid interval (radians)
- real(r8) :: lam(plond,platd) ! longitude coords of extended grid
- real(r8) :: phi(platd) ! latitude coords of extended grid
- real(r8) :: dphi(platd) ! latitude intervals (radians)
- real(r8) :: sinlam(plond,platd) ! sin(lam) model domain only
- real(r8) :: coslam(plond,platd) ! cos(lam) model domain only
- real(r8) :: lbasdy(4,2,platd) ! latitude derivative weights
- real(r8) :: lbasdz(4,2,plev) ! vert (full levels) deriv wghts
- real(r8) :: lbassd(4,2,plevp) ! vert (half levels) deriv wghts
- real(r8) :: lbasiy(4,2,platd) ! Lagrange cubic interp wghts (lat.)
- real(r8) :: detai(plevp) ! intervals between vert half levs.
- integer :: kdpmpf(pmap) ! artificial full vert grid indices
- integer :: kdpmph(pmap) ! artificial half vert grid indices
- real(r8) :: gravit ! gravitational constant
-
-!-----------------------------------------------------------------------
-contains
-!-----------------------------------------------------------------------
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine scanslt_alloc()
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Allocate some scanslt data
-!
-! Author:
-!
-! Erik Kluzek
-!
-!-----------------------------------------------------------------------
- use infnan, only: nan, assignment(=)
-
- allocate (lammp(plon,plev,beglat:endlat))
- allocate (phimp(plon,plev,beglat:endlat))
- allocate (sigmp(plon,plev,beglat:endlat))
- allocate (qfcst(plon,plev,pcnst,beglat:endlat))
-
- lammp (:,:,:) = nan
- phimp (:,:,:) = nan
- sigmp (:,:,:) = nan
- qfcst (:,:,:,:) = nan
-end subroutine scanslt_alloc
-
-!
-!-----------------------------------------------------------------------
-!
-subroutine scanslt_initial( adv_state, etamid, gravit_in, detam, cwava )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! SLT initialization for Eulerian dynamics
-!
-! Author:
-!
-! Erik Kluzek
-!
-!-----------------------------------------------------------------------
- use commap, only: clat
- use prognostics, only: ps, n3
- use time_manager, only: is_first_step
- use hycoef, only: hyam, hybm, hyai, hybi, ps0
- use eul_control_mod, only : pdela
-!
-! Input arguments
-!
- real(r8), intent(out) :: etamid(plev) ! vertical coords at midpoints
- real(r8), intent(in) :: gravit_in ! Gravitational constant
-!
-! Output arguments
-!
- real(r8), intent(out) :: detam(plev) ! intervals between vert full levs.
- real(r8), intent(out) :: cwava(plat) ! weight applied to global integrals
- type(advection_state), intent(out) :: adv_state ! Advection state data
-
-!
-! Local variables
-!
- integer :: i, j, k, lat ! indices
- real(r8) :: hyad (plev) ! del (A)
- real(r8) :: pmid(plon,plev) ! pressure at model levels
- real(r8) :: pint(plon,plevp) ! pressure at interfaces
- real(r8) :: pdel(plon,plev) ! pressure difference between
- real(r8) :: gw(plat) ! Gaussian weights needed for SCAM grdini call
-!
-! Allocate memory for scanslt variables
-!
- call adv_state_alloc( adv_state )
-
- do k = 1, plev
- etamid(k) = hyam(k) + hybm(k)
- etaint(k) = hyai(k) + hybi(k)
- end do
- etaint(plevp) = hyai(plevp) + hybi(plevp)
-!
-! For SCAM compute pressure levels to use for eta interface
-!
- if (single_column) then
- lat = beglat
- call plevs0(plon, plon, plev, ps(1,lat,n3), pint, pmid, pdel)
- etamid(:) = pmid(lat,:)
- etaint(:) = pint(lat,:)
- if ( any(etamid == 0.0_r8) ) call endrun('etamid == 0')
- if ( any(etaint == 0.0_r8) ) call endrun('etaint == 0')
- endif
-!
-! Set slt module variables
-!
- gravit = gravit_in
- call grdini(pmap ,etamid ,etaint ,gravit ,dlam , &
- lam ,phi ,dphi ,gw ,sinlam , &
- coslam ,lbasdy ,lbasdz ,lbassd ,lbasiy , &
- detam ,detai ,kdpmpf ,kdpmph ,cwava )
-!
-! Initial guess for trajectory midpoints in spherical coords.
-! nstep = 0: use arrival points as initial guess for trajectory midpoints.
-! nstep > 0: use calculated trajectory midpoints from previous time
-! step as first guess.
-! NOTE: reduce number of iters necessary for convergence after nstep = 1.
-!
- if (is_first_step()) then
- do lat=beglat,endlat
- j = j1 - 1 + lat
-!
-! Set current time pressure arrays for model levels etc.
-!
- call plevs0(plon, plon, plev, ps(1,lat,n3), pint, pmid, pdel)
-
- do k=1,plev
- do i=1,plon
- if (single_column) then
- sigmp(i,k,lat) = pmid(i,k)
- else
- lammp(i,k,lat) = real(i-1,r8)*dlam(j1-1+lat)
- phimp(i,k,lat) = clat(lat)
- sigmp(i,k,lat) = etamid(k)
- endif
- end do
- end do
- end do
- end if
-!
-! Compute pdel from "A" portion of hybrid vertical grid
-!
- do k=1,plev
- hyad(k) = hyai(k+1) - hyai(k)
- end do
- do k=1,plev
- do i=1,plon
- pdela(i,k) = hyad(k)*ps0
- end do
- end do
-
-end subroutine scanslt_initial
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine scanslt_run(adv_state, ztodt ,etadot ,detam, etamid, cwava )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Driving routine for semi-lagrangian transport.
-!
-! Method:
-! The latitude loop in this routine is multitasked.
-!
-! Author:
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
- use physconst, only: ra
- use prognostics, only: hadv
- use time_manager, only: get_nstep
- use pmgrid, only: plon, plat
-#if (defined SPMD)
- use mpishorthand, only: mpicom
-#endif
-!------------------------------Parameters-------------------------------
- integer itermx ! number of iterations to be used in departure
-! ! point calculation for nstep = 0 and 1
- integer itermn ! number of iterations to be used in departure
-! ! point calculation for nstep > 1
- parameter(itermx=4,itermn=1)
-!-----------------------------------------------------------------------
-!
-! Input arguments
-!
- real(r8), intent(in) :: ztodt ! twice the time step unless nstep = 0
- real(r8), intent(in) :: etadot(plon,plevp,beglat:endlat)! vertical motion (slt)
- real(r8), intent(in) :: etamid(plev) ! eta at levels
-!
-! In/Output arguments
-!
- real(r8), intent(inout) :: detam(plev) ! delta eta at levels
- ! needs intent(out) because of SCAM
- real(r8), intent(inout) :: cwava(plat) ! weight for global water vapor int.
- ! needs intent(out) because of SCAM
- type(advection_state), intent(inout) :: adv_state ! Advection state data
-!
-!---------------------------Local workspace-----------------------------
-!
- integer iter ! number of iterations for
-! ! departure point calculation
- integer m
- integer lat ! latitude index
- integer irow ! N/S latitude pair index
- integer jcen ! lat index (extended grid) of forecast
- integer :: nstep ! current timestep number
- real(r8) :: pmid(plon,plev) ! pressure at model levels
- real(r8) :: pint(plon,plevp)! pressure at interfaces
- real(r8) :: pdel(plon,plev) ! pressure difference between
-!
-! Dynamic (SPMD) vs stack (shared memory)
-!
- real(r8) uxl(plond,plev,beglatex:endlatex) ! left x-deriv of u/v
- real(r8) uxr(plond,plev,beglatex:endlatex) ! left x-deriv of u/v
- real(r8) vxl(plond,plev,beglatex:endlatex) ! left x-deriv of u/v
- real(r8) vxr(plond,plev,beglatex:endlatex) ! left x-deriv of u/v
- real(r8) qxl(plond,plev,pcnst,beglatex:endlatex) ! left x-deriv of constituents
- real(r8) qxr(plond,plev,pcnst,beglatex:endlatex) ! right x-deriv of constituents
- real(r8) :: gw(plat) ! Gaussian weights needed for SCAM grdini call
- integer :: k ! Vertical index needed for SCAM
-!
-!-----------------------------------------------------------------------
-!
-! Copy dynamics data into SLT advection structure
-!
- call t_startf ('scanslt_da_coup')
- call da_coupling( cwava, adv_state )
- call t_stopf ('scanslt_da_coup')
-!
-! For SCAM reset vertical grid
-!
- if (single_column) then
-!
-! IF surface pressure changes with time we need to remap the vertical
-! coordinate for the slt advection process. It has been empirically
-! determined that we can get away with 500 for pmap (instead of 20000)
-! This is necessary to make the procedure computationally feasible
-!
- call grdini(pmap ,etamid ,etaint ,gravit ,dlam , &
- lam ,phi ,dphi ,gw ,sinlam , &
- coslam ,lbasdy ,lbasdz ,lbassd ,lbasiy , &
- detam ,detai ,kdpmpf ,kdpmph ,cwava )
-!
-! Initial guess for trajectory midpoints in spherical coords.
-! nstep = 0: use arrival points as initial guess for trajectory midpoints.
-! nstep > 0: use calculated trajectory midpoints from previous time
-! step as first guess.
-! NOTE: reduce number of iters necessary for convergence after nstep = 1.
-!
- do k=1,plev
- sigmp(1,k,beglat) = etamid(k)
- end do
-
- else
-!
-! Mpi barrier
-!
-#if ( defined SPMD )
-!
-! Communicate boundary information
-!
- call t_barrierf ('sync_bndexch', mpicom)
- call t_startf ('bndexch')
- call bndexch( adv_state )
- call t_stopf ('bndexch')
-#endif
-
- nstep = get_nstep()
-!
-! Initialize extended arrays
-!
- call t_startf('sltini')
- call sltini (dlam, sinlam, coslam, uxl, uxr, &
- vxl, vxr, qxl, qxr, adv_state )
- call t_stopf('sltini')
- endif
- nstep = get_nstep()
- if (nstep .le. 1) then
- iter = itermx
- else
- iter = itermn
- end if
-!
-! Loop through latitudes producing forecast
-!
- call t_startf ('sltb1')
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (LAT, IROW, JCEN)
-#endif
- do lat=beglat,endlat
- if(lat.le.plat/2) then
- irow = lat
- else
- irow = plat + 1 - lat
- end if
- jcen = j1 - 1 + lat
-!
-! Call slt interface routine.
-!
- call sltb1 (pmap ,jcen ,lat ,ztodt ,ra , &
- iter ,uxl ,uxr ,vxl ,vxr , &
- etadot(1,1,lat) ,qxl ,qxr ,lam , &
- phi ,dphi ,etamid ,etaint ,detam , &
- detai ,lbasdy ,lbasdz ,lbassd ,lbasiy , &
- kdpmpf ,kdpmph ,lammp(1,1,lat), phimp(1,1,lat), sigmp(1,1,lat), &
- qfcst(1,1,1,lat) ,adv_state, plon, hadv, nlonex )
- end do
- call t_stopf ('sltb1')
-!
-! Copy SLT advection structure data back into dynamics data
-!
- call t_startf ('scanslt_ad_coup')
- call ad_coupling( adv_state )
- call t_stopf ('scanslt_ad_coup')
- return
-end subroutine scanslt_run
-
-!
-!-----------------------------------------------------------------------
-!
-subroutine scanslt_final( adv_state )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! SLT finalization for Eulerian dynamics
-!
-! Author:
-!
-! Erik Kluzek
-!
-!-----------------------------------------------------------------------
-!
-! Arguments
-!
- type(advection_state), intent(inout) :: adv_state ! Advection state data
-
- call adv_state_dealloc( adv_state )
-end subroutine scanslt_final
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine ad_coupling( adv_state )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Copy advection data into dynamics state.
-!
-! Author:
-!
-! Erik Kluzek
-!
-!-----------------------------------------------------------------------
- use prognostics, only: u3, v3, qminus, n3m1
-!
-! Arguments
-!
- type(advection_state), intent(in) :: adv_state ! Advection state data
-
- integer :: i, j, k, c ! Indices
-
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (J,K,I,C)
-#endif
- do j = beglat, endlat
-!$OMP PARALLEL DO PRIVATE (K,I,C)
- do k = 1, plev
- do i = 1, plon
- u3(i,k,j,n3m1) = adv_state%u3(i+i1-1,k,j+beglatex+numbnd-beglat)
- v3(i,k,j,n3m1) = adv_state%v3(i+i1-1,k,j+beglatex+numbnd-beglat)
- do c = 1, pcnst
- qminus(i,k,c,j) = adv_state%qminus(i+i1-1,k,c,j+beglatex+numbnd-beglat)
- end do
- end do
- end do
- end do
-
-end subroutine ad_coupling
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine da_coupling( cwava, adv_state )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Copy dynamics data into advection state
-! Also find the total moisture mass before SLT.
-!
-! Author:
-!
-! Erik Kluzek
-!
-!-----------------------------------------------------------------------
- use prognostics, only: u3, v3, qminus, n3m1, ps, n3m2, q3, pdeld
- use commap, only: w
- use qmassa, only: qmassarun
-
-!
-! Arguments
-!
- real(r8), intent(in) :: cwava(plat) ! weight for global water vapor int.
- type(advection_state), intent(inout) :: adv_state ! Advection state data
-!
-! Local variables
-!
- integer :: i, j, k, c, irow, lat ! Indices
-
- real(r8) :: pmid(plon,plev) ! pressure at model levels
- real(r8) :: pint(plon,plevp) ! pressure at interfaces
- real(r8) :: pdel(plon,plev) ! pressure difference between
-!
-! Initialize moisture mass integrals.
-!
- hw1lat = 0.0_r8
-!
-! Find moisture mass before SLT
-!
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (LAT, IROW, PINT, PMID, PDEL)
-#endif
- do lat=beglat,endlat
- if(lat.le.plat/2) then
- irow = lat
- else
- irow = plat + 1 - lat
- end if
-!
-! Only pdel is needed inside SLT. pint and pmid are not.
-!
- call plevs0 (plon,plon,plev,ps(1,lat,n3m2), pint, pmid, pdel)
-!
-! Calculate mass of moisture in field being advected by slt. (hw1lat)
-!
-
-! q3 is plon,plev,pcnst,beglat:endlat,ptimelevs
-! qminus is plon,plev,pcnst,beglat:endlat
- call qmassarun (cwava(lat),w(irow) ,qminus(1,1,1,lat),pdel , &
- hw1lat(1,lat),plon, q3(1,1,1,lat,n3m2), lat, pdeld(:,:,lat,n3m2 ))
- end do
-
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (J,K,I,C)
-#endif
- do j = beglat, endlat
-!$OMP PARALLEL DO PRIVATE (K,I,C)
- do k = 1, plev
- do i = 1, plon
- adv_state%u3(i+i1-1,k,j+beglatex+numbnd-beglat) = u3(i,k,j,n3m1)
- adv_state%v3(i+i1-1,k,j+beglatex+numbnd-beglat) = v3(i,k,j,n3m1)
- do c = 1, pcnst
- adv_state%qminus(i+i1-1,k,c,j+beglatex+numbnd-beglat) = qminus(i,k,c,j)
- end do
- end do
- end do
- end do
-
-end subroutine da_coupling
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine adv_state_alloc( adv_state )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Allocate advection state data
-!
-! Author:
-!
-! Erik Kluzek
-!
-!-----------------------------------------------------------------------
- use infnan, only: posinf, assignment(=)
-!
-! Arguments
-!
- type(advection_state), intent(out) :: adv_state ! Advection state data
-
- allocate (adv_state%u3 (plond,plev ,beglatex:endlatex) )
- allocate (adv_state%v3 (plond,plev ,beglatex:endlatex) )
- allocate (adv_state%qminus(plond,plev,pcnst ,beglatex:endlatex) )
- adv_state%u3 (:,:, beglatex:endlatex) = posinf
- adv_state%v3 (:,:, beglatex:endlatex) = posinf
- adv_state%qminus(:,:,:,beglatex:endlatex) = posinf
-
-end subroutine adv_state_alloc
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine adv_state_dealloc( adv_state )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! De-allocate advection state data
-!
-! Author:
-!
-! Erik Kluzek
-!
-!-----------------------------------------------------------------------
-!
-! Arguments
-!
- type(advection_state), intent(inout) :: adv_state ! Advection state data
-
- deallocate (adv_state%u3 )
- deallocate (adv_state%v3 )
- deallocate (adv_state%qminus)
-
-end subroutine adv_state_dealloc
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine grdini(pmap ,etamid ,etaint ,gravit ,dlam , &
- lam ,phi ,dphi ,gw ,sinlam , &
- coslam ,lbasdy ,lbasdz ,lbassd ,lbasiy , &
- detam ,detai ,kdpmpf ,kdpmph ,cwava )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Initialize model and extended grid parameters
-! Initialize weights for Lagrange cubic derivative estimates
-! Initialize weights for Lagrange cubic interpolant
-!
-! Method:
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
- use vrtmap_mod, only: vrtmap
-!------------------------------Parameters-------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: pmap ! dimension of artificial vert. grid
-!
- real(r8), intent(in) :: etamid(plev) ! full-level model vertical grid
- real(r8), intent(in) :: etaint(plevp) ! half-level model vertical grid
- real(r8), intent(in) :: gravit ! gravitational constant
-!
-! Output arguments
-!
- real(r8), intent(out) :: dlam(platd) ! longitudinal grid interval (radians)
- real(r8), intent(out) :: lam (plond,platd) ! longitudinal coords of extended grid
- real(r8), intent(out) :: phi (platd) ! latitudinal coords of extended grid
- real(r8), intent(out) :: dphi (platd) ! latitude intervals (radians)
- real(r8), intent(out) :: gw (plat) ! Gaussian weights
- real(r8), intent(out) :: sinlam(plond,platd) ! sin(lam) model domain only
- real(r8), intent(out) :: coslam(plond,platd) ! cos(lam) model domain only
- real(r8), intent(out) :: lbasdy(4,2,platd) ! latitude derivative weights
- real(r8), intent(out) :: lbasdz(4,2,plev) ! vertical (full levels) deriv weights
- real(r8), intent(out) :: lbassd(4,2,plevp) ! vertical (half levels) deriv weights
- real(r8), intent(out) :: lbasiy(4,2,platd) ! Lagrange cubic interp weights (lat.)
- real(r8), intent(out) :: detam (plev) ! intervals between vertical full levs.
- real(r8), intent(out) :: detai (plevp) ! intervals between vertical half levs.
-!
- integer, intent(out) :: kdpmpf(pmap) ! artificial full vertical grid indices
- integer, intent(out) :: kdpmph(pmap) ! artificial half vertical grid indices
-!
- real(r8), intent(out) :: cwava(plat) ! weight applied to global integrals
-!
-!-----------------------------------------------------------------------
-!
-! pmap Dimension of artificial evenly spaced vertical grid arrays
-! etamid Full-index hybrid-levels in vertical grid.
-! etaint Half-index hybrid-levels from sig(1/2) = etaint(1) = 0. to
-! sig(plev+1/2) = etaint(plevp) = 1.
-! gravit Gravitational constant.
-! dlam Length of increment in longitude grid.
-! lam Longitude values in the extended grid.
-! phi Latitude values in the extended grid.
-! dphi Interval between latitudes in the extended grid
-! gw Gauss weights for latitudes in the global grid. (These sum
-! to 2.0.)
-! sinlam Sine of longitudes in global grid (no extension points).
-! coslam Cosine of longitudes in global grid (no extension points).
-! lbasdy Weights for Lagrange cubic derivative estimates on the
-! unequally spaced latitude grid
-! lbasdz Weights for Lagrange cubic derivative estimates on the
-! unequally spaced vertical grid (corresponding to model
-! full levels).
-! lbassd Weights for Lagrange cubic derivative estimates on the
-! unequally spaced vertical grid (corresponding to model
-! half levels).
-! lbasiy Weights for Lagrange cubic interpolation on the
-! unequally spaced latitude grid
-! detam Increment between model mid-levels ("full" levels)
-! detai Increment between model interfaces ("half" levels).
-! kdpmpf Array of indicies of the model full levels which are mapped
-! into an artificial evenly spaced vertical grid. Used to aid
-! in search for vertical position of departure point
-! kdpmph Array of indicies of the model half levels which are mapped
-! into an artificial evenly spaced vertical grid. Used to aid
-! in search for vertical position of departure point
-! cwava 1./(plon*gravit)
-!
-!---------------------------Local variables-----------------------------
-!
- integer j ! index
- integer k ! index
-!
- real(r8) etamln(plev) ! log(etamid)
- real(r8) etailn(plevp) ! log(etaint)
- real(r8) detamln(plev) ! dlog(etamid)
- real(r8) detailn(plevp) ! dlog(etaint)
-!
-!-----------------------------------------------------------------------
- if (single_column) then
-
- dlam(:)=0._r8
- lam(:,:)=0._r8
- phi(:)=0._r8
- dphi(:)=0._r8
- sinlam(:,:)=0._r8
- coslam(:,:)=0._r8
- detai(:)=0._r8
- kdpmpf(:)=0._r8
- kdpmph(:)=0._r8
- gw(:)=1._r8
- call basdz(plev ,etamid ,lbasdz )
- call basdz(plevp ,etaint ,lbassd )
-
- else
- !
- ! Initialize extended horizontal grid coordinates.
- !
- call grdxy(dlam ,lam ,phi ,gw ,sinlam , &
- coslam )
- !
- ! Basis functions for computing Lagrangian cubic derivatives
- ! on unequally spaced latitude and vertical grids.
- !
- call basdy(phi ,lbasdy )
-
- call basdz(plev ,etamid ,lbasdz )
- call basdz(plevp ,etaint ,lbassd )
-
-
- !
- ! Basis functions for computing weights for Lagrangian cubic
- ! interpolation on unequally spaced latitude grids.
- !
- call basiy(phi ,lbasiy )
- !
- ! Compute interval lengths in latitudinal grid
- !
- do j = 1,platd-1
- dphi(j) = phi(j+1) - phi(j)
- end do
-
- endif
-!
-! Compute interval lengths in vertical grids.
-!
- do k = 1,plev
- etamln(k) = log(etamid(k))
- end do
- do k = 1,plevp
- etailn(k) = log(etaint(k))
- end do
- do k = 1,plev-1
- detam (k) = etamid(k+1) - etamid(k)
- detamln(k) = etamln(k+1) - etamln(k)
- end do
- do k = 1,plev
- detai (k) = etaint(k+1) - etaint(k)
- detailn(k) = etailn(k+1) - etailn(k)
- end do
-!
-! Build artificial evenly spaced vertical grid for use in determining
-! vertical position of departure point.
-! Build one grid for full model levels and one for half levels.
-!
- call vrtmap(plev ,pmap ,etamln ,detamln ,kdpmpf )
- call vrtmap(plevp ,pmap ,etailn ,detailn ,kdpmph )
-!
-! Compute moisture integration constant
-!
-if (single_column) then
- cwava = 1._r8
-else
- do j=1,plat
- cwava(j) = 1._r8/(plon*gravit)
- end do
-endif
-!
- return
-end subroutine grdini
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine grdxy(dlam ,lam ,phi ,w ,sinlam , &
- coslam )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Define the "extended" grid used in the semi-Lagrangian transport
-! scheme. The longitudes are equally spaced and the latitudes are
-! Gaussian. The global grid is extended to include "wraparound" points
-! on all sides.
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
- use gauaw_mod, only: gauaw
-!------------------------------Parameters-------------------------------
- integer, parameter :: istart = nxpt+1 ! index for first model long.
- integer, parameter :: jstart = nxpt+jintmx+1 ! index for first model lat.
- integer, parameter :: jstop = jstart-1+plat ! index for last model lat.
-!-----------------------------------------------------------------------
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(out) :: dlam(platd) ! longitudinal increment
- real(r8), intent(out) :: lam (plond,platd) ! long. coords. in extended grid
- real(r8), intent(out) :: phi (platd) ! lat. coords. in extended grid
- real(r8), intent(out) :: w (plat) ! Gaussian weights
- real(r8), intent(out) :: sinlam(plond,platd) ! sin(lam)
- real(r8), intent(out) :: coslam(plond,platd) ! cos(lam)
-!
-! dlam Length of increment in longitude grid.
-! lam Longitude values in the extended grid.
-! phi Latitude values in the extended grid.
-! w Gauss weights for latitudes in the global grid. (These sum
-! to 2.0 like the ones in CCM1.)
-! sinlam Sine of longitudes in global grid (no extension points).
-! coslam Cosine of longitudes in global grid (no extension points).
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i,j,ig ! indices
- integer nlond ! extended long dim
- real(r8) lam0 ! lamda = 0
- real(r8) pi ! 3.14...
- real(r8) wrk(platd) ! work space
-!-----------------------------------------------------------------------
-!
- lam0 = 0.0_r8
- pi = 4._r8*atan(1._r8)
-!
-! Interval length in equally spaced longitude grid.
-!
- do j=1,platd
- dlam(j) = 2._r8*pi/real(nlonex(j),r8)
-!
-! Longitude values on extended grid.
-!
- nlond = nlonex(j) + 1 + 2*nxpt
- do i = 1,nlond
- lam(i,j) = real(i-istart,r8)*dlam(j) + lam0
- end do
- end do
-!
-! Compute Gauss latitudes and weights. On return; phi contains the
-! sine of the latitudes starting closest to the north pole and going
-! toward the south; w contains the corresponding Gauss weights.
-!
- call gauaw(phi ,w ,plat )
-!
-! Reorder and compute latitude values.
-!
- do j = jstart,jstop
- wrk(j) = asin( phi(jstop-j+1) )
- end do
- phi(jstart:jstop) = wrk(jstart:jstop)
-!
-! North and south poles.
-!
- phi(jstart-1) = -pi/2.0_r8
- phi(jstop +1) = pi/2.0_r8
-!
-! Extend Gauss latitudes below south pole so that the spacing above
-! the pole is symmetric, and phi is decreasing, i.e., phi < -pi/2
-!
- if( jstart > 2 )then
- do j = 1,jstart-2
- phi(j) = -pi - phi(2*jstart-2-j)
- end do
- end if
-!
-! Analogously for Northern Hemisphere
-!
- if( platd > jstop+1 )then
- do j = jstop+2,platd
- phi(j) = pi - phi(2*jstop+2-j)
- end do
- end if
-!
-! Sine and cosine of longitude.
-!
- do j=1,platd
- ig = 0
- do i = istart,nlonex(j)+nxpt
- ig = ig + 1
- sinlam(ig,j) = sin( lam(i,j) )
- coslam(ig,j) = cos( lam(i,j) )
- end do
- end do
-
- return
-end subroutine grdxy
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine sltb1(pmap ,jcen ,jgc ,dt ,ra , &
- iterdp ,uxl ,uxr ,vxl ,vxr , &
- wb ,fxl ,fxr ,lam ,phib , &
- dphib ,sig ,sigh ,dsig ,dsigh , &
- lbasdy ,lbasdz ,lbassd ,lbasiy ,kdpmpf , &
- kdpmph ,lammp ,phimp ,sigmp ,fbout , &
- adv_state ,nlon ,hadv ,nlonex )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Drive the slt algorithm on a given latitude slice in the extended
-! data arrays using information from the entire latitudinal extent
-! of the arrays.
-!
-! Method:
-! Compute departure points and corresponding indices.
-! Poleward of latitude phigs (radians), perform the computation in
-! local geodesic coordinates.
-! Equatorward of latitude phigs, perform the computation in global
-! spherical coordinates
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-
-#include <parslt.h>
-
-!------------------------------Parameters-------------------------------
- real(r8), parameter :: phigs = 1.221730_r8 ! cut-off latitude: about 70 degrees
-!-----------------------------------------------------------------------
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nlon ! longitude dimension
- integer , intent(in) :: nlonex(platd) ! extended longitude dimension
- integer , intent(in) :: pmap ! artificial vert grid dim.
- integer , intent(in) :: jcen ! index of lat slice(extend)
- integer , intent(in) :: jgc ! index of lat slice (model)
- real(r8), intent(in) :: dt ! time step (seconds)
- real(r8), intent(in) :: ra ! 1./(radius of earth)
- integer , intent(in) :: iterdp ! iteration count
- real(r8), intent(in) :: uxl(plond,plev,beglatex:endlatex) ! left x-deriv of ub
- real(r8), intent(in) :: uxr(plond,plev,beglatex:endlatex) ! right x-deriv of ub
- real(r8), intent(in) :: vxl(plond,plev,beglatex:endlatex) ! left x-deriv of vb
- real(r8), intent(in) :: vxr(plond,plev,beglatex:endlatex) ! right x-deriv of vb
- real(r8), intent(in) :: wb(plon,plevp) ! eta-dot
- real(r8), intent(in) :: fxl(plond,plev, pcnst,beglatex:endlatex) ! left fb x-deriv
- real(r8), intent(in) :: fxr(plond,plev, pcnst,beglatex:endlatex) ! right fb x-deriv
- real(r8), intent(in) :: lam (plond,platd) ! long. coord of model grid
- real(r8), intent(in) :: phib (platd) ! lat. coord of model grid
- real(r8), intent(in) :: dphib(platd) ! increment between lats.
- real(r8), intent(in) :: sig (plev) ! vertical full levels
- real(r8), intent(in) :: sigh (plevp) ! vertical half levels
- real(r8), intent(in) :: dsig (plev) ! inc. between full levs
- real(r8), intent(in) :: dsigh(plevp) ! inc. between half levs
- real(r8), intent(in) :: lbasdy(4,2,platd) ! lat deriv weights
- real(r8), intent(in) :: lbasdz(4,2,plev) ! vert full level deriv wts
- real(r8), intent(in) :: lbassd(4,2,plevp) ! vert half level deriv wts
- real(r8), intent(in) :: lbasiy(4,2,platd) ! lat interp wts(lagrng)
- integer , intent(in) :: kdpmpf(pmap) ! artificial vert grid index
- integer , intent(in) :: kdpmph(pmap) ! artificial vert grid index
- real(r8), intent(inout) :: hadv (plon, plev, pcnst, beglat:endlat) ! horizontal advection tendency
- real(r8), intent(inout) :: lammp(plon,plev) ! long coord of mid-point
- real(r8), intent(inout) :: phimp(plon,plev) ! lat coord of mid-point
- real(r8), intent(inout) :: sigmp(plon,plev) ! vert coord of mid-point
- real(r8), intent(out) :: fbout(plon,plev,pcnst) ! advected constituents
- type(advection_state), intent(in) :: adv_state ! Advection state
-!
-! pmap Dimension of kdpmpX arrays
-! jcen Latitude index in extended grid corresponding to lat slice
-! being forecasted.
-! jgc Latitude index in model grid corresponding to lat slice
-! being forecasted.
-! dt Time interval that parameterizes the parcel trajectory.
-! ra Reciprocal of radius of earth.
-! iterdp Number of iterations used for departure point calculation.
-! uxl x-derivatives of u at the left (west) edge of given interval
-! vxl x-derivatives of v at the left (west) edge of given interval
-! uxr x-derivatives of u at the right (east) edge of given interval
-! vxr x-derivatives of v at the right (east) edge of given interval
-! wb z-velocity component (eta-dot).
-! fxl x-derivatives at the left edge of each interval containing
-! the departure point.
-! fxr x-derivatives at the right edge of each interval containing
-! the departure point.
-! lam Longitude values for the extended grid.
-! phib Latitude values for the extended grid.
-! dphib Interval between latitudes in the extended grid.
-! sig Hybrid eta values at the "full-index" levels.
-! sigh Half-index eta-levels including sigh(i,1) = eta(1/2) = 0.0
-! and sigh(i,plev+1) = eta(plev+1/2) = 1. Note that in general
-! sigh(i,k) .lt. sig(i,k) where sig(i,k) is the hybrid value
-! at the k_th full-index level.
-! dsig Interval lengths in full-index hybrid level grid.
-! dsigh Interval lengths in half-index hybrid level grid.
-! lbasdy Weights for Lagrange cubic derivative estimates on the
-! unequally spaced latitude grid.
-! lbasdz Weights for Lagrange cubic derivative estimates on the
-! unequally spaced vertical grid (full levels).
-! lbassd Weights for Lagrange cubic derivative estimates on the
-! unequally spaced vertical grid (half levels).
-! lbasiy Weights for Lagrange cubic interpolation on the unequally
-! spaced latitude grid.
-! kdpmpf indices of artificial grid mapped into the full level grid
-! kdpmph indices of artificial grid mapped into the half level grid
-! lammp Longitude coordinates of the trajectory mid-points of the
-! parcels that correspond to the global grid points contained
-! in the latitude slice being forecasted. On entry lammp
-! is an initial guess.
-! phimp Latitude coordinates of the trajectory mid-points of the
-! parcels that correspond to the global grid points contained
-! in the latitude slice being forecasted. On entry phimp
-! is an initial guess.
-! sigmp Hybrid value at the trajectory midpoint for each gridpoint
-! in a vertical slice from the global grid. On entry sigmp is
-! an initial guess.
-! fbout Extended array only one latitude of which, however, is filled
-! with forecasted (transported) values. This routine must be
-! called multiple times to fill the entire array. This is
-! done to facilitate multi-tasking.
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer m ! constituent index
- integer idp(plon,plev,4) ! zonal dep point index
- integer jdp(plon,plev) ! meridional dep point index
- integer kdp(plon,plev) ! vertical dep point index
- real(r8) fhr(plon,plev,pcnst) ! horizontal interpolants
- real(r8) lamdp(plon,plev) ! zonal departure pt. coord.
- real(r8) phidp(plon,plev) ! meridional departure pt. coord.
- real(r8) sigdp(plon,plev) ! vertical departure pt. coord.
- real(r8) fhst(plon,plev,pcnst) ! derivative at top of interval
- real(r8) fhsb(plon,plev,pcnst) ! derivative at bot of interval
- real(r8) wst(plon,plevp) ! w derivative at top of interval
- real(r8) wsb(plon,plevp) ! w derivative at bot of interval
- real(r8) fint(plon,plev,ppdy,pcnst) ! work space
- real(r8) fyb(plon,plev,pcnst) ! work space
- real(r8) fyt(plon,plev,pcnst) ! work space
- logical locgeo ! flag indicating coordinate sys
- integer :: k,i ! indices (needed for SCAM)
-!-----------------------------------------------------------------------
- if (.not. single_column) then
-
-!
-! Horizontal interpolation
-!
- locgeo = abs(phib(jcen))>=phigs
-!
- call sphdep(jcen ,jgc ,dt ,ra ,iterdp , &
- locgeo ,adv_state%u3 ,uxl ,uxr ,lam , &
- phib ,lbasiy ,lammp ,phimp ,lamdp , &
- phidp ,idp ,jdp ,adv_state%v3, &
- vxl ,vxr ,nlon ,nlonex )
-!
-! Interpolate scalar fields to the departure points.
-!
- call hrintp(pcnst ,pcnst ,adv_state%qminus, fxl ,fxr , &
- lam ,phib ,dphib ,lbasdy ,lamdp , &
- phidp ,idp ,jdp ,jcen ,plimdr , &
- fint ,fyb ,fyt ,fhr ,nlon , &
- nlonex )
-
- do m = 1,pcnst
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k = 1,plev
- do i = 1,nlon
- hadv(i,k,m,jgc) = (fhr(i,k,m) - adv_state%qminus(i1-1+i,k,m,jcen))/dt
- end do
- end do
- end do
-else
-!
-! fill in fhr in leiu of horizontal interpolation
-!
- do m = 1,pcnst
- do k = 1,plev
- do i = 1,nlon
- fhr(i,k,m) = adv_state%qminus(i1+i-1,k,m,jcen)
- hadv(i,k,m,jgc) = 0._r8
- end do
- end do
- end do
-endif
-!
-! Vertical interpolation.
-! Compute vertical derivatives of vertical wind
-!
- call cubzdr(nlon ,plevp ,wb ,lbassd ,wst , &
- wsb )
-!
-! Compute departure points and corresponding indices.
-!
- call vrtdep(pmap ,dt ,iterdp ,wb ,wst , &
- wsb ,sig ,sigh ,dsigh ,kdpmpf , &
- kdpmph ,sigmp ,sigdp ,kdp ,nlon )
-!
-! Vertical derivatives of scalar fields.
-! Loop over constituents.
-!
- do m = 1,pcnst
- call cubzdr(nlon ,plev ,fhr(:,:,m), lbasdz ,fhst(:,:,m), &
- fhsb(:,:,m) )
- end do
- if( plimdr )then
- call limdz(fhr ,dsig ,fhst ,fhsb ,nlon )
- end if
-!
-! Vertical interpolation of scalar fields.
-!
- call herzin(plev ,pcnst ,fhr ,fhst ,fhsb , &
- sig ,dsig ,sigdp ,kdp ,fbout , &
- nlon )
-
- return
-end subroutine sltb1
-
-!
-!============================================================================================
-!
-
-subroutine vrtdep(pmap ,dt ,iterdp ,wb ,wst , &
- wsb ,sig ,sigh ,dsigh ,kdpmpf , &
- kdpmph ,sigmp ,sigdp ,kdp ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute vertical departure point and departure point index.
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nlon ! longitude dimension
- integer , intent(in) :: pmap ! dimension of artificial vert grid
- real(r8), intent(in) :: dt ! time step (seconds)
- integer , intent(in) :: iterdp ! number of iterations
- real(r8), intent(in) :: wb (plon,plevp) ! vertical velocity
- real(r8), intent(in) :: wst(plon,plevp) ! z-derivative of wb at top of interval
- real(r8), intent(in) :: wsb(plon,plevp) ! z-derivative of wb at bot of interval
- real(r8), intent(in) :: sig (plev ) ! sigma values of model full levels
- real(r8), intent(in) :: sigh (plevp) ! sigma values of model half levels
- real(r8), intent(in) :: dsigh(plevp) ! increment between half levels
- integer , intent(in) :: kdpmpf(pmap) ! artificial grid indices
- integer , intent(in) :: kdpmph(pmap) ! artificial grid indices
- real(r8), intent(inout) :: sigmp(plon,plev) ! vert coords of traj mid-points
- real(r8), intent(out) :: sigdp(plon,plev) ! vert coords of traj departure points
- integer , intent(out) :: kdp(plon,plev) ! vertical departure point indices
-!
-! pmap Dimension of kdpmap arrays
-! dt Time interval that parameterizes the parcel trajectory.
-! iterdp Number of iterations used for departure point calculation.
-! wb Vertical velocity component (sigma dot).
-! wst z-derivs at the top edge of each interval contained in wb
-! wsb z-derivs at the bot edge of each interval contained in wb
-! sig Sigma values at the full-index levels.
-! sigh Half-index sigma levels including sigh(1) = sigma(1/2) = 0.0
-! sigh(plev+1) = sigma(plev+1/2) = 1.0 . Note that in general
-! sigh(k) .lt. sig(k) where sig(k) is the sigma value at the
-! k_th full-index level.
-! dsigh Increment in half-index sigma levels.
-! kdpmpf Array of indices of the model full levels which are mapped
-! into an artificial evenly spaced vertical grid. Used to aid
-! in search for vertical position of departure point
-! kdpmph Array of indices of the model half levels which are mapped
-! into an artificial evenly spaced vertical grid. Used to aid
-! in search for vertical position of departure point
-! sigmp Sigma value at the trajectory midpoint for each gridpoint
-! in a vertical slice from the global grid. On entry sigmp is
-! an initial guess.
-! sigdp Sigma value at the trajectory endpoint for each gridpoint
-! in a vertical slice from the global grid.
-! kdp Vertical index for each gridpoint. This index points into a
-! vertical slice array whose vertical grid is given by sig.
-! E.g., sig(kdp(i,k)) .le. sigdp(i,k) .lt. sig(kdp(i,k)+1).
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i ! |
- integer iter ! |-- indices
- integer k ! |
- real(r8) wmp(plon,plev) ! vert vel. at midpoint
-!-----------------------------------------------------------------------
-!
-! Loop over departure point iterates.
-!
- do iter = 1,iterdp
-!
-! Compute midpoint indices in half-index sigma-level arrays (use kdp
-! as temporary storage).
-!
- call kdpfnd(plevp ,pmap ,sigh ,sigmp ,kdpmph , &
- kdp ,nlon )
-!
-! Interpolate sigma dot field to trajectory midpoints using Hermite
-! cubic interpolant.
-!
- call herzin(plevp ,1 ,wb ,wst ,wsb , &
- sigh ,dsigh ,sigmp ,kdp ,wmp , &
- nlon )
-!
-! Update estimate of trajectory midpoint.
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k = 1,plev
- do i = 1,nlon
- sigmp(i,k) = sig(k) - .5_r8*dt*wmp(i,k)
- end do
- end do
-!
-! Restrict vertical midpoints to be between the top and bottom half-
-! index sigma levels.
-!
- call vdplim(plevp ,sigh ,sigmp ,nlon)
- end do
-!
-! Compute trajectory endpoints.
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k = 1,plev
- do i = 1,nlon
- sigdp(i,k) = sig(k) - dt*wmp(i,k)
- end do
- end do
-!
-! Restrict vertical departure points to be between the top and bottom
-! full-index sigma levels.
-!
- call vdplim(plev ,sig ,sigdp ,nlon)
-!
-! Vertical indices for trajectory endpoints that point into full-index
-! sigma level arrays.
-!
- call kdpfnd(plev ,pmap ,sig ,sigdp ,kdpmpf , &
- kdp ,nlon )
-!
- return
-end subroutine vrtdep
-
-!
-!============================================================================================
-!
-
-subroutine vdplim(pkdim ,sig ,sigdp ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Restrict vertical departure points to be between the top and bottom
-! sigma levels of the "full-" or "half-" level grid
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!---------------------- Arguments --------------------------------------
- integer , intent(in) :: nlon ! longitude dimension
- integer , intent(in) :: pkdim ! vertical dimension
- real(r8), intent(in) :: sig(pkdim) ! vertical coordinate of model grid
- real(r8), intent(inout) :: sigdp(plon,plev) ! vertical coords. of departure points.
-! pkdim Vertical dimension of "sig"
-! sig Sigma values at the "full" or "half" model levels
-! sigdp Sigma value at the trajectory endpoint or midpoint for each
-! gridpoint in a vertical slice from the global grid. This
-! routine restricts those departure points to within the
-! model's vertical grid.
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i,k ! index
-!-----------------------------------------------------------------------
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i = 1,nlon
- if (sigdp(i,k) < sig(1)) then
- sigdp(i,k) = sig(1)
- end if
- if (sigdp(i,k) >= sig(pkdim)) then
- sigdp(i,k) = sig(pkdim)*(1._r8 - 10._r8*epsilon(sigdp))
- end if
- end do
- end do
-
- return
-end subroutine vdplim
-
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine sltini(dlam, sinlam, coslam, uxl, uxr, &
- vxl, vxr, qxl, qxr, adv_state )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Prepare the extended arrays for use in the SLT routines
-!
-! 1) Fill latitude extensions.
-! 2) Fill longitude extensions.
-! 3) Compute x-derivatives
-!
-! Method:
-! Computational note: The latitude loop in this routine is multitasked
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-
-!-----------------------------------------------------------------------
-#include <parslt.h>
-!---------------------------Local parameters----------------------------
-!
- integer puvpts ! number of u/v pts in lat slice
- integer pqpts ! number of constituent pts in lat slice
-!
- parameter(puvpts = plond*plev, pqpts = plond*plev*pcnst)
-!-----------------------------------------------------------------------
-!
-! Input arguments
-!
- real(r8), intent(in) :: dlam(platd) ! increment in x-direction
- real(r8), intent(in) :: sinlam(plond,platd) ! sin(lamda)
- real(r8), intent(in) :: coslam(plond,platd) ! cos(lamda)
- real(r8), intent(inout) :: uxl (plond,plev, beglatex:endlatex)
- real(r8), intent(inout) :: uxr (plond,plev, beglatex:endlatex)
- real(r8), intent(inout) :: vxl (plond,plev, beglatex:endlatex)
- real(r8), intent(inout) :: vxr (plond,plev, beglatex:endlatex)
- real(r8), intent(inout) :: qxl (plond,plev,pcnst,beglatex:endlatex)
- real(r8), intent(inout) :: qxr (plond,plev,pcnst,beglatex:endlatex)
- type(advection_state), intent(inout) :: adv_state ! Advection data state
-!
-!
-!-----------------------------------------------------------------------
-!
-! dlam Length of increment in longitude grid.
-! sinlam Sin of longitudes in global grid (model grid pts only).
-! coslam Cos of longitudes in global grid (model grid pts only).
-! uxl x-derivatives of u at the left (west) edge of given interval
-! vxl x-derivatives of v at the left (west) edge of given interval
-! uxr x-derivatives of u at the right (east) edge of given interval
-! vxr x-derivatives of v at the right (east) edge of given interval
-! qxl x-derivatives of scalar species at the left (west) edge
-! of given interval
-! qxr x-derivatives of scalar species at the right (east) edge
-! of given interval
-!
-!---------------------------Local variables-----------------------------
-!
- integer m,j,k ! index
- integer nlond
-!
-!------------------------------Externals--------------------------------
-!
- external cubxdr,extx,extys,extyv,limdx
-!
-!-----------------------------------------------------------------------
-!
-! Fill latitude extensions beyond the southern- and northern-most
-! latitudes in the global grid
-!
- call t_startf ('slt_single')
- if (beglatex .le. endlatex) then
- call extyv(1, plev, coslam, sinlam, adv_state%u3, adv_state%v3)
- call extys(pcnst, plev ,adv_state%qminus, pcnst)
-!
-! Fill longitude extensions
-!
- call extx(1 ,plev ,adv_state%u3, 1)
- call extx(1 ,plev ,adv_state%v3, 1)
- call extx(pcnst, plev ,adv_state%qminus, pcnst)
- endif
- call t_stopf ('slt_single')
-!
-! Compute x-derivatives.
-!
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (J, NLOND, K, M)
-#endif
- do j = beglatex, endlatex
- nlond = 1 + 2*nxpt + nlonex(j)
-!$OMP PARALLEL DO PRIVATE (K, M)
- do k=1,plev
- call cubxdr (nlond, 2, nlond-3, dlam(j), adv_state%u3(1:nlond,k,j), &
- uxl(1:nlond,k,j), uxr(1:nlond,k,j))
- call cubxdr (nlond, 2, nlond-3, dlam(j), adv_state%v3(1:nlond,k,j), &
- vxl(1:nlond,k,j), vxr(1:nlond,k,j))
- do m=1,pcnst
- call cubxdr (nlond, 2, nlond-3, dlam(j), adv_state%qminus(1:nlond,k,m,j), &
- qxl(1:nlond,k,m,j), qxr(1:nlond,k,m,j))
- if( plimdr )then
- call limdx (nlond, 2, nlond-3, dlam(j), adv_state%qminus(1:nlond,k,m,j), &
- qxl(1:nlond,k,m,j), qxr(1:nlond,k,m,j))
- end if
- end do
- end do
- end do
-
- return
-end subroutine sltini
-
-!
-!-----------------------------------------------------------------------
-!
-
-end module scanslt
diff --git a/src/dynamics/eul/scmforecast.F90 b/src/dynamics/eul/scmforecast.F90
deleted file mode 100644
index decdff9c7f..0000000000
--- a/src/dynamics/eul/scmforecast.F90
+++ /dev/null
@@ -1,571 +0,0 @@
-module scmforecast
- ! --------------------------------------------------------------------------- !
- ! !
- ! Compute Time-Marched 'T, u, v, q' for SCAM by summing the 'physics', !
- ! 'horizontal advection', and 'vertical advection' tendencies. !
- ! This module is used only for SCAM. !
- ! !
- ! --------------------------------------------------------------------------- !
- use spmd_utils, only: masterproc
- use cam_logfile, only: iulog
- use cam_control_mod, only: adiabatic
-
- implicit none
- private
- save
-
- public forecast
-!
-! Private module data
-!
-
-!=======================================================================
-contains
-!=======================================================================
-
-
- subroutine forecast( lat , nlon , ztodt , &
- psm1 , psm2 , ps , &
- u3 , u3m1 , u3m2 , &
- v3 , v3m1 , v3m2 , &
- t3 , t3m1 , t3m2 , &
- q3 , q3m1 , q3m2 , &
- tten_phys , uten_phys , vten_phys , &
- qminus , qfcst )
-
- ! --------------------------------------------------------------------------- !
- ! !
- ! Compute Time-Marched 'T, u, v, q' for SCAM by summing the 'physics', !
- ! 'horizontal advection', and 'vertical advection' tendencies. !
- ! This module is used only for SCAM. !
- ! !
- ! Author : Sungsu Park. 2010. Sep. !
- ! !
- ! --------------------------------------------------------------------------- !
-
- use shr_kind_mod, only : r8 => shr_kind_r8, i8 => shr_kind_i8
- use pmgrid, only : plev, plat, plevp, plon
- use cam_history, only : outfld
- use constituents, only : pcnst, cnst_get_ind, cnst_name
- use physconst, only : rair, cpair, gravit, rga
- use scammod, only : divq,divq3d,divt,divu,divt3d,divu3d,have_divv, &
- divv,divv3d,have_aldif,have_aldir,have_asdif,have_asdir, &
- have_cld,have_cldice,have_cldliq,have_clwp,have_divq,have_divq3d, &
- have_divt,have_divt3d,have_divu,have_divu3d,have_divv3d,have_numice, &
- have_numliq,have_omega,have_phis,have_prec,have_ps,have_ptend, &
- have_q,have_q1,have_q2,have_t,have_u,have_v, &
- have_vertdivq,have_vertdivt,have_vertdivu,have_vertdivv,qdiff,qobs, &
- scm_relax_bot_p,scm_relax_linear,scm_relax_tau_bot_sec, &
- scm_relax_tau_sec,scm_relax_tau_top_sec,scm_relax_top_p, &
- scm_relaxation,scm_use_obs_qv,scm_use_obs_t,scm_use_obs_uv,scm_zadv_q,scm_zadv_t, &
- scm_zadv_uv,tdiff,tobs,uobs,use_3dfrc,use_camiop,vertdivq, &
- vertdivt,vertdivu,vertdivv,vobs,wfld,qinitobs,scm_relax_fincl
- use time_manager, only : get_curr_calday, get_nstep, get_step_size, is_first_step
- use cam_abortutils, only : endrun
- use string_utils, only: to_upper
-
- implicit none
-
- ! ---------------------- !
- ! Parameters !
- ! ---------------------- !
-
- character(len=*), parameter :: subname = "forecast"
-
- ! --------------------------------------------------- !
- ! x = t, u, v, q !
- ! x3m1 : state variable used for computing 'forcing' !
- ! x3m2 : initial state variable before time-marching !
- ! x3 : final state variable after time-marching !
- ! --------------------------------------------------- !
-
- integer, intent(in) :: lat
- integer, intent(in) :: nlon
- real(r8), intent(in) :: ztodt ! Twice time step unless nstep = 0 [ s ]
-
- real(r8), intent(in) :: ps(plon) ! Surface pressure [ Pa ]
- real(r8), intent(in) :: psm1(plon) ! Surface pressure [ Pa ]
- real(r8), intent(in) :: psm2(plon) ! Surface pressure [ Pa ]
-
- real(r8), intent(in) :: t3m1(plev) ! Temperature [ K ]
- real(r8), intent(in) :: t3m2(plev) ! Temperature [ K ]
- real(r8), intent(in) :: u3m1(plev) ! Zonal wind [ m/s ]
- real(r8), intent(in) :: u3m2(plev) ! Zonal wind [ m/s ]
- real(r8), intent(in) :: v3m1(plev) ! Meridional wind [ m/s ]
- real(r8), intent(in) :: v3m2(plev) ! Meridional wind [ m/s ]
- real(r8), intent(inout) :: q3m1(plev,pcnst) ! Tracers [ kg/kg, #/kg ]
- real(r8), intent(inout) :: q3m2(plev,pcnst) ! Tracers [ kg/kg, #/kg ]
-
- real(r8), intent(inout) :: tten_phys(plev) ! Tendency of T by the 'physics' [ K/s ]
- real(r8), intent(inout) :: uten_phys(plev) ! Tendency of u by the sum of 'physics + geostrophic forcing' [ m/s/s ]
- real(r8), intent(inout) :: vten_phys(plev) ! Tendency of v by the sum of 'physics + geostrophic forcing' [ m/s/s ]
- real(r8) qten_phys(plev,pcnst) ! Tendency of q by the 'physics' [ #/kg/s, kg/kg/s ]
- real(r8), intent(in) :: qminus(plon,plev,pcnst) ! (qminus - q3m2) / ztodt =
- ! Tendency of tracers by the 'physics' [ #/kg/s, kg/kg/s ]
-
- real(r8), intent(out) :: t3(plev) ! Temperature [ K ]
- real(r8), intent(out) :: u3(plev) ! Zonal wind [ m/s ]
- real(r8), intent(out) :: v3(plev) ! Meridional wind [ m/s ]
- real(r8), intent(inout) :: q3(plev,pcnst) ! Tracers [ #/kg, kg/kg ]
- real(r8), intent(inout) :: qfcst(plon,plev,pcnst) ! ( Input qfcst - q3m2 ) / ztodt = Tendency of q by the sum of 'physics' +
- ! 'SLT vertical advection' [ #/kg/s, kg/kg/s ]
-
-
- ! --------------- !
- ! Local Variables !
- ! --------------- !
-
- integer dummy
- integer dummy_dyndecomp
- integer i, k, m
- integer ixcldliq, ixcldice, ixnumliq, ixnumice, ioptop
- real(r8) weight, fac
- real(r8) pmidm1(plev)
- real(r8) pintm1(plevp)
- real(r8) pdelm1(plev)
- real(r8) wfldint(plevp)
- real(r8) pdelb(plon,plev)
- real(r8) tfcst(plev) ! ( tfcst - t3m2 ) / ztodt = Tendency of T by the sum of 'physics' +
- ! 'SLT/EUL/XXX vertical advection' [ K/s ]
- real(r8) ufcst(plev) ! ( ufcst - u3m2 ) / ztodt = Tendency of u by the sum of 'physics' +
- ! 'SLT/EUL/XXX vertical advection' [ m/s/s ]
- real(r8) vfcst(plev) ! ( vfcst - u3m2 ) / ztodt = Tendency of v by the sum of 'physics' +
- ! 'SLT/EUL/XXX vertical advection' [ m/s/s ]
- logical scm_fincl_empty
- ! ----------------------------------------------- !
- ! Centered Eulerian vertical advective tendencies !
- ! ----------------------------------------------- !
-
- real(r8) tten_zadv_EULc(plev) ! Vertical advective forcing of t [ K/s ]
- real(r8) uten_zadv_EULc(plev) ! Vertical advective forcing of u [ m/s/s ]
- real(r8) vten_zadv_EULc(plev) ! Vertical advective forcing of v [ m/s/s ]
- real(r8) qten_zadv_EULc(plev,pcnst) ! Vertical advective forcing of tracers [ #/kg/s, kg/kg/s ]
-
- ! --------------------------------- !
- ! SLT vertical advective tendencies !
- ! --------------------------------- !
- real(r8) qten_zadv_SLT(plev,pcnst) ! Vertical advective forcing of tracers [ #/kg/s, kg/kg/s ]
-
- ! ---------------------------- !
- ! Eulerian compression heating !
- ! ---------------------------- !
-
- real(r8) tten_comp_EUL(plev) ! Compression heating by vertical advection [ K/s ]
-
- ! ----------------------------------- !
- ! Final vertical advective tendencies !
- ! ----------------------------------- !
-
- real(r8) tten_zadv(plev) ! Vertical advective forcing of t [ K/s ]
- real(r8) uten_zadv(plev) ! Vertical advective forcing of u [ m/s/s ]
- real(r8) vten_zadv(plev) ! Vertical advective forcing of v [ m/s/s ]
- real(r8) qten_zadv(plev,pcnst) ! Vertical advective forcing of tracers [ #/kg/s, kg/kg/s ]
-
- ! --------------------------- !
- ! For 'scm_relaxation' switch !
- ! --------------------------- !
-
- real(r8) rtau(plev)
- real(r8) relax_T(plev)
- real(r8) relax_u(plev)
- real(r8) relax_v(plev)
- real(r8) relax_q(plev,pcnst)
- ! +++BPM: allow linear relaxation profile
- real(r8) rslope ! [optional] slope for linear relaxation profile
- real(r8) rycept ! [optional] y-intercept for linear relaxtion profile
-
-!+++ BPM check what we have:
- if (masterproc .and. is_first_step()) write(iulog,*) 'SCAM FORECAST REPORT: ' , &
- 'have_divq ', have_divq , &
- 'have_divt ', have_divt , &
- 'have_divq3d ', have_divq3d , &
- 'have_vertdivt ', have_vertdivt , &
- 'have_vertdivu ', have_vertdivu , &
- 'have_vertdivv ', have_vertdivv , &
- 'have_vertdivq ', have_vertdivq , &
- 'have_divt3d ', have_divt3d , &
- 'have_divu3d ', have_divu3d , &
- 'have_divv3d ', have_divv3d , &
- 'have_divu ', have_divu , &
- 'have_divv ', have_divv , &
- 'have_omega ', have_omega , &
- 'have_phis ', have_phis , &
- 'have_ptend ', have_ptend , &
- 'have_ps ', have_ps , &
- 'have_q ', have_q , &
- 'have_q1 ', have_q1 , &
- 'have_q2 ', have_q2 , &
- 'have_prec ', have_prec , &
- 'have_t ', have_t , &
- 'have_u ', have_u , &
- 'have_v ', have_v , &
- 'have_cld ', have_cld , &
- 'have_cldliq ', have_cldliq , &
- 'have_cldice ', have_cldice , &
- 'have_numliq ', have_numliq , &
- 'have_numice ', have_numice , &
- 'have_clwp ', have_clwp , &
- 'have_aldir ', have_aldir , &
- 'have_aldif ', have_aldif , &
- 'have_asdir ', have_asdir , &
- 'have_asdif ', have_asdif , &
- 'use_camiop ', use_camiop , &
- 'use_obs_uv ', scm_use_obs_uv , &
- 'use_obs_qv ', scm_use_obs_qv , &
- 'use_obs_T ', scm_use_obs_T , &
- 'relaxation ', scm_relaxation , &
- 'use_3dfrc ', use_3dfrc
-
- !---BPM
-
-
- ! ---------------------------- !
- ! !
- ! Main Computation Begins Here !
- ! !
- ! ---------------------------- !
-
- dummy = 2
- dummy_dyndecomp = 1
- ioptop = minloc(tobs(:), 1, BACK=.true.)+1
-
-
- ! ------------------------------------------------------------ !
- ! Calculate midpoint pressure levels !
- ! ------------------------------------------------------------ !
- call plevs0( nlon, plon, plev, psm1, pintm1, pmidm1, pdelm1 )
-
- call cnst_get_ind( 'CLDLIQ', ixcldliq, abort=.false. )
- call cnst_get_ind( 'CLDICE', ixcldice, abort=.false. )
- call cnst_get_ind( 'NUMLIQ', ixnumliq, abort=.false. )
- call cnst_get_ind( 'NUMICE', ixnumice, abort=.false. )
-
- ! ------------------------------------------------------------ !
- ! Extract physical tendencies of tracers q. !
- ! Note 'tten_phys, uten_phys, vten_phys' are already input. !
- ! ------------------------------------------------------------ !
-
- qten_phys(:plev,:pcnst) = ( qminus(1,:plev,:pcnst) - q3m2(:plev,:pcnst) ) / ztodt
-
- ! ----------------------------------------------------- !
- ! Extract SLT-transported vertical advective tendencies !
- ! TODO : Add in SLT transport of t u v as well !
- ! ----------------------------------------------------- !
-
- qten_zadv_SLT(:plev,:pcnst) = ( qfcst(1,:plev,:pcnst) - qminus(1,:plev,:pcnst) ) / ztodt
-
- ! ------------------------------------------------------- !
- ! use_camiop = .true. : Use CAM-generated 3D IOP file !
- ! = .false. : Use User-generated SCAM IOP file !
- ! ------------------------------------------------------- !
-
-
- if( use_camiop ) then
- do k = 1, plev
- tfcst(k) = t3m2(k) + ztodt * tten_phys(k) + ztodt * divt3d(k)
- ufcst(k) = u3m2(k) + ztodt * uten_phys(k) + ztodt * divu3d(k)
- vfcst(k) = v3m2(k) + ztodt * vten_phys(k) + ztodt * divv3d(k)
- do m = 1, pcnst
- ! Below two lines are identical but in order to reproduce the bit-by-bit results
- ! of CAM-3D simulation, I simply rewrite the 'original' into the 'expanded' one.
- ! Below is the 'original' one.
- ! qfcst(1,k,m) = q3m2(k,m) + ztodt * ( qten_phys(k,m) + divq3d(k,m) )
- ! Below is the 'expanded' one.
- qfcst(1,k,m) = qminus(1,k,m) + ztodt * divq3d(k,m)
- enddo
- enddo
-
- else
-
- ! ---------------------------------------------------------------------------- !
- ! Compute 'omega'( wfldint ) at the interface from the value at the mid-point. !
- ! SCAM-IOP file must provide omega at the mid-point not at the interface. !
- ! ---------------------------------------------------------------------------- !
-
- wfldint(1) = 0._r8
- do k = 2, plev
- weight = ( pintm1(k) - pmidm1(k-1) ) / ( pmidm1(k) - pmidm1(k-1) )
- wfldint(k) = ( 1._r8 - weight ) * wfld(k-1) + weight * wfld(k)
- enddo
- wfldint(plevp) = 0._r8
-
- ! ------------------------------------------------------------ !
- ! Compute Eulerian compression heating due to vertical motion. !
- ! ------------------------------------------------------------ !
-
- do k = 1, plev
- tten_comp_EUL(k) = wfld(k) * t3m1(k) * rair / ( cpair * pmidm1(k) )
- enddo
-
- ! ---------------------------------------------------------------------------- !
- ! Compute Centered Eulerian vertical advective tendencies for all 't, u, v, q' !
- ! ---------------------------------------------------------------------------- !
-
- do k = 2, plev - 1
- fac = 1._r8 / ( 2.0_r8 * pdelm1(k) )
- tten_zadv_EULc(k) = -fac * ( wfldint(k+1) * ( t3m1(k+1) - t3m1(k) ) + wfldint(k) * ( t3m1(k) - t3m1(k-1) ) )
- vten_zadv_EULc(k) = -fac * ( wfldint(k+1) * ( v3m1(k+1) - v3m1(k) ) + wfldint(k) * ( v3m1(k) - v3m1(k-1) ) )
- uten_zadv_EULc(k) = -fac * ( wfldint(k+1) * ( u3m1(k+1) - u3m1(k) ) + wfldint(k) * ( u3m1(k) - u3m1(k-1) ) )
- do m = 1, pcnst
- qten_zadv_EULc(k,m) = -fac * ( wfldint(k+1) * ( q3m1(k+1,m) - q3m1(k,m) ) + wfldint(k) * ( q3m1(k,m) - q3m1(k-1,m) ) )
- end do
- end do
-
- k = 1
- fac = 1._r8 / ( 2.0_r8 * pdelm1(k) )
- tten_zadv_EULc(k) = -fac * ( wfldint(k+1) * ( t3m1(k+1) - t3m1(k) ) )
- vten_zadv_EULc(k) = -fac * ( wfldint(k+1) * ( v3m1(k+1) - v3m1(k) ) )
- uten_zadv_EULc(k) = -fac * ( wfldint(k+1) * ( u3m1(k+1) - u3m1(k) ) )
- do m = 1, pcnst
- qten_zadv_EULc(k,m) = -fac * ( wfldint(k+1) * ( q3m1(k+1,m) - q3m1(k,m) ) )
- end do
-
- k = plev
- fac = 1._r8 / ( 2.0_r8 * pdelm1(k) )
- tten_zadv_EULc(k) = -fac * ( wfldint(k) * ( t3m1(k) - t3m1(k-1) ) )
- vten_zadv_EULc(k) = -fac * ( wfldint(k) * ( v3m1(k) - v3m1(k-1) ) )
- uten_zadv_EULc(k) = -fac * ( wfldint(k) * ( u3m1(k) - u3m1(k-1) ) )
- do m = 1, pcnst
- qten_zadv_EULc(k,m) = -fac * ( wfldint(k) * ( q3m1(k,m) - q3m1(k-1,m) ) )
- end do
-
- ! ------------------------------------- !
- ! Manupulate individual forcings before !
- ! computing the final forecasted state !
- ! ------------------------------------- !
-
- ! -------------------------------------------------------------- !
- ! Select the type of vertical advection : EULc,IOP,OFF supported!
- ! -------------------------------------------------------------- !
-
- select case (scm_zadv_T)
- case ('iop')
- if (have_vertdivt) then
- tten_zadv(:plev) = vertdivt(:plev)
- else
- call endrun( subname//':: user set scm_zadv_tten to iop but vertdivt not on file')
- end if
- case ('eulc')
- tten_zadv(:) = tten_zadv_EULc(:) + tten_comp_EUL(:)
- case ('off')
- tten_zadv(:) = 0._r8
- end select
-
- select case (scm_zadv_uv)
- case ('iop')
- if (have_vertdivu .and. have_vertdivv) then
- uten_zadv(:) = vertdivu(:)
- vten_zadv(:) = vertdivv(:)
- else
- call endrun( subname//':: user set scm_zadv_uv to iop but vertdivu/v not on file')
- end if
- case ('eulc')
- uten_zadv(:) = uten_zadv_EULc(:)
- vten_zadv(:) = vten_zadv_EULc(:)
- case ('off')
- uten_zadv(:) = 0._r8
- vten_zadv(:) = 0._r8
- end select
-
- select case (scm_zadv_q)
- case ('iop')
- if (have_vertdivq) then
- qten_zadv(:plev,:pcnst) = vertdivq(:plev,:pcnst)
- else
- call endrun( subname//':: user set scm_zadv_qten to iop but vertdivq not on file')
- end if
- case ('eulc')
- qten_zadv(:plev,:pcnst) = qten_zadv_EULc(:plev,:pcnst)
- case ('slt')
- qten_zadv = qten_zadv_SLT
- case ('off')
- qten_zadv = 0._r8
- end select
-
- ! -------------------------------------------------------------- !
- ! Check horizontal advection u,v,t,q !
- ! -------------------------------------------------------------- !
- if (.not. have_divu) divu=0._r8
- if (.not. have_divv) divv=0._r8
- if (.not. have_divt) divt=0._r8
- if (.not. have_divq) divq=0._r8
-
- ! ----------------------------------- !
- ! !
- ! Compute the final forecasted states !
- ! !
- ! ----------------------------------- !
- ! make sure we have everything !
- ! ----------------------------------- !
-
- if( .not. scm_use_obs_uv .and. .not. have_divu .and. .not. have_divv ) then
- call endrun( subname//':: divu and divv not on the iop Unable to forecast Wind Set &
- scm_use_obs_uv=true to use observed u and v')
- end if
- if( .not. scm_use_obs_T .and. .not. have_divt) then
- call endrun( subname//':: divt not on the dataset. Unable to forecast Temperature. Stopping')
- end if
- if( .not. scm_use_obs_qv .and. .not. have_divq) then
- call endrun( subname//':: divq not on the dataset. Unable to forecast Humidity. Stopping')
- end if
-
- do k = 1, plev
- tfcst(k) = t3m2(k) + ztodt * ( tten_phys(k) + divt(k) + tten_zadv(k) )
- ufcst(k) = u3m2(k) + ztodt * ( uten_phys(k) + divu(k) + uten_zadv(k) )
- vfcst(k) = v3m2(k) + ztodt * ( vten_phys(k) + divv(k) + vten_zadv(k) )
- do m = 1, pcnst
- qfcst(1,k,m) = q3m2(k,m) + ztodt * ( qten_phys(k,m) + divq(k,m) + qten_zadv(k,m) )
- enddo
- enddo
-
- ! ------------------ !
- ! Diagnostic Outputs !
- ! ------------------ !
-
- call outfld( 'TTEN_XYADV' , divt, plon, dummy_dyndecomp )
- call outfld( 'UTEN_XYADV' , divu, plon, dummy_dyndecomp )
- call outfld( 'VTEN_XYADV' , divv, plon, dummy_dyndecomp )
- call outfld( 'QVTEN_XYADV', divq(:,1), plon, dummy_dyndecomp )
- if (.not.adiabatic) then
- call outfld( 'QLTEN_XYADV', divq(:,ixcldliq), plon, dummy_dyndecomp )
- call outfld( 'QITEN_XYADV', divq(:,ixcldice), plon, dummy_dyndecomp )
- call outfld( 'NLTEN_XYADV', divq(:,ixnumliq), plon, dummy_dyndecomp )
- call outfld( 'NITEN_XYADV', divq(:,ixnumice), plon, dummy_dyndecomp )
- call outfld( 'QLTEN_ZADV' , qten_zadv(:,ixcldliq), plon, dummy_dyndecomp )
- call outfld( 'QITEN_ZADV' , qten_zadv(:,ixcldice), plon, dummy_dyndecomp )
- call outfld( 'NLTEN_ZADV' , qten_zadv(:,ixnumliq), plon, dummy_dyndecomp )
- call outfld( 'NITEN_ZADV' , qten_zadv(:,ixnumice), plon, dummy_dyndecomp )
- call outfld( 'QLTEN_PHYS' , qten_phys(:,ixcldliq), plon, dummy )
- call outfld( 'QITEN_PHYS' , qten_phys(:,ixcldice), plon, dummy )
- call outfld( 'NLTEN_PHYS' , qten_phys(:,ixnumliq), plon, dummy )
- call outfld( 'NITEN_PHYS' , qten_phys(:,ixnumice), plon, dummy )
- end if
- call outfld( 'TTEN_ZADV' , tten_zadv, plon, dummy_dyndecomp )
- call outfld( 'UTEN_ZADV' , uten_zadv, plon, dummy_dyndecomp )
- call outfld( 'VTEN_ZADV' , vten_zadv, plon, dummy_dyndecomp )
- call outfld( 'QVTEN_ZADV' , qten_zadv(:,1), plon, dummy_dyndecomp )
- call outfld( 'TTEN_ZADV' , vertdivt, plon, dummy_dyndecomp )
- call outfld( 'QVTEN_ZADV' , vertdivq(:,1), plon, dummy_dyndecomp )
-
- call outfld( 'TTEN_PHYS' , tten_phys, plon, dummy )
- call outfld( 'UTEN_PHYS' , uten_phys, plon, dummy )
- call outfld( 'VTEN_PHYS' , vten_phys, plon, dummy )
- call outfld( 'QVTEN_PHYS' , qten_phys(:,1), plon, dummy )
-
- endif
-
- ! ---------------------------------------------------------------- !
- ! Used the SCAM-IOP-specified state instead of forecasted state !
- ! at each time step if specified by the switch. !
- ! If SCAM-IOP has 't,u,v,q' profile at a single initial time step. !
- ! ---------------------------------------------------------------- !
-
- if( scm_use_obs_T .and. have_t ) then
- do k = 1, plev
- tfcst(k) = tobs(k)
- enddo
- endif
-
- if( scm_use_obs_uv .and. have_u .and. have_v ) then
- ufcst(:plev) = uobs(:plev)
- vfcst(:plev) = vobs(:plev)
- endif
-
- if( scm_use_obs_qv .and. have_q ) then
- do k = 1, plev
- qfcst(1,k,1) = qobs(k)
- enddo
- endif
-
- !If not using camiop then fillt tobs/qobs with background CAM state above IOP top before t3/q3 update below
- if( .not. use_camiop ) then
- tobs(1:ioptop-1)=t3(1:ioptop-1)
- qobs(1:ioptop-1)=q3(1:ioptop-1,1)
- end if
- ! ------------------------------------------------------------------- !
- ! Relaxation to the observed or specified state !
- ! We should specify relaxation time scale ( rtau ) and !
- ! target-relaxation state ( in the current case, either 'obs' or 0 ) !
- ! ------------------------------------------------------------------- !
-
- relax_T(:) = 0._r8
- relax_u(:) = 0._r8
- relax_v(:) = 0._r8
- relax_q(:plev,:pcnst) = 0._r8
- ! +++BPM: allow linear relaxation profile
- ! scm_relaxation is a logical from scamMod
- ! scm_relax_tau_top_sec and scm_relax_tau_bot_sec are the relaxation times at top and bottom of layer
- ! also defined in scamMod
- if ( scm_relaxation.and.scm_relax_linear ) then
- rslope = (scm_relax_top_p - scm_relax_bot_p)/(scm_relax_tau_top_sec - scm_relax_tau_bot_sec)
- rycept = scm_relax_tau_top_sec - (rslope*scm_relax_top_p)
- endif
-
- ! prepare scm_relax_fincl for comparison in scmforecast.F90
- scm_fincl_empty=.true.
- do i=1,pcnst
- if (len_trim(scm_relax_fincl(i)) > 0) then
- scm_fincl_empty=.false.
- scm_relax_fincl(i)=trim(to_upper(scm_relax_fincl(i)))
- end if
- end do
-
- do k = 1, plev
- if( scm_relaxation ) then
- if ( pmidm1(k)<=scm_relax_bot_p.and.pmidm1(k) >= scm_relax_top_p ) then ! inside layer
- if (scm_relax_linear) then
- rtau(k) = rslope*pmidm1(k) + rycept ! linear regime
- else
- rtau(k) = max( ztodt, scm_relax_tau_sec ) ! constant for whole layer / no relax outside
- endif
- else if (scm_relax_linear .and. pmidm1(k)<=scm_relax_top_p ) then ! not linear => do nothing / linear => use upper value
- rtau(k) = scm_relax_tau_top_sec ! above layer keep rtau equal to the top
- endif
- ! +BPM: this can't be the best way...
- ! I put this in because if rtau doesn't get set above, then I don't want to do any relaxation in that layer.
- ! maybe the logic of this whole loop needs to be re-thinked.
- if (rtau(k) /= 0) then
- relax_T(k) = - ( tfcst(k) - tobs(k) ) / rtau(k)
- relax_u(k) = - ( ufcst(k) - uobs(k) ) / rtau(k)
- relax_v(k) = - ( vfcst(k) - vobs(k) ) / rtau(k)
- relax_q(k,1) = - ( qfcst(1,k,1) - qobs(k) ) / rtau(k)
- do m = 2, pcnst
- relax_q(k,m) = - ( qfcst(1,k,m) - qinitobs(k,m) ) / rtau(k)
- enddo
- if (scm_fincl_empty .or. ANY(scm_relax_fincl(:)=='T')) &
- tfcst(k) = tfcst(k) + relax_T(k) * ztodt
- if (scm_fincl_empty .or.ANY(scm_relax_fincl(:)=='U')) &
- ufcst(k) = ufcst(k) + relax_u(k) * ztodt
- if (scm_fincl_empty .or. ANY(scm_relax_fincl(:)=='V')) &
- vfcst(k) = vfcst(k) + relax_v(k) * ztodt
- do m = 1, pcnst
- if (scm_fincl_empty .or. ANY(scm_relax_fincl(:) == trim(to_upper(cnst_name(m)))) ) then
- qfcst(1,k,m) = qfcst(1,k,m) + relax_q(k,m) * ztodt
- end if
- enddo
- end if
- endif
- enddo
- call outfld( 'TRELAX' , relax_T , plon, dummy )
- call outfld( 'QRELAX' , relax_q(1:plev,1) , plon, dummy )
- call outfld( 'TAURELAX' , rtau , plon, dummy )
-
- ! --------------------------------------------------------- !
- ! Assign the final forecasted state to the output variables !
- ! --------------------------------------------------------- !
-
- t3(1:plev) = tfcst(1:plev)
- u3(1:plev) = ufcst(1:plev)
- v3(1:plev) = vfcst(1:plev)
- q3(1:plev,1:pcnst) = qfcst(1,1:plev,1:pcnst)
-
- tdiff(1:plev) = t3(1:plev) - tobs(1:plev)
- qdiff(1:plev) = q3(1:plev,1) - qobs(1:plev)
-
- call outfld( 'QDIFF' , qdiff, plon, dummy_dyndecomp )
- call outfld( 'TDIFF' , tdiff, plon, dummy_dyndecomp )
-
- return
-
- end subroutine forecast
- end module scmforecast
diff --git a/src/dynamics/eul/settau.F90 b/src/dynamics/eul/settau.F90
deleted file mode 100644
index 80ec456e00..0000000000
--- a/src/dynamics/eul/settau.F90
+++ /dev/null
@@ -1,543 +0,0 @@
-subroutine settau(zdt)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Set time invariant hydrostatic matrices, which depend on the reference
-! temperature and pressure in the semi-implicit time step. Note that
-! this subroutine is actually called twice, because the effective time
-! step changes between step 0 and step 1.
-!
-! Method:
-! zdt = delta t for next semi-implicit time step.
-!
-! Author: CCM1
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use commap
- use physconst, only: cappa, rair, gravit
- use cam_abortutils, only: endrun
- use spmd_utils, only: masterproc
- use hycoef, only : hypi, hybi, hypd
- use sgexx, only: dgeco, dgedi
- use cam_logfile, only: iulog
-
- implicit none
-
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: zdt ! time step (or dt/2 at time 0)
-!---------------------------Local workspace-----------------------------
- real(r8) aq(plev,plev)
- real(r8) rcond,z(plev),det(2),work(plev)
- integer ipvt(plev)
- real(r8) zcr(plev) ! gravity wave equivalent depth
- real(r8) zci(plev) ! dummy, used to print phase speeds
- real(r8) zdt2 ! zdt**2
- real(r8) factor ! intermediate workspace
- real(r8) zdt0u ! vertical diff. of ref. temp (above)
- real(r8) zshu ! interface "sigma" (above)
- real(r8) zr2ds ! 1./(2.*hypd(k))
- real(r8) zdt0d ! vertical diff. of ref. temp (below)
- real(r8) zshd ! interface "sigma" (below)
- real(r8) ztd ! temporary accumulator
- real(r8) zcn ! sq(n)
- real(r8) zb(plev,plev) ! semi-implicit matrix in d equation
- real(r8), save :: zdt_init=0 ! reinitialize if zdt <> zdt_init
-
- integer k,kk,kkk ! level indices
- integer n ! n-wavenumber index
- integer nneg ! number of unstable mean temperatures
-!-----------------------------------------------------------------------
-!
- if (zdt == zdt_init) return
-
-! save dt for which this code has performed the initialization
- zdt_init=zdt
-
- zdt2 = zdt*zdt
-!
-! Set mean temperature
-! NOTE: Making t0 an actual function of height ***DOES NOT WORK***
-!
- do k=1,plev
- t0(k) = 300._r8
- end do
-!
-! Calculate hydrostatic matrix tau
-!
- zdt0u = 0._r8
- zshu = 0._r8
- do k=1,plev
- zr2ds = 1._r8/(2._r8*hypd(k))
- if (k < plev) then
- zdt0d = t0(k+1) - t0(k)
- zshd = hybi(k+1)
- else
- zdt0d = 0._r8
- zshd = 0._r8
- end if
-
- factor = ((zdt0u*zshu + zdt0d*zshd) - (zdt0d + zdt0u))*zr2ds
- do kk=1,k-1
- tau(kk,k) = factor*hypd(kk) + cappa*t0(k)*ecref(kk,k)
- end do
-
- factor = (zdt0u*zshu + zdt0d*zshd - zdt0d)*zr2ds
- tau(k,k) = factor*hypd(k) + cappa*t0(k)*ecref(k,k)
-
- factor = (zdt0u*zshu + zdt0d*zshd)*zr2ds
- do kk=k+1,plev
- tau(kk,k) = factor*hypd(kk)
- end do
- zdt0u = zdt0d
- zshu = zshd
- end do
-!
-! Vector for linear surface pressure term in divergence
-! Pressure gradient and diagonal term of hydrostatic components
-!
- do k=1,plev
- bps(k) = t0(k)
- bps(k) = bps(k)*rair
- end do
- do k=1,plev
- do kk=1,plev
- ztd = bps(k) * hypd(kk)/hypi(plevp)
- do kkk=1,plev
- ztd = ztd + href(kkk,k)*tau(kk,kkk)
- end do
- zb(kk,k) = ztd
- aq(kk,k) = ztd
- end do
- end do
-!
-! Compute and print gravity wave equivalent depths and phase speeds
-!
- call qreig(zb ,plev ,zcr )
-
- do k=1,plev
- zci(k) = sign(1._r8,zcr(k))*sqrt(abs(zcr(k)))
- zcr(k) = zcr(k) / gravit
- end do
-
- if (masterproc) then
- write(iulog,910) (t0(k),k=1,plev)
- write(iulog,920) (zci(k),k=1,plev)
- write(iulog,930) (zcr(k),k=1,plev)
- end if
-!
-! Test for unstable mean temperatures (negative phase speed and eqivalent
-! depth) for at least one gravity wave.
-!
- nneg = 0
- do k=1,plev
- if (zcr(k)<=0._r8) nneg = nneg + 1
- end do
-
- if (nneg/=0) then
- call endrun ('SETTAU: UNSTABLE MEAN TEMPERATURE.')
- end if
-!
-! Compute and invert matrix a(n)=(i+sq*b*delt**2)
-!
- do k=1,plev
- do kk=1,plev
- aq(kk,k) = aq(kk,k)*zdt2
- bm1(kk,k,1) = 0._r8
- end do
- end do
- do n=2,pnmax
- zcn = sq(n)
- do k=1,plev
- do kk=1,plev
- zb(kk,k) = zcn*aq(kk,k)
- if(kk.eq.k) zb(kk,k) = zb(kk,k) + 1._r8
- end do
- end do
-!
-! Use linpack routines to invert matrix
-!
- call dgeco(zb,plev,plev,ipvt,rcond,z)
- call dgedi(zb,plev,plev,ipvt,det,work,01)
- do k=1,plev
- do kk=1,plev
- bm1(kk,k,n) = zb(kk,k)
- end do
- end do
- end do
-
-910 format(' REFERENCE TEMPERATURES FOR SEMI-IMPLICIT SCHEME = ', /(1x,12f9.3))
-920 format(' GRAVITY WAVE PHASE SPEEDS (M/S) FOR MEAN STATE = ' /(1x,12f9.3))
-930 format(' GRAVITY WAVE EQUIVALENT DEPTHS (M) FOR MEAN STATE = ' /(1x,12f9.3))
-
- return
-end subroutine settau
-
-!============================================================================================
-
-subroutine qreig(a ,i ,b )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Create complex matrix P with real part = A and imaginary part = 0
-! Find its eigenvalues and return their real parts.
-!
-! Method:
-! This routine is of unknown lineage. It is only used to provide the
-! equivalent depths of the reference atmosphere for a diagnostic print
-! in SETTAU and has no effect on the model simulation. Therefore it can
-! be replaced at any time with a functionally equivalent, but more
-! understandable, procedure. Consequently, the internal commenting has
-! not been brought up to CAM standards.
-!
-! Author:
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- implicit none
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: a(*) ! Input real part
- integer , intent(in) :: i
- real(r8), intent(out) :: b(*)
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- complex(r8) p(plev*plev)
- complex(r8) q(plev*plev)
- integer l,ij,ik ! indicies
-!-----------------------------------------------------------------------
-!
-! l = 0
-! do ij=1,i
-! do ik=1,i
-! l = l + 1
-! p(l) = cmplx(a(l),0._r8,r8)
-! end do
-! end do
-
- do l = 1, i*i
- p(l) = cmplx( a(l), 0.0_r8, r8)
- end do
-
- call cmphes(p ,i ,1 ,i )
- call cmplr(p ,q ,i)
-
- do ij=1,i
- b(ij) = real(q(ij),r8)
- end do
-
- return
-end subroutine qreig
-
-!============================================================================================
-
-subroutine cmphes(ac ,nac ,k ,l )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Reduce complex matrix (ac) to upper Hessenburg matrix (ac)
-!
-! Method:
-! This routine is of unknown lineage. It is only used to provide the
-! equivalent depths of the reference atmosphere for a diagnostic print
-! in SETTAU and has no effect on the model simulation. Therefore it can
-! be replaced at any time with a functionally equivalent, but more
-! understandable, procedure. Consequently, the internal commenting has
-! not been brought up to CCM3 or CAM standards.
-!
-! Author:
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer, intent(in) :: nac ! Dimension of one side of matrix ac
- integer, intent(in) :: k,l !
- complex(r8), intent(inout) :: ac(nac,nac) ! On input, complex matrix to be converted
- ! On output, upper Hessenburg matrix
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- complex(r8) x
- complex(r8) y
- integer la
- integer m1
- integer i,m,j ! Indices
- integer j1,i1 ! Loop limits
-!-----------------------------------------------------------------------
-!
- la = l - 1
- m1 = k + 1
- do m=m1,la
- i = m
- x = (0.0_r8,0.0_r8)
- do j=m,l
- if (abs(ac(j,m-1))>abs(x)) then
- x = ac(j,m-1)
- i = j
- end if
- end do
- if (i/=m) then
- j1 = m - 1
- do j=j1,nac
- y = ac(i,j)
- ac(i,j) = ac(m,j)
- ac(m,j) = y
- end do
- do j=1,l
- y = ac(j,i)
- ac(j,i) = ac(j,m)
- ac(j,m) = y
- end do
- end if
- if (x/=(0.0_r8,0.0_r8)) then
- i1 = m + 1
- do i=i1,l
- y = ac(i,m-1)
- if (y/=(0.0_r8,0.0_r8)) then
- y = y/x
- ac(i,m-1) = y
- do j=m,nac
- ac(i,j) = ac(i,j) - y*ac(m,j)
- end do
- do j=1,l
- ac(j,m) = ac(j,m) + y*ac(j,i)
- end do
- end if
- end do
- end if
- end do
-
- return
-end subroutine cmphes
-
-!============================================================================================
-
-subroutine cmplr(hes ,w ,nc)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute w, eigenvalues of upper Hessenburg matrix hes
-!
-! Method:
-! This routine is of unknown lineage. It is only used to provide the
-! equivalent depths of the reference atmosphere for a diagnostic print
-! in SETTAU and has no effect on the model simulation. Therefore it can
-! be replaced at any time with a functionally equivalent, but more
-! understandable, procedure. Consequently, the internal commenting has
-! not been brought up to CCM3 or CAM standards.
-!
-! Author:
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use cam_abortutils, only: endrun
- use cam_logfile, only: iulog
-
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nc ! Dimension of input and output matrices
- complex(r8), intent(inout) :: hes(nc,nc) ! Upper hessenberg matrix from comhes
- complex(r8), intent(out):: w(nc) ! Weights
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer itest
- integer nfail ! Limit for number of iterations to convergence
- integer ntest
- integer n,j,m
- integer i ! Eigenvalue
- integer its ! Iteration counter
- integer l
- integer l1,m1,n1,i1
- real(r8) a
- real(r8) sr
- real(r8) si
- real(r8) tr
- real(r8) ti
- real(r8) xr
- real(r8) yr
- real(r8) zr
- real(r8) xi
- real(r8) yi
- real(r8) areal
- real(r8) eps
- complex(r8) s
- complex(r8) t
- complex(r8) x
- complex(r8) y
- complex(r8) z
- complex(r8) u
-
- data itest/0/
- save a,eps,sr,itest
-!-----------------------------------------------------------------------
-!
- nfail = 30
- if (itest==0) then
- a = 1
-5 continue
- eps = a
- sr = 1 + a
- a = a/2.0_r8
- if (sr/=1.0_r8) go to 5
- itest = 1
- end if
- if (nc.le.0) then
- write(iulog,*)'CMPLR: Entered with incorrect dimension '
- write(iulog,*)'NC=',NC
- call endrun
- end if
- ntest = 10
- n = nc
- t = 0.0_r8
-10 continue
- if (n==0) go to 300
- its = 0
-20 continue
- if (n/=1) then
- do l1=2,n
- l = n + 2 - l1
- if (abs(hes(l,l-1)) <= eps*(abs(hes(l-1,l-1))+abs(hes(l,l)))) go to 50
- end do
- end if
- l = 1
-50 continue
- if (l/=n) then
- if (its==nfail) then
- i = nc - n + 1
- write(iulog,*)'CMPLR: Failed to converge in ',nfail,' iterations'
- write(iulog,*)'Eigenvalue=',i
- call endrun
- end if
- if (its==ntest) then
- ntest = ntest + 10
- sr = hes(n,n-1)
- si = hes(n-1,n-2)
- sr = abs(sr)+abs(si)
- u = (0.0_r8,-1.0_r8)*hes(n,n-1)
- tr = u
- u = (0.0_r8,-1.0_r8)*hes(n-1,n-2)
- ti = u
- tr = abs(tr) + abs(ti)
- s = cmplx(sr,tr)
- else
- s = hes(n,n)
- x = hes(n-1,n)*hes(n,n-1)
- if (abs(x)/=0.0_r8) then
- y = 0.5_r8*(hes(n-1,n-1)-s)
- u = y*y + x
- z = sqrt(u)
- u = conjg(z)*y
- areal = u
- if (areal<0.0_r8) z = -z
- x = x/(y+z)
- s = s - x
- end if
- end if
- do i=1,n
- hes(i,i) = hes(i,i) - s
- end do
- t = t + s
- its = its + 1
- j = l + 1
- xr = abs(hes(n-1,n-1))
- yr = abs(hes(n,n-1))
- zr = abs(hes(n,n))
- n1 = n - 1
- if ((n1/=1).and.(n1>=j)) then
- do m1=j,n1
- m = n1 + j - m1
- yi = yr
- yr = abs(hes(m,m-1))
- xi = zr
- zr = xr
- xr = abs(hes(m-1,m-1))
- if (yr.le.eps*zr/yi*(zr+xr+xi)) go to 100
- end do
- end if
- m = l
-100 continue
- m1 = m + 1
- do i=m1,n
- x = hes(i-1,i-1)
- y = hes(i,i-1)
- if (abs(x)<abs(y)) then
- i1 = i - 1
- do j=i1,n
- z = hes(i-1,j)
- hes(i-1,j) = hes(i,j)
- hes(i,j) = z
- end do
- z = x/y
- w(i) = 1.0_r8
- else
- z = y/x
- w(i) = -1.0_r8
- end if
- hes(i,i-1) = z
- do j=i,n
- hes(i,j) = hes(i,j) - z*hes(i-1,j)
- end do
- end do
- m1 = m + 1
- do j=m1,n
- x = hes(j,j-1)
- hes(j,j-1) = 0.0_r8
- areal = w(j)
- if (areal>0.0_r8) then
- do i=l,j
- z = hes(i,j-1)
- hes(i,j-1) = hes(i,j)
- hes(i,j) = z
- end do
- end if
- do i=l,j
- hes(i,j-1) = hes(i,j-1) + x*hes(i,j)
- end do
- end do
- go to 20
- end if
- w(n) = hes(n,n) + t
- n = n - 1
- go to 10
-300 continue
-
- return
-end subroutine cmplr
-
diff --git a/src/dynamics/eul/spegrd.F90 b/src/dynamics/eul/spegrd.F90
deleted file mode 100644
index 0c89afa941..0000000000
--- a/src/dynamics/eul/spegrd.F90
+++ /dev/null
@@ -1,512 +0,0 @@
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Transfrom variables from spherical harmonic coefficients
-! to grid point values during second gaussian latitude scan (scan2)
-!
-! Method:
-! Assemble northern and southern hemisphere grid values from the
-! symmetric and antisymmetric fourier coefficients.
-! 1. Determine the fourier coefficients for the northern or southern
-! hemisphere latitude.
-! 2. Transform to gridpoint values
-! 3. Clean up
-!
-! Author:
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, J. Hack, August 1992
-! Reviewed: B. Boville, April 1996
-! Modified: P. Worley, September 2002
-!
-!-----------------------------------------------------------------------
-!
-
-subroutine spegrd_bft (lat ,nlon_fft, &
- grdps ,grzs ,grds ,gruhs ,grvhs , &
- grths ,grpss ,grus ,grvs ,grts , &
- grpls ,grpms ,grdpa ,grza ,grda , &
- gruha ,grvha ,grtha ,grpsa ,grua , &
- grva ,grta ,grpla ,grpma ,fftbuf )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Preparation for transform of variables from spherical harmonic
-! coefficients to grid point values during second gaussian latitude scan
-! (scan2)
-!
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, J. Hack, August 1992
-! Reviewed: B. Boville, April 1996
-! Modified: P. Worley, September 2002
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plat, plev, plevp
- use spmd_utils, only: iam
- use comspe, only: maxm, numm
-!-----------------------------------------------------------------------
- implicit none
-!---------------------------------------------------------------------
-!
-! Arguments
-!
- integer, intent(in) :: lat ! latitude index
- integer, intent(in) :: nlon_fft ! first dimension of FFT work array
-!
-! Symmetric fourier coefficient arrays for all variables transformed
-! from spherical harmonics (see grcalc)
-!
- real(r8), intent(in) :: grdps(2*maxm) ! sum(n) of K(4)*(n(n+1)/a**2)**2*2dt*lnps(n,m)*P(n,m)
- real(r8), intent(in) :: grzs(2*maxm,plev) ! sum(n) of z(n,m)*P(n,m)
- real(r8), intent(in) :: grds(2*maxm,plev) ! sum(n) of d(n,m)*P(n,m)
- real(r8), intent(in) :: gruhs(2*maxm,plev) ! sum(n) of K(2i)*z(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(in) :: grvhs(2*maxm,plev) ! sum(n) of K(2i)*d(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(in) :: grths(2*maxm,plev) ! sum(n) of K(2i)*t(n,m)*P(n,m)
- real(r8), intent(in) :: grpss(2*maxm) ! sum(n) of lnps(n,m)*P(n,m)
- real(r8), intent(in) :: grus(2*maxm,plev) ! sum(n) of z(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(in) :: grvs(2*maxm,plev) ! sum(n) of d(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(in) :: grts(2*maxm,plev) ! sum(n) of t(n,m)*P(n,m)
- real(r8), intent(in) :: grpls(2*maxm) ! sum(n) of lnps(n,m)*P(n,m)*m/a
- real(r8), intent(in) :: grpms(2*maxm) ! sum(n) of lnps(n,m)*H(n,m)
-!
-! Antisymmetric fourier coefficient arrays for all variables transformed
-! from spherical harmonics (see grcalc)
-!
- real(r8), intent(in) :: grdpa(2*maxm) ! sum(n) of K(4)*(n(n+1)/a**2)**2*2dt*lnps(n,m)*P(n,m)
- real(r8), intent(in) :: grza(2*maxm,plev) ! sum(n) of z(n,m)*P(n,m)
- real(r8), intent(in) :: grda(2*maxm,plev) ! sum(n) of d(n,m)*P(n,m)
- real(r8), intent(in) :: gruha(2*maxm,plev) ! sum(n)K(2i)*z(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(in) :: grvha(2*maxm,plev) ! sum(n)K(2i)*d(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(in) :: grtha(2*maxm,plev) ! sum(n) of K(2i)*t(n,m)*P(n,m)
- real(r8), intent(in) :: grpsa(2*maxm) ! sum(n) of lnps(n,m)*P(n,m)
- real(r8), intent(in) :: grua(2*maxm,plev) ! sum(n) of z(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(in) :: grva(2*maxm,plev) ! sum(n) of d(n,m)*H(n,m)*a/(n(n+1))
- real(r8), intent(in) :: grta(2*maxm,plev) ! sum(n) of t(n,m)*P(n,m)
- real(r8), intent(in) :: grpla(2*maxm) ! sum(n) of lnps(n,m)*P(n,m)*m/a
- real(r8), intent(in) :: grpma(2*maxm) ! sum(n) of lnps(n,m)*H(n,m)
-
- real(r8), intent(out) :: fftbuf(nlon_fft,8,plevp) ! buffer used for in-place FFTs
-
-!
-!---------------------------Local workspace-----------------------------
-!
- integer i,k ! longitude, level indices
- integer rmlength ! twice number of local wavenumbers
- integer, parameter :: vortdex = 1 ! indices into fftbuf
- integer, parameter :: divdex = 2
- integer, parameter :: duhdex = 3
- integer, parameter :: dvhdex = 4
- integer, parameter :: dthdex = 5
- integer, parameter :: u3dex = 6
- integer, parameter :: v3dex = 7
- integer, parameter :: t3dex = 8
- integer, parameter :: dpsdex = 1
- integer, parameter :: psdex = 2
- integer, parameter :: dpsldex = 3
- integer, parameter :: dpsmdex = 4
-!
-!-----------------------------------------------------------------------
-!
-! Assemble northern and southern hemisphere grid values from the
-! symmetric and antisymmetric fourier coefficients: pre-FFT
-!
- rmlength = 2*numm(iam)
- if (lat > plat/2) then ! Northern hemisphere
- do k=1,plev
- do i=1,rmlength
- fftbuf(i,vortdex,k) = grzs(i,k) + grza(i,k)
- fftbuf(i,divdex,k) = grds(i,k) + grda(i,k)
- fftbuf(i,duhdex,k) = gruhs(i,k) + gruha(i,k)
- fftbuf(i,dvhdex,k) = grvhs(i,k) + grvha(i,k)
- fftbuf(i,dthdex,k) = grths(i,k) + grtha(i,k)
- fftbuf(i,u3dex,k) = grus(i,k) + grua(i,k)
- fftbuf(i,v3dex,k) = grvs(i,k) + grva(i,k)
- fftbuf(i,t3dex,k) = grts(i,k) + grta(i,k)
- end do
- end do
-!
- do i=1,rmlength
- fftbuf(i,dpsdex,plevp) = grdps(i) + grdpa(i)
- fftbuf(i,psdex,plevp) = grpss(i) + grpsa(i)
- fftbuf(i,dpsldex,plevp) = grpls(i) + grpla(i)
- fftbuf(i,dpsmdex,plevp) = grpms(i) + grpma(i)
- end do
-
- else ! Southern hemisphere
-
- do k=1,plev
- do i=1,rmlength
- fftbuf(i,vortdex,k) = grzs(i,k) - grza(i,k)
- fftbuf(i,divdex,k) = grds(i,k) - grda(i,k)
- fftbuf(i,duhdex,k) = gruhs(i,k) - gruha(i,k)
- fftbuf(i,dvhdex,k) = grvhs(i,k) - grvha(i,k)
- fftbuf(i,dthdex,k) = grths(i,k) - grtha(i,k)
- fftbuf(i,u3dex,k) = grus(i,k) - grua(i,k)
- fftbuf(i,v3dex,k) = grvs(i,k) - grva(i,k)
- fftbuf(i,t3dex,k) = grts(i,k) - grta(i,k)
- end do
- end do
-
- do i=1,rmlength
- fftbuf(i,dpsdex,plevp) = grdps(i) - grdpa(i)
- fftbuf(i,psdex,plevp) = grpss(i) - grpsa(i)
- fftbuf(i,dpsldex,plevp) = grpls(i) - grpla(i)
- fftbuf(i,dpsmdex,plevp) = grpms(i) - grpma(i)
- end do
-
- end if
-
- return
-end subroutine spegrd_bft
-
-subroutine spegrd_ift (nlon_fft_in, nlon_fft_out, fftbuf_in, fftbuf_out)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Inverse Fourier transform of variables from spherical harmonic
-! coefficients to grid point values during second gaussian latitude scan
-! (scan2)
-!
-! Author: P. Worley, September 2002
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plat, plevp, beglat, endlat, plev
- use comspe, only: maxm
- use pspect, only: pmmax
-#if ( defined SPMD )
- use mpishorthand
-#endif
- use eul_control_mod, only : trig, ifax, pcray
- use perf_mod
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-
-!---------------------------------------------------------------------
-!
-! Arguments
-!
-!
-! Input arguments
-!
- integer, intent(in) :: nlon_fft_in ! first dimension of first FFT work array
- integer, intent(in) :: nlon_fft_out ! first dimension of second FFT work array
-#if (defined SPMD)
- real(r8), intent(in) :: fftbuf_in(nlon_fft_in,8,plevp,plat)
- ! buffer containing fields dcomposed over wavenumbers
-#else
- real(r8), intent(in) :: fftbuf_in(1,1,1,1)
- ! buffer unused
-#endif
-!
-! Input/Output arguments
-!
- real(r8), intent(inout) :: fftbuf_out(nlon_fft_out,8,plevp,beglat:endlat)
- ! buffer used for in-place FFTs
-!
-!---------------------------Local workspace-----------------------------
-!
-#if ( ! defined USEFFTLIB )
- real(r8) work((plon+1)*8*plevp)
-#else
- real(r8) work((plon+1)*pcray) ! workspace needed by fft991
-#endif
- integer lat ! latitude index
- integer isign ! +1 => transform spectral to grid
- integer ntr ! number of transforms to perform
- integer inc ! distance between transform elements
- integer begtrm ! (real) location of first truncated wavenumber
- integer k, ifld ! level and field indices
-!
-!-----------------------------------------------------------------------
-!
-!
-#if ( defined SPMD )
-!
-! reorder Fourier coefficients
-!
- call t_barrierf ('sync_realloc4b', mpicom)
- call t_startf('realloc4b')
- call realloc4b(nlon_fft_in, nlon_fft_out, fftbuf_in, fftbuf_out)
- call t_stopf('realloc4b')
-#endif
-!
-! Zero elements corresponding to truncated wavenumbers, then
-! transform from fourier coefficients to gridpoint values.
-! ps,vort,div,duh,dvh,dth,dpsl,dpsm,dps,
-! u,v,t (SLT) [If you want to do spectral transport, do q as well]
-!
- begtrm = 2*pmmax+1
- inc = 1
- isign = +1
-#ifdef OUTER_OMP
-!$OMP PARALLEL DO PRIVATE (LAT, NTR, K, IFLD, WORK)
-#endif
- do lat=beglat,endlat
- ntr = 8
-!$OMP PARALLEL DO PRIVATE (K, WORK)
- do k=1,plev
- fftbuf_out(begtrm:nlon_fft_out,:,k,lat) = 0.0_r8
- call fft991 (fftbuf_out(1,1,k,lat), work, trig(1,lat), ifax(1,lat), inc, &
- nlon_fft_out, plon, ntr, isign)
- enddo
- ntr = 1
-!$OMP PARALLEL DO PRIVATE (IFLD, WORK)
- do ifld=1,4
- fftbuf_out(begtrm:nlon_fft_out,ifld,plevp,lat) = 0.0_r8
- call fft991 (fftbuf_out(1,ifld,plevp,lat), work, trig(1,lat), ifax(1,lat), inc, &
- nlon_fft_out, plon, ntr, isign)
- enddo
- enddo
-!
- return
-end subroutine spegrd_ift
-
-subroutine spegrd_aft (ztodt ,lat ,nlon ,nlon_fft, &
- cwava ,qfcst , &
- etamid ,ps ,u3 ,v3 ,t3 , &
- qminus ,vort ,div ,hw2al ,hw2bl , &
- hw3al ,hw3bl ,hwxal ,hwxbl ,q3m1 , &
- dps ,dpsl ,dpsm ,t3m2 ,engy2alat, &
- engy2blat,difftalat, difftblat,phis,fftbuf )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Completion of transformation of variables from spherical harmonic
-! coefficients to grid point values during second gaussian latitude scan
-! (scan2)
-!
-! Method:
-!
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, J. Hack, August 1992
-! Reviewed: B. Boville, April 1996
-! Modified: P. Worley, September 2002
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plat, plev, plevp
- use pspect
- use commap
- use cam_history, only: outfld
- use physconst, only: rga
- use constituents, only: pcnst
- use eul_control_mod
- use hycoef, only: nprlev
-!-----------------------------------------------------------------------
- implicit none
-!-----------------------------------------------------------------------
-!
-! Arguments
-!
- integer, intent(in) :: lat ! latitude index
- integer, intent(in) :: nlon ! number of longitudes
- integer, intent(in) :: nlon_fft ! first dimension of FFT work arrays
-
- real(r8), intent(in) :: ztodt ! twice the timestep unles nstep=0
- real(r8), intent(in) :: cwava ! normalization factor (1/g*plon)
- real(r8), intent(in) :: qfcst(plon,plev,pcnst)
- real(r8), intent(in) :: qminus(plon,plev,pcnst)
- real(r8), intent(in) :: etamid(plev) ! vertical coords at midpoints
-
- real(r8), intent(inout) :: ps(plon)
- real(r8), intent(inout) :: u3(plon,plev)
- real(r8), intent(inout) :: v3(plon,plev)
- real(r8), intent(inout) :: t3(plon,plev)
- real(r8), intent(inout) :: vort(plon,plev)
- real(r8), intent(inout) :: div(plon,plev)
- real(r8), intent(inout) :: q3m1(plon,plev,pcnst)
-
- real(r8), intent(out) :: hw2al(pcnst) ! -
- real(r8), intent(out) :: hw2bl(pcnst) ! | lat contributions to components
- real(r8), intent(out) :: hw3al(pcnst) ! | of slt global mass integrals
- real(r8), intent(out) :: hw3bl(pcnst) ! -
- real(r8), intent(out) :: hwxal(pcnst,4)
- real(r8), intent(out) :: hwxbl(pcnst,4)
-
- real(r8), intent(out) :: dps(plon)
- real(r8), intent(out) :: dpsl(plon)
- real(r8), intent(out) :: dpsm(plon)
- real(r8), intent(in) :: t3m2(plon,plev) ! temperature
- real(r8), intent(out) :: engy2alat
- real(r8), intent(out) :: engy2blat
- real(r8), intent(out) :: difftalat
- real(r8), intent(out) :: difftblat
- real(r8), intent(in) :: phis(plon)
- real(r8), intent(in) :: fftbuf(nlon_fft,8,plevp) ! buffer used for in-place FFTs
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) :: duh(plon,plev) !
- real(r8) :: dvh(plon,plev) !
- real(r8) :: dth(plon,plev) !
- real(r8) :: ps_tmp(plon)
-
- real(r8) pmid(plon,plev) ! pressure at model levels
- real(r8) pint(plon,plevp) ! pressure at model interfaces
- real(r8) pdel(plon,plev) ! pdel(k) = pint(k+1) - pint(k)
- real(r8) pdelb(plon,plev) ! pressure diff bet intfcs (press defined using the "B" part
- ! of the hybrid grid only)
- real(r8) hcwavaw ! 0.5*cwava*w(lat)
- real(r8) sum
-!
- real(r8) rcoslat ! 1./cosine(latitude)
- real(r8) dotproda ! dot product
- real(r8) dotprodb ! dot product
- integer i,k,m ! longitude, level, constituent indices
- integer klev ! top level where hybrid coordinates apply
- integer, parameter :: vortdex = 1 ! indices into fftbuf
- integer, parameter :: divdex = 2
- integer, parameter :: duhdex = 3
- integer, parameter :: dvhdex = 4
- integer, parameter :: dthdex = 5
- integer, parameter :: u3dex = 6
- integer, parameter :: v3dex = 7
- integer, parameter :: t3dex = 8
- integer, parameter :: dpsdex = 1
- integer, parameter :: psdex = 2
- integer, parameter :: dpsldex = 3
- integer, parameter :: dpsmdex = 4
-!
-!-----------------------------------------------------------------------
-!
-! Copy 3D fields out of FFT buffer, removing cosine(latitude) from momentum variables
-!
- rcoslat = 1._r8/cos(clat(lat))
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- vort(i,k) = fftbuf(i,vortdex,k)
- div(i,k) = fftbuf(i,divdex,k)
- duh(i,k) = fftbuf(i,duhdex,k)*rcoslat
- dvh(i,k) = fftbuf(i,dvhdex,k)*rcoslat
- dth(i,k) = fftbuf(i,dthdex,k)
- u3(i,k) = fftbuf(i,u3dex,k)*rcoslat
- v3(i,k) = fftbuf(i,v3dex,k)*rcoslat
- t3(i,k) = fftbuf(i,t3dex,k)
- end do
- end do
-!
-! Copy 2D fields out of FFT buffer, converting
-! log(ps) to ps.
-!
-!$OMP PARALLEL DO PRIVATE (I)
- do i=1,nlon
- dps(i) = fftbuf(i,dpsdex,plevp)
- dpsl(i) = fftbuf(i,dpsldex,plevp)
- dpsm(i) = fftbuf(i,dpsmdex,plevp)
- ps(i) = exp(fftbuf(i,psdex,plevp))
- end do
-
-!
-! Diagnose pressure arrays needed by DIFCOR
-!
- call plevs0 (nlon, plon, plev, ps, pint, pmid, pdel)
- call pdelb0 (ps, pdelb, nlon)
-!
-! Accumulate mass integrals
-!
- sum = 0._r8
- do i=1,nlon
- sum = sum + ps(i)
- end do
- tmass(lat) = w(lat)*rga*sum/nlon
-!
-! Finish horizontal diffusion: add pressure surface correction term to t and
-! q diffusions; add kinetic energy dissipation to internal energy (temperature)
-!
- klev = max(kmnhdn,nprlev)
- call difcor (klev, ztodt, dps, u3, v3, &
- q3m1(1,1,1), pdel, pint, t3, dth, &
- duh, dvh, nlon)
-!
-! Calculate SLT moisture, constituent, energy, and temperature integrals
-!
- hcwavaw = 0.5_r8*cwava*w(lat)
- engy2alat = 0._r8
- engy2blat = 0._r8
- difftalat = 0._r8
- difftblat = 0._r8
-!$OMP PARALLEL DO PRIVATE (M, K, DOTPRODA, DOTPRODB, I)
- do m=1,pcnst
- hw2al(m) = 0._r8
- hw2bl(m) = 0._r8
- hw3al(m) = 0._r8
- hw3bl(m) = 0._r8
- hwxal(m,1) = 0._r8
- hwxal(m,2) = 0._r8
- hwxal(m,3) = 0._r8
- hwxal(m,4) = 0._r8
- hwxbl(m,1) = 0._r8
- hwxbl(m,2) = 0._r8
- hwxbl(m,3) = 0._r8
- hwxbl(m,4) = 0._r8
- do k=1,plev
- dotproda = 0._r8
- dotprodb = 0._r8
- do i=1,nlon
- dotproda = dotproda + qfcst(i,k,m)*pdela(i,k)
- dotprodb = dotprodb + qfcst(i,k,m)*pdelb(i,k)
- end do
- hw2al(m) = hw2al(m) + hcwavaw*dotproda
- hw2bl(m) = hw2bl(m) + hcwavaw*dotprodb
- end do
- end do
-
- do i=1,nlon
- ps_tmp(i) = 0._r8
- end do
-
-! using do loop and select to enable functional parallelism with OpenMP
-!$OMP PARALLEL DO PRIVATE (I)
- do i=1,6
- select case (i)
- case (1)
- call engy_te (cwava ,w(lat) ,t3 ,u3 ,v3 ,phis ,pdela, ps_tmp, engy2alat ,nlon)
- case (2)
- call engy_te (cwava ,w(lat) ,t3 ,u3 ,v3 ,phis ,pdelb, ps , engy2blat ,nlon)
- case (3)
- call engy_tdif(cwava ,w(lat) ,t3 ,t3m2 ,pdela, difftalat ,nlon)
- case (4)
- call engy_tdif(cwava ,w(lat) ,t3 ,t3m2 ,pdelb, difftblat ,nlon)
- case (5)
- call qmassd (cwava, etamid, w(lat), qminus, qfcst, &
- pdela, hw3al, nlon)
- case (6)
- call qmassd (cwava, etamid, w(lat), qminus, qfcst, &
- pdelb, hw3bl, nlon)
- end select
- end do
-
- if (pcnst.gt.1) then
- call xqmass (cwava, etamid, w(lat), qminus, qfcst, &
- qminus, qfcst, pdela, pdelb, hwxal, &
- hwxbl, nlon)
- end if
-
- call outfld ('DTH ',dth ,plon ,lat )
-
- return
-end subroutine spegrd_aft
-
-
diff --git a/src/dynamics/eul/spetru.F90 b/src/dynamics/eul/spetru.F90
deleted file mode 100644
index abd8c40619..0000000000
--- a/src/dynamics/eul/spetru.F90
+++ /dev/null
@@ -1,1287 +0,0 @@
-
-module spetru
-
-!-----------------------------------------------------------------------
-!
-! Purpose: Spectrally truncate initial data fields.
-!
-! Method: Truncate one or a few fields at a time, to minimize the
-! memory requirements
-!
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, J. Hack, August 1992
-! Modified to implement processing of subsets of fields: P. Worley, May 2003
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev, plat
- use pspect, only: psp, pspt, ptrn, pmmax
- use comspe, only: alp, nlen, nstart, dalp
- use commap, only: w, xm
- use physconst, only: rearth, ra
- use eul_control_mod, only: trig, ifax, pcray
- implicit none
-!
-! By default make data and interfaces to this module private
-!
- private
-
-!
-! Public interfaces
-!
- public spetru_phis ! Spectrally truncate PHIS
- public spetru_ps ! Spectrally truncate PS
- public spetru_3d_scalar ! Spectrally truncate 3D scalar fields
- public spetru_uv ! Spectrally truncate winds (U and V)
-!
-! Private module data
-!
- integer, parameter :: plondfft = plon + 2 ! Size of longitude needed for FFT's
-
-!
-!=======================================================================
-contains
-
-!************************************************************************
-subroutine spetru_phis (phis, phis_hires, phisl, phism, phi_out)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-!
-! Method:
-! Spectrally truncate PHIS input field.
-!
-! Author:
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, J. Hack, August 1992
-! Modified: P. Worley, May 2003
-! Modified: J. Olson, Apr 2004
-!
-!-----------------------------------------------------------------------
-
- use pmgrid, only: plon, plat
-
-!
-! Input/Output arguments
-!
- real(r8), intent(inout) :: phis(plon,plat) ! Fourier -> spec. coeffs. for sfc geo.
- logical, intent(in) :: phis_hires ! true => PHIS came from hi res topo file
- real(r8), intent(out), optional :: phisl(plon,plat) ! Spectrally trunc d(phis)/d(longitude)
- real(r8), intent(out), optional :: phism(plon,plat) ! Spectrally trunc d(phis)/d(latitude)
- real(r8), intent(out), optional :: phi_out(2,psp/2) ! used in spectral truncation of phis
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8), pointer :: phis_tmp(:,:) ! Temporary to compute Phis of size needed for FFT
- real(r8), pointer :: phisl_tmp(:,:) ! Temporary to compute phisl of size needed for FFT
- real(r8), pointer :: phism_tmp(:,:) ! Temporary to compute phism of size needed for FFT
- real(r8) tmp1 ! vector temporary
- real(r8) tmp2 ! vector temporary
- real(r8) phialpr,phialpi ! phi*alp (real and imaginary)
- real(r8) phdalpr,phdalpi ! phi*dalp (real and imaginary)
- real(r8) zwalp ! zw*alp
- real(r8) zw ! w**2
- real(r8) filtlim ! filter function
- real(r8) ft ! filter multiplier for spectral coefficients
- real(r8) phi(2,psp/2) ! used in spectral truncation of phis
-#if ( ! defined USEFFTLIB )
- real(r8) work((plon+1)*plev) ! Workspace for fft
-#else
- real(r8) work((plon+1)*pcray) ! Workspace for fft
-#endif
-
- integer i ! longitude index
- integer irow ! latitude pair index
- integer latm,latp ! symmetric latitude indices
- integer lat
- integer m ! longitudinal wavenumber index
- integer n ! latitudinal wavenumber index
- integer nspec
- integer mr ! spectral indices
-!
-!-----------------------------------------------------------------------
-!
-! Zero spectral array
-!
- phi(:,:) = 0._r8
-!
-! Transform grid -> fourier
-!
- allocate(phis_tmp(plondfft,plat))
- phis_tmp(:plon,:) = phis(:plon,:)
- do lat=1,plat
- irow = lat
- if (lat.gt.plat/2) irow = plat - lat + 1
- call fft991(phis_tmp(1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,1,-1)
- end do ! lat=1,plat
-!
-! Loop over latitude pairs
-!
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
- zw = w(irow)*2._r8
- do i=1,2*pmmax
-!
-! Compute symmetric and antisymmetric components
-!
- tmp1 = 0.5_r8*(phis_tmp(i,latm) - phis_tmp(i,latp))
- tmp2 = 0.5_r8*(phis_tmp(i,latm) + phis_tmp(i,latp))
- phis_tmp(i,latm) = tmp1
- phis_tmp(i,latp) = tmp2
- end do
-!
-! Compute phi*mn
-!
- do m=1,pmmax
- mr = nstart(m)
- do n=1,nlen(m),2
- zwalp = zw*alp(mr+n,irow)
- phi(1,mr+n) = phi(1,mr+n) + zwalp*phis_tmp(2*m-1,latp)
- phi(2,mr+n) = phi(2,mr+n) + zwalp*phis_tmp(2*m ,latp)
- end do
-
- do n=2,nlen(m),2
- zwalp = zw*alp(mr+n,irow)
- phi(1,mr+n) = phi(1,mr+n) + zwalp*phis_tmp(2*m-1,latm)
- phi(2,mr+n) = phi(2,mr+n) + zwalp*phis_tmp(2*m ,latm)
- end do
- end do
- enddo ! irow=1,plat/2
-!
- if (phis_hires) then
-!
-! Apply spectral filter to phis
-! filter is a function of n
-! if n < filter limit then
-! spectral_coeff = spectral_coeff * (1. - (real(n,r8)/filtlim)**2)
-! else
-! spectral_coeff = 0.
-! endif
-! where filter limit = 1.4*PTRN
-!
- filtlim = real(int(1.4_r8*real(ptrn,r8)),r8)
- do m=1,pmmax
- mr = nstart(m)
- do n=1,nlen(m)
- nspec=m-1+n
- ft = 1._r8 - (real(nspec,r8)/filtlim)**2
- if (real(nspec,r8) .ge. filtlim) ft = 0._r8
- phi(1,mr+n) = phi(1,mr+n)*ft
- phi(2,mr+n) = phi(2,mr+n)*ft
- end do
- end do
- call hordif1(rearth,phi)
- end if
-!
-! Compute grid point values of phi*.
-!
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
-!
-! Zero fourier fields
-!
- phis_tmp(:,latm) = 0._r8
- phis_tmp(:,latp) = 0._r8
-!
-! Compute(phi*)m
-!
- do m=1,pmmax
- mr = nstart(m)
- do n=1,nlen(m),2
- phialpr = phi(1,mr+n)*alp(mr+n,irow)
- phialpi = phi(2,mr+n)*alp(mr+n,irow)
- phis_tmp(2*m-1,latm) = phis_tmp(2*m-1,latm) + phialpr
- phis_tmp(2*m ,latm) = phis_tmp(2*m ,latm) + phialpi
- end do
- end do
-
- do m=1,pmmax
- mr = nstart(m)
- do n=2,nlen(m),2
- phialpr = phi(1,mr+n)*alp(mr+n,irow)
- phialpi = phi(2,mr+n)*alp(mr+n,irow)
- phis_tmp(2*m-1,latp) = phis_tmp(2*m-1,latp) + phialpr
- phis_tmp(2*m ,latp) = phis_tmp(2*m ,latp) + phialpi
- end do
- end do
-!
-! Recompute real fields from symmetric and antisymmetric parts
-!
- do i=1,plon+2
- tmp1 = phis_tmp(i,latm) + phis_tmp(i,latp)
- tmp2 = phis_tmp(i,latm) - phis_tmp(i,latp)
- phis_tmp(i,latm) = tmp1
- phis_tmp(i,latp) = tmp2
- end do
-
- enddo ! irow=1,plat/2
-
- if(present(phisl)) then
- allocate(phisl_tmp(plondfft,plat))
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
-!
-! Zero fourier fields
-!
- phisl_tmp(:,latm) = 0._r8
- phisl_tmp(:,latp) = 0._r8
-!
-! Compute(phi*)m
-!
- do m=1,pmmax
- mr = nstart(m)
- do n=1,nlen(m),2
- phialpr = phi(1,mr+n)*alp(mr+n,irow)
- phialpi = phi(2,mr+n)*alp(mr+n,irow)
- phisl_tmp(2*m-1,latm) = phisl_tmp(2*m-1,latm) - phialpi*ra
- phisl_tmp(2*m ,latm) = phisl_tmp(2*m ,latm) + phialpr*ra
- end do
- end do
-
- do m=1,pmmax
- mr = nstart(m)
- do n=2,nlen(m),2
- phialpr = phi(1,mr+n)*alp(mr+n,irow)
- phialpi = phi(2,mr+n)*alp(mr+n,irow)
- phisl_tmp(2*m-1,latp) = phisl_tmp(2*m-1,latp) - phialpi*ra
- phisl_tmp(2*m ,latp) = phisl_tmp(2*m ,latp) + phialpr*ra
- end do
- end do
-!
-! d(Phi)/d(lamda)
-!
- do m=1,pmmax
- phisl_tmp(2*m-1,latm) = xm(m)*phisl_tmp(2*m-1,latm)
- phisl_tmp(2*m ,latm) = xm(m)*phisl_tmp(2*m ,latm)
- phisl_tmp(2*m-1,latp) = xm(m)*phisl_tmp(2*m-1,latp)
- phisl_tmp(2*m ,latp) = xm(m)*phisl_tmp(2*m ,latp)
- end do
-!
-! Recompute real fields from symmetric and antisymmetric parts
-!
- do i=1,plon+2
- tmp1 = phisl_tmp(i,latm) + phisl_tmp(i,latp)
- tmp2 = phisl_tmp(i,latm) - phisl_tmp(i,latp)
- phisl_tmp(i,latm) = tmp1
- phisl_tmp(i,latp) = tmp2
- end do
- enddo ! irow=1,plat/2
- end if
-
- if(present(phism)) then
- allocate(phism_tmp(plondfft,plat))
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
-!
-! Zero fourier fields
-!
- phism_tmp(:,latm) = 0._r8
- phism_tmp(:,latp) = 0._r8
-!
-! Compute(phi*)m
-!
- do m=1,pmmax
- mr = nstart(m)
- do n=1,nlen(m),2
- phdalpr = phi(1,mr+n)*dalp(mr+n,irow)
- phdalpi = phi(2,mr+n)*dalp(mr+n,irow)
- phism_tmp(2*m-1,latp) = phism_tmp(2*m-1,latp) + phdalpr*ra
- phism_tmp(2*m ,latp) = phism_tmp(2*m ,latp) + phdalpi*ra
- end do
- end do
-
- do m=1,pmmax
- mr = nstart(m)
- do n=2,nlen(m),2
- phdalpr = phi(1,mr+n)*dalp(mr+n,irow)
- phdalpi = phi(2,mr+n)*dalp(mr+n,irow)
- phism_tmp(2*m-1,latm) = phism_tmp(2*m-1,latm) + phdalpr*ra
- phism_tmp(2*m ,latm) = phism_tmp(2*m ,latm) + phdalpi*ra
- end do
- end do
-!
-! Recompute real fields from symmetric and antisymmetric parts
-!
- do i=1,plon+2
- tmp1 = phism_tmp(i,latm) + phism_tmp(i,latp)
- tmp2 = phism_tmp(i,latm) - phism_tmp(i,latp)
- phism_tmp(i,latm) = tmp1
- phism_tmp(i,latp) = tmp2
- end do
- enddo ! irow=1,plat/2
- end if
-!
- do lat=1,plat
-!
-! Transform Fourier -> grid, obtaining spectrally truncated
-! grid point values.
-!
- irow = lat
- if (lat.gt.plat/2) irow = plat - lat + 1
-
- call fft991(phis_tmp(1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,1,+1)
- phis(:plon,lat) = phis_tmp(:plon,lat)
- if(present(phisl)) then
- call fft991 (phisl_tmp(1,lat),work ,trig(1,irow),ifax(1,irow),1 , &
- plondfft ,plon,1 ,+1 )
- phisl(:plon,lat) = phisl_tmp(:plon,lat)
- end if
- if(present(phism)) then
- call fft991 (phism_tmp(1,lat),work ,trig(1,irow),ifax(1,irow),1 , &
- plondfft ,plon,1 ,+1 )
- phism(:plon,lat) = phism_tmp(:plon,lat)
- end if
- enddo
- deallocate( phis_tmp )
- if ( present(phisl) ) deallocate( phisl_tmp )
- if ( present(phism) ) deallocate( phism_tmp )
-
- if(present(phi_out)) then
- phi_out(:,:) = phi(:,:)
- end if
-
- return
-end subroutine spetru_phis
-
-!************************************************************************
-subroutine spetru_ps(ps ,dpsl ,dpsm)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-!
-! Method:
-! Spectrally truncate PS input field.
-!
-! Author:
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, J. Hack, August 1992
-! Modified: P. Worley, May 2003
-! Modified: J. Olson, Apr 2004
-!
-!-----------------------------------------------------------------------
-
- use pmgrid, only: plon, plat
-
-!
-! Input/Output arguments
-!
- real(r8), intent(inout) :: ps(plon,plat) ! Fourier -> spec. coeffs. for ln(ps)
-!
-! Output arguments
-!
- real(r8), intent(out) :: dpsl(plon,plat) ! Spectrally trunc d(ln(ps))/d(longitude)
- real(r8), intent(out) :: dpsm(plon,plat) ! Spectrally trunc d(ln(ps))/d(latitude)
-
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8), pointer :: log_ps(:,:) ! log(ps)
- real(r8), pointer :: dpsm_tmp(:,:) ! Temporary to compute dpsm of size needed for FFT
- real(r8), pointer :: dpsl_tmp(:,:) ! Temporary to compute dpsl of size needed for FFT
- real(r8) alps_tmp(psp) ! used in spectral truncation of phis
- real(r8) tmp1 ! vector temporary
- real(r8) tmp2 ! vector temporary
- real(r8) zwalp ! zw*alp
- real(r8) psdalpr,psdalpi ! alps (real and imaginary)*dalp
- real(r8) psalpr,psalpi ! alps (real and imaginary)*alp
- real(r8) zw ! w**2
-#if ( ! defined USEFFTLIB )
- real(r8) work((plon+1)*plev) ! Workspace for fft
-#else
- real(r8) work((plon+1)*pcray) ! Workspace for fft
-#endif
-
- integer ir,ii ! indices complex coeffs. of spec. arrs.
- integer i,k ! longitude, level indices
- integer irow ! latitude pair index
- integer latm,latp ! symmetric latitude indices
- integer lat
- integer m ! longitudinal wavenumber index
- integer n ! latitudinal wavenumber index
- integer nspec
- integer mr,mc ! spectral indices
-!
-!-----------------------------------------------------------------------
-!
-! Zero spectral array
-!
- alps_tmp(:) = 0._r8
-!
-! Compute the 2D quantities which are transformed to spectral space:
-! ps= ln(ps).
-!
- allocate( log_ps(plondfft,plat) )
- do lat=1,plat
- irow = lat
- if (lat.gt.plat/2) irow = plat - lat + 1
- do i=1,plon
- log_ps(i,lat) = log(ps(i,lat))
- end do
-!
-! Transform grid -> fourier
-!
- call fft991(log_ps(1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,1,-1)
-
- end do ! lat=1,plat
- allocate( dpsl_tmp(plondfft,plat) )
- allocate( dpsm_tmp(plondfft,plat) )
-!
-! Loop over latitude pairs
-!
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
- zw = w(irow)*2._r8
- do i=1,2*pmmax
-!
-! Compute symmetric and antisymmetric components
-!
- tmp1 = 0.5_r8*(log_ps(i,latm) - log_ps(i,latp))
- tmp2 = 0.5_r8*(log_ps(i,latm) + log_ps(i,latp))
- log_ps(i,latm) = tmp1
- log_ps(i,latp) = tmp2
-
- end do
-!
-! Compute ln(p*)mn
-!
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=1,nlen(m),2
- zwalp = zw*alp(mr+n,irow)
- ir = mc + 2*n - 1
- ii = ir + 1
- alps_tmp(ir) = alps_tmp(ir) + zwalp*log_ps(2*m-1,latp)
- alps_tmp(ii) = alps_tmp(ii) + zwalp*log_ps(2*m ,latp)
- end do
-
- do n=2,nlen(m),2
- zwalp = zw*alp(mr+n,irow)
- ir = mc + 2*n - 1
- ii = ir + 1
- alps_tmp(ir) = alps_tmp(ir) + zwalp*log_ps(2*m-1,latm)
- alps_tmp(ii) = alps_tmp(ii) + zwalp*log_ps(2*m ,latm)
- end do
- end do
- enddo ! irow=1,plat/2
-!
-! Compute grid point values of:ln(p*) and grad(ln(p*)).
-!
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
-!
-! Zero fourier fields
-!
- log_ps(:,latm) = 0._r8
- log_ps(:,latp) = 0._r8
-
- dpsl_tmp(:,latm) = 0._r8
- dpsl_tmp(:,latp) = 0._r8
-
- dpsm_tmp(:,latm) = 0._r8
- dpsm_tmp(:,latp) = 0._r8
-
-!
-! Compute(ln(p*),grad(ln(p*)))m
-!
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=1,nlen(m),2
- ir = mc + 2*n - 1
- ii = ir + 1
- psalpr = alps_tmp(ir)*alp(mr+n,irow)
- psalpi = alps_tmp(ii)*alp(mr+n,irow)
-!
- log_ps(2*m-1,latm) = log_ps(2*m-1,latm) + psalpr
- log_ps(2*m ,latm) = log_ps(2*m ,latm) + psalpi
- dpsl_tmp(2*m-1,latm) = dpsl_tmp(2*m-1,latm) - psalpi*ra
- dpsl_tmp(2*m ,latm) = dpsl_tmp(2*m ,latm) + psalpr*ra
-!
- psdalpr = alps_tmp(ir)*dalp(mr+n,irow)
- psdalpi = alps_tmp(ii)*dalp(mr+n,irow)
-!
- dpsm_tmp(2*m-1,latp) = dpsm_tmp(2*m-1,latp) + psdalpr*ra
- dpsm_tmp(2*m ,latp) = dpsm_tmp(2*m ,latp) + psdalpi*ra
- end do
- end do
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=2,nlen(m),2
- ir = mc + 2*n - 1
- ii = ir + 1
- psalpr = alps_tmp(ir)*alp(mr+n,irow)
- psalpi = alps_tmp(ii)*alp(mr+n,irow)
-!
- log_ps(2*m-1,latp) = log_ps(2*m-1,latp) + psalpr
- log_ps(2*m ,latp) = log_ps(2*m ,latp) + psalpi
- dpsl_tmp(2*m-1,latp) = dpsl_tmp(2*m-1,latp) - psalpi*ra
- dpsl_tmp(2*m ,latp) = dpsl_tmp(2*m ,latp) + psalpr*ra
-!
- psdalpr = alps_tmp(ir)*dalp(mr+n,irow)
- psdalpi = alps_tmp(ii)*dalp(mr+n,irow)
-!
- dpsm_tmp(2*m-1,latm) = dpsm_tmp(2*m-1,latm) + psdalpr*ra
- dpsm_tmp(2*m ,latm) = dpsm_tmp(2*m ,latm) + psdalpi*ra
- end do
- end do
-
- do m=1,pmmax
- dpsl_tmp(2*m-1,latm) = xm(m)*dpsl_tmp(2*m-1,latm)
- dpsl_tmp(2*m ,latm) = xm(m)*dpsl_tmp(2*m ,latm)
- dpsl_tmp(2*m-1,latp) = xm(m)*dpsl_tmp(2*m-1,latp)
- dpsl_tmp(2*m ,latp) = xm(m)*dpsl_tmp(2*m ,latp)
- end do
-!
-! Recompute real fields from symmetric and antisymmetric parts
-!
- do i=1,plon+2
-!
- tmp1 = log_ps(i,latm) + log_ps(i,latp)
- tmp2 = log_ps(i,latm) - log_ps(i,latp)
- log_ps(i,latm) = tmp1
- log_ps(i,latp) = tmp2
-!
- tmp1 = dpsl_tmp(i,latm) + dpsl_tmp(i,latp)
- tmp2 = dpsl_tmp(i,latm) - dpsl_tmp(i,latp)
- dpsl_tmp(i,latm) = tmp1
- dpsl_tmp(i,latp) = tmp2
-!
- tmp1 = dpsm_tmp(i,latm) + dpsm_tmp(i,latp)
- tmp2 = dpsm_tmp(i,latm) - dpsm_tmp(i,latp)
- dpsm_tmp(i,latm) = tmp1
- dpsm_tmp(i,latp) = tmp2
- end do
-!
- enddo ! irow=1,plat/2
-!
- do lat=1,plat
-!
-! Transform Fourier -> grid, obtaining spectrally truncated
-! grid point values.
-!
- irow = lat
- if (lat.gt.plat/2) irow = plat - lat + 1
-
- call fft991(log_ps(1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,1,+1)
- call fft991(dpsl_tmp(1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,1,+1)
- call fft991(dpsm_tmp(1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,1,+1)
-!
-! Convert from ln(ps) to ps, copy temporaries to input arrays
-!
- do i=1,plon
- ps(i,lat) = exp(log_ps(i,lat))
- dpsl(i,lat) = dpsl_tmp(i,lat)
- dpsm(i,lat) = dpsm_tmp(i,lat)
- end do
-!
- enddo
- deallocate( log_ps )
- deallocate( dpsm_tmp )
- deallocate( dpsl_tmp )
-
- return
-end subroutine spetru_ps
-
-!************************************************************************
-
-subroutine spetru_3d_scalar(x3, dl, dm)
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-!
-! Method:
-! Spectrally truncate 3-D scalar field.
-!
-! Author:
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, J. Hack, August 1992
-! Modified: P. Worley, May 2003
-! Modified: J. Olson, Apr 2004
-!
-!-----------------------------------------------------------------------
-
- use pmgrid, only: plon, plat
-
-!
-! Input/Output arguments
-!
- real(r8), intent(inout) :: x3(plon,plev,plat) ! Fourier -> spec. coeffs. for X
- real(r8), intent(out), optional :: dl(plon,plev,plat) ! Spectrally trunc d(X)/d(longitude)
- real(r8), intent(out), optional :: dm(plon,plev,plat) ! Spectrally trunc d(X)/d(latitude)
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8), pointer :: x3_tmp(:,:,:) ! Temporary to compute x3 of size needed for FFT
- real(r8), pointer :: dl_tmp(:,:,:) ! Temporary to compute dl of size needed for FFT
- real(r8), pointer :: dm_tmp(:,:,:) ! Temporary to compute dm of size needed for FFT
- real(r8) t_tmp(psp) ! used in spectral truncation of t
- real(r8) tmp1 ! vector temporary
- real(r8) tmp2 ! vector temporary
- real(r8) tmpr ! vector temporary (real)
- real(r8) tmpi ! vector temporary (imaginary)
- real(r8) zwalp ! zw*alp
- real(r8) zw ! w**2
-#if ( ! defined USEFFTLIB )
- real(r8) work((plon+1)*plev) ! Workspace for fft
-#else
- real(r8) work((plon+1)*pcray) ! Workspace for fft
-#endif
-
- integer ir,ii ! indices complex coeffs. of spec. arrs.
- integer i,k ! longitude, level indices
- integer irow ! latitude pair index
- integer latm,latp ! symmetric latitude indices
- integer lat
- integer m ! longitudinal wavenumber index
- integer n ! latitudinal wavenumber index
- integer nspec
- integer mr,mc ! spectral indices
-!
-!-----------------------------------------------------------------------
-!
-! Transform grid -> fourier
-!
- allocate( x3_tmp(plondfft,plev,plat) )
- if(present(dm)) allocate( dm_tmp(plondfft,plev,plat) )
- if(present(dl)) allocate( dl_tmp(plondfft,plev,plat) )
- do lat=1,plat
- irow = lat
- if (lat.gt.plat/2) irow = plat - lat + 1
- x3_tmp(:plon,:,lat) = x3(:plon,:,lat)
- call fft991(x3_tmp(1,1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,plev,-1)
- end do ! lat=1,plat
-!
-! Loop over vertical levels
-!
- do k=1,plev
-!
-! Zero spectral array
-!
- t_tmp(:) = 0._r8
-!
-! Loop over latitude pairs
-!
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
- zw = w(irow)*2._r8
-!
-! Multi-level field: T
-!
- do i=1,2*pmmax
- tmp1 = 0.5_r8*(x3_tmp(i,k,latm) - x3_tmp(i,k,latp))
- tmp2 = 0.5_r8*(x3_tmp(i,k,latm) + x3_tmp(i,k,latp))
- x3_tmp(i,k,latm) = tmp1
- x3_tmp(i,k,latp) = tmp2
- end do
-!
-! Compute tmn
-!
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=1,nlen(m),2
- zwalp = zw*alp (mr+n,irow)
- ir = mc + 2*n - 1
- ii = ir + 1
- t_tmp(ir) = t_tmp(ir) + zwalp*x3_tmp(2*m-1,k,latp)
- t_tmp(ii) = t_tmp(ii) + zwalp*x3_tmp(2*m ,k,latp)
- end do
- end do
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=2,nlen(m),2
- zwalp = zw*alp (mr+n,irow)
- ir = mc + 2*n - 1
- ii = ir + 1
- t_tmp(ir) = t_tmp(ir) + zwalp*x3_tmp(2*m-1,k,latm)
- t_tmp(ii) = t_tmp(ii) + zwalp*x3_tmp(2*m ,k,latm)
- end do
- end do
- enddo ! irow=1,plat/2
-!
-! Compute grid point values of:t.
-!
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
-!
-! Zero fourier fields
-!
- x3_tmp(:,k,latm) = 0._r8
- x3_tmp(:,k,latp) = 0._r8
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=1,nlen(m),2
- ir = mc + 2*n - 1
- ii = ir + 1
- tmpr = t_tmp(ir)*alp(mr+n,irow)
- tmpi = t_tmp(ii)*alp(mr+n,irow)
- x3_tmp(2*m-1,k,latm) = x3_tmp(2*m-1,k,latm) + tmpr
- x3_tmp(2*m ,k,latm) = x3_tmp(2*m ,k,latm) + tmpi
- end do
- end do
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=2,nlen(m),2
- ir = mc + 2*n - 1
- ii = ir + 1
- tmpr = t_tmp(ir)*alp(mr+n,irow)
- tmpi = t_tmp(ii)*alp(mr+n,irow)
- x3_tmp(2*m-1,k,latp) = x3_tmp(2*m-1,k,latp) + tmpr
- x3_tmp(2*m ,k,latp) = x3_tmp(2*m ,k,latp) + tmpi
- end do
- end do
-!
-! Recompute real fields from symmetric and antisymmetric parts
-!
- do i=1,plon+2
- tmp1 = x3_tmp(i,k,latm) + x3_tmp(i,k,latp)
- tmp2 = x3_tmp(i,k,latm) - x3_tmp(i,k,latp)
- x3_tmp(i,k,latm) = tmp1
- x3_tmp(i,k,latp) = tmp2
- end do
- enddo ! irow=1,plat/2
-
- if(present(dl)) then
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
-!
-! Zero fourier fields
-!
- dl_tmp(:,k,latm) = 0._r8
- dl_tmp(:,k,latp) = 0._r8
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=1,nlen(m),2
- ir = mc + 2*n - 1
- ii = ir + 1
- tmpr = t_tmp(ir)*alp(mr+n,irow)
- tmpi = t_tmp(ii)*alp(mr+n,irow)
- dl_tmp(2*m-1,k,latm) = dl_tmp(2*m-1,k,latm) - tmpi*ra
- dl_tmp(2*m ,k,latm) = dl_tmp(2*m ,k,latm) + tmpr*ra
- end do
- end do
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=2,nlen(m),2
- ir = mc + 2*n - 1
- ii = ir + 1
- tmpr = t_tmp(ir)*alp(mr+n,irow)
- tmpi = t_tmp(ii)*alp(mr+n,irow)
- dl_tmp(2*m-1,k,latp) = dl_tmp(2*m-1,k,latp) - tmpi*ra
- dl_tmp(2*m ,k,latp) = dl_tmp(2*m ,k,latp) + tmpr*ra
- end do
- end do
-!
-! d(T)/d(lamda)
-!
- do m=1,pmmax
- dl_tmp(2*m-1,k,latm) = xm(m)*dl_tmp(2*m-1,k,latm)
- dl_tmp(2*m ,k,latm) = xm(m)*dl_tmp(2*m ,k,latm)
- dl_tmp(2*m-1,k,latp) = xm(m)*dl_tmp(2*m-1,k,latp)
- dl_tmp(2*m ,k,latp) = xm(m)*dl_tmp(2*m ,k,latp)
- end do
-!
-! Recompute real fields from symmetric and antisymmetric parts
-!
- do i=1,plon+2
- tmp1 = dl_tmp(i,k,latm) + dl_tmp(i,k,latp)
- tmp2 = dl_tmp(i,k,latm) - dl_tmp(i,k,latp)
- dl_tmp(i,k,latm) = tmp1
- dl_tmp(i,k,latp) = tmp2
- end do
- enddo ! irow=1,plat/2
- end if
-
- if(present(dm)) then
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
-!
-! Zero fourier fields
-!
- dm_tmp(:,k,latm) = 0._r8
- dm_tmp(:,k,latp) = 0._r8
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=1,nlen(m),2
- ir = mc + 2*n - 1
- ii = ir + 1
- tmpr = t_tmp(ir)*dalp(mr+n,irow)
- tmpi = t_tmp(ii)*dalp(mr+n,irow)
- dm_tmp(2*m-1,k,latp) = dm_tmp(2*m-1,k,latp) + tmpr*ra
- dm_tmp(2*m ,k,latp) = dm_tmp(2*m ,k,latp) + tmpi*ra
- end do
- end do
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=2,nlen(m),2
- ir = mc + 2*n - 1
- ii = ir + 1
- tmpr = t_tmp(ir)*dalp(mr+n,irow)
- tmpi = t_tmp(ii)*dalp(mr+n,irow)
- dm_tmp(2*m-1,k,latm) = dm_tmp(2*m-1,k,latm) + tmpr*ra
- dm_tmp(2*m ,k,latm) = dm_tmp(2*m ,k,latm) + tmpi*ra
- end do
- end do
-!
-! Recompute real fields from symmetric and antisymmetric parts
-!
- do i=1,plon+2
- tmp1 = dm_tmp(i,k,latm) + dm_tmp(i,k,latp)
- tmp2 = dm_tmp(i,k,latm) - dm_tmp(i,k,latp)
- dm_tmp(i,k,latm) = tmp1
- dm_tmp(i,k,latp) = tmp2
- end do
- enddo ! irow=1,plat/2
- end if
-
- enddo ! k=1,plev
-!
- do lat=1,plat
-!
-! Transform Fourier -> grid, obtaining spectrally truncated
-! grid point values.
-
- irow = lat
- if (lat.gt.plat/2) irow = plat - lat + 1
-
- call fft991(x3_tmp(1,1,lat) ,work ,trig(1,irow),ifax(1,irow),1 , &
- plondfft ,plon,plev ,+1)
- x3(:plon,:,lat) = x3_tmp(:plon,:,lat)
- if(present(dl)) then
- call fft991(dl_tmp(1,1,lat) ,work ,trig(1,irow),ifax(1,irow),1 , &
- plondfft ,plon,plev ,+1 )
- dl(:plon,:,lat) = dl_tmp(:plon,:,lat)
- end if
- if(present(dm)) then
- call fft991(dm_tmp(1,1,lat) ,work ,trig(1,irow),ifax(1,irow),1 , &
- plondfft ,plon,plev ,+1 )
- dm(:plon,:,lat) = dm_tmp(:plon,:,lat)
- end if
- end do
- deallocate( x3_tmp )
- if ( present(dm) ) deallocate( dm_tmp )
- if ( present(dl) ) deallocate( dl_tmp )
-
- return
-end subroutine spetru_3d_scalar
-
-!***********************************************************************
-
-subroutine spetru_uv(u3 ,v3 ,div ,vort )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-!
-! Method:
-! Spectrally truncate U, V input fields.
-!
-! Author:
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, J. Hack, August 1992
-! Modified: P. Worley, May 2003
-! Modified: J. Olson, Apr 2004
-!
-!-----------------------------------------------------------------------
-
- use pmgrid, only: plon, plat
- use commap, only: rsq, cs
- use physconst,only: ez
-
-!
-! Input/Output arguments
-!
- real(r8), intent(inout) :: u3(plon,plev,plat) ! Fourier -> spec. coeffs. for u-wind
- real(r8), intent(inout) :: v3(plon,plev,plat) ! Fourier -> spec. coeffs. for v-wind
-!
-! Output arguments
-!
- real(r8), intent(out), optional :: div (plon,plev,plat) ! Spectrally truncated divergence
- real(r8), intent(out), optional :: vort(plon,plev,plat) ! Spectrally truncated vorticity
-
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8), pointer :: u_cosphi(:,:,:) ! u3*cos(phi)
- real(r8), pointer :: v_cosphi(:,:,:) ! v3*cos(phi)
- real(r8), pointer :: div_tmp(:,:,:) ! Temporary to compute div of size needed for FFT
- real(r8), pointer :: vort_tmp(:,:,:) ! Temporary to compute vort of size needed for FFT
- real(r8) d_tmp(psp) ! used in spectral truncation of div
- real(r8) vz_tmp(psp) ! used in spectral truncation of vort
- real(r8) alpn(pspt) ! alp*rsq*xm*ra
- real(r8) dalpn(pspt) ! dalp*rsq*ra
- real(r8) tmp1 ! vector temporary
- real(r8) tmp2 ! vector temporary
- real(r8) tmpr ! vector temporary (real)
- real(r8) tmpi ! vector temporary (imaginary)
- real(r8) zcor ! correction for absolute vorticity
- real(r8) zwalp ! zw*alp
- real(r8) zwdalp ! zw*dalp
- real(r8) zrcsj ! ra/(cos**2 latitude)
- real(r8) zw ! w**2
-#if ( ! defined USEFFTLIB )
- real(r8) work((plon+1)*plev) ! Workspace for fft
-#else
- real(r8) work((plon+1)*pcray) ! Workspace for fft
-#endif
- real(r8) zsqcs
-
- integer ir,ii ! indices complex coeffs. of spec. arrs.
- integer i,k ! longitude, level indices
- integer irow ! latitude pair index
- integer latm,latp ! symmetric latitude indices
- integer lat
- integer m ! longitudinal wavenumber index
- integer n ! latitudinal wavenumber index
- integer nspec
- integer mr,mc ! spectral indices
-
-!
-!-----------------------------------------------------------------------
-!
-! Compute the quantities which are transformed to spectral space:
-! 1. u = u*sqrt(1-mu*mu), u * cos(phi)
-! 2. v = v*sqrt(1-mu*mu), v * cos(phi)
-!
- allocate( u_cosphi(plondfft,plev,plat) )
- allocate( v_cosphi(plondfft,plev,plat) )
- do lat=1,plat
- irow = lat
- if (lat.gt.plat/2) irow = plat - lat + 1
- zsqcs = sqrt(cs(irow))
- do k=1,plev
- do i=1,plon
- u_cosphi(i,k,lat) = u3(i,k,lat)*zsqcs
- v_cosphi(i,k,lat) = v3(i,k,lat)*zsqcs
- end do
- end do
-!
-! Transform grid -> fourier
-! 1st transform: U,V,T: note contiguity assumptions
-! 2nd transform: LN(PS). 3rd transform: surface geopotential
-!
- call fft991(u_cosphi(1,1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,plev,-1)
- call fft991(v_cosphi(1,1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,plev,-1)
-
- end do ! lat=1,plat
-!
-! Multi-level fields: U, V
-!
- if ( present(div) ) allocate( div_tmp(plondfft,plev,plat) )
- if ( present(vort) ) allocate( vort_tmp(plondfft,plev,plat) )
- do k=1,plev
-!
-! Zero spectral arrays
-!
- vz_tmp(:) = 0._r8
- d_tmp(:) = 0._r8
-!
-! Loop over latitude pairs
-!
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
- zrcsj = ra/cs(irow)
- zw = w(irow)*2._r8
- do i=1,2*pmmax
-
- tmp1 = 0.5_r8*(u_cosphi(i,k,latm) - u_cosphi(i,k,latp))
- tmp2 = 0.5_r8*(u_cosphi(i,k,latm) + u_cosphi(i,k,latp))
- u_cosphi(i,k,latm) = tmp1
- u_cosphi(i,k,latp) = tmp2
-
- tmp1 = 0.5_r8*(v_cosphi(i,k,latm) - v_cosphi(i,k,latp))
- tmp2 = 0.5_r8*(v_cosphi(i,k,latm) + v_cosphi(i,k,latp))
- v_cosphi(i,k,latm) = tmp1
- v_cosphi(i,k,latp) = tmp2
-
- end do
-!
-! Compute vzmn and dmn
-!
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=1,nlen(m),2
- zwdalp = zw*dalp(mr+n,irow)
- zwalp = zw*alp (mr+n,irow)
- ir = mc + 2*n - 1
- ii = ir + 1
- d_tmp(ir) = d_tmp(ir) - (zwdalp*v_cosphi(2*m-1,k,latm) + &
- xm(m)*zwalp*u_cosphi(2*m ,k,latp))*zrcsj
- d_tmp(ii) = d_tmp(ii) - (zwdalp*v_cosphi(2*m ,k,latm) - &
- xm(m)*zwalp*u_cosphi(2*m-1,k,latp))*zrcsj
- vz_tmp(ir) = vz_tmp(ir) + (zwdalp*u_cosphi(2*m-1,k,latm) - &
- xm(m)*zwalp*v_cosphi(2*m ,k,latp))*zrcsj
- vz_tmp(ii) = vz_tmp(ii) + (zwdalp*u_cosphi(2*m ,k,latm) + &
- xm(m)*zwalp*v_cosphi(2*m-1,k,latp))*zrcsj
- end do
- end do
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=2,nlen(m),2
- zwdalp = zw*dalp(mr+n,irow)
- zwalp = zw*alp (mr+n,irow)
- ir = mc + 2*n - 1
- ii = ir + 1
- d_tmp(ir) = d_tmp(ir) - (zwdalp*v_cosphi(2*m-1,k,latp) + &
- xm(m)*zwalp*u_cosphi(2*m ,k,latm))*zrcsj
- d_tmp(ii) = d_tmp(ii) - (zwdalp*v_cosphi(2*m ,k,latp) - &
- xm(m)*zwalp*u_cosphi(2*m-1,k,latm))*zrcsj
- vz_tmp(ir) = vz_tmp(ir) + (zwdalp*u_cosphi(2*m-1,k,latp) - &
- xm(m)*zwalp*v_cosphi(2*m ,k,latm))*zrcsj
- vz_tmp(ii) = vz_tmp(ii) + (zwdalp*u_cosphi(2*m ,k,latp) + &
- xm(m)*zwalp*v_cosphi(2*m-1,k,latm))*zrcsj
- end do
- end do
- enddo ! irow=1,plat/2
-!
-! Compute grid point values of:u,v,vz, and d.
-!
- do irow=1,plat/2
- latp = irow
- latm = plat - irow + 1
- zcor = ez*alp(2,irow)
-!
-! Compute(u,v,vz,d)m
-!
- do m=1,pmmax
- mr = nstart(m)
- do n=1,nlen(m)
-!
-! These statements will likely not be bfb since xm*ra is now a scalar
-!
- alpn (mr+n) = alp(mr+n,irow)*rsq(n+m-1)*xm(m)*ra
- dalpn(mr+n) = dalp(mr+n,irow)*rsq(n+m-1) *ra
- end do
- end do
-!
-! Zero fourier fields
-!
- u_cosphi(:,k,latm) = 0._r8
- u_cosphi(:,k,latp) = 0._r8
-
- v_cosphi(:,k,latm) = 0._r8
- v_cosphi(:,k,latp) = 0._r8
-
- if(present(vort)) then
- vort_tmp(:,k,latm) = 0._r8
- vort_tmp(:,k,latp) = 0._r8
- end if
-
- if(present(div)) then
- div_tmp(:,k,latm) = 0._r8
- div_tmp(:,k,latp) = 0._r8
- end if
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=1,nlen(m),2
- ir = mc + 2*n - 1
- ii = ir + 1
-!
- tmpr = d_tmp(ir)*alpn(mr+n)
- tmpi = d_tmp(ii)*alpn(mr+n)
- u_cosphi(2*m-1,k,latm) = u_cosphi(2*m-1,k,latm) + tmpi
- u_cosphi(2*m ,k,latm) = u_cosphi(2*m ,k,latm) - tmpr
-!
- tmpr = d_tmp(ir)*dalpn(mr+n)
- tmpi = d_tmp(ii)*dalpn(mr+n)
- v_cosphi(2*m-1,k,latp) = v_cosphi(2*m-1,k,latp) - tmpr
- v_cosphi(2*m ,k,latp) = v_cosphi(2*m ,k,latp) - tmpi
-!
- tmpr = vz_tmp(ir)*dalpn(mr+n)
- tmpi = vz_tmp(ii)*dalpn(mr+n)
- u_cosphi(2*m-1,k,latp) = u_cosphi(2*m-1,k,latp) + tmpr
- u_cosphi(2*m ,k,latp) = u_cosphi(2*m ,k,latp) + tmpi
-!
- tmpr = vz_tmp(ir)*alpn(mr+n)
- tmpi = vz_tmp(ii)*alpn(mr+n)
- v_cosphi(2*m-1,k,latm) = v_cosphi(2*m-1,k,latm) + tmpi
- v_cosphi(2*m ,k,latm) = v_cosphi(2*m ,k,latm) - tmpr
-!
- if(present(div)) then
- tmpr = d_tmp(ir)*alp(mr+n,irow)
- tmpi = d_tmp(ii)*alp(mr+n,irow)
- div_tmp(2*m-1,k,latm) = div_tmp(2*m-1,k,latm) + tmpr
- div_tmp(2*m ,k,latm) = div_tmp(2*m ,k,latm) + tmpi
- end if
-!
- if(present(vort)) then
- tmpr = vz_tmp(ir)*alp(mr+n,irow)
- tmpi = vz_tmp(ii)*alp(mr+n,irow)
- vort_tmp(2*m-1,k,latm) = vort_tmp(2*m-1,k,latm) + tmpr
- vort_tmp(2*m ,k,latm) = vort_tmp(2*m ,k,latm) + tmpi
- end if
- end do
- end do
-
- do m=1,pmmax
- mr = nstart(m)
- mc = 2*mr
- do n=2,nlen(m),2
- ir = mc + 2*n - 1
- ii = ir + 1
-!
- tmpr = d_tmp(ir)*alpn(mr+n)
- tmpi = d_tmp(ii)*alpn(mr+n)
- u_cosphi(2*m-1,k,latp) = u_cosphi(2*m-1,k,latp) + tmpi
- u_cosphi(2*m ,k,latp) = u_cosphi(2*m ,k,latp) - tmpr
-!
- tmpr = d_tmp(ir)*dalpn(mr+n)
- tmpi = d_tmp(ii)*dalpn(mr+n)
- v_cosphi(2*m-1,k,latm) = v_cosphi(2*m-1,k,latm) - tmpr
- v_cosphi(2*m ,k,latm) = v_cosphi(2*m ,k,latm) - tmpi
-!
- tmpr = vz_tmp(ir)*dalpn(mr+n)
- tmpi = vz_tmp(ii)*dalpn(mr+n)
- u_cosphi(2*m-1,k,latm) = u_cosphi(2*m-1,k,latm) + tmpr
- u_cosphi(2*m ,k,latm) = u_cosphi(2*m ,k,latm) + tmpi
-!
- tmpr = vz_tmp(ir)*alpn(mr+n)
- tmpi = vz_tmp(ii)*alpn(mr+n)
- v_cosphi(2*m-1,k,latp) = v_cosphi(2*m-1,k,latp) + tmpi
- v_cosphi(2*m ,k,latp) = v_cosphi(2*m ,k,latp) - tmpr
-!
- if(present(div)) then
- tmpr = d_tmp(ir)*alp(mr+n,irow)
- tmpi = d_tmp(ii)*alp(mr+n,irow)
- div_tmp(2*m-1,k,latp) = div_tmp(2*m-1,k,latp) + tmpr
- div_tmp(2*m ,k,latp) = div_tmp(2*m ,k,latp) + tmpi
- end if
-!
- if(present(vort)) then
- tmpr = vz_tmp(ir)*alp(mr+n,irow)
- tmpi = vz_tmp(ii)*alp(mr+n,irow)
- vort_tmp(2*m-1,k,latp) = vort_tmp(2*m-1,k,latp) + tmpr
- vort_tmp(2*m ,k,latp) = vort_tmp(2*m ,k,latp) + tmpi
- end if
- end do
- end do
-!
-! Correction to get the absolute vorticity.
-!
- if(present(vort)) then
- vort_tmp(1,k,latp) = vort_tmp(1,k,latp) + zcor
- end if
-!
-! Recompute real fields from symmetric and antisymmetric parts
-!
- do i=1,plon+2
- tmp1 = u_cosphi(i,k,latm) + u_cosphi(i,k,latp)
- tmp2 = u_cosphi(i,k,latm) - u_cosphi(i,k,latp)
- u_cosphi(i,k,latm) = tmp1
- u_cosphi(i,k,latp) = tmp2
-!
- tmp1 = v_cosphi(i,k,latm) + v_cosphi(i,k,latp)
- tmp2 = v_cosphi(i,k,latm) - v_cosphi(i,k,latp)
- v_cosphi(i,k,latm) = tmp1
- v_cosphi(i,k,latp) = tmp2
-!
- if(present(vort)) then
- tmp1 = vort_tmp(i,k,latm) + vort_tmp(i,k,latp)
- tmp2 = vort_tmp(i,k,latm) - vort_tmp(i,k,latp)
- vort_tmp(i,k,latm) = tmp1
- vort_tmp(i,k,latp) = tmp2
- end if
-!
- if(present(div)) then
- tmp1 = div_tmp(i,k,latm) + div_tmp(i,k,latp)
- tmp2 = div_tmp(i,k,latm) - div_tmp(i,k,latp)
- div_tmp(i,k,latm) = tmp1
- div_tmp(i,k,latp) = tmp2
- end if
- end do
- enddo ! irow=1,plat/2
- enddo ! k=1,plev
-!
- do lat=1,plat
-!
-! Transform Fourier -> grid, obtaining spectrally truncated
-! grid point values.
-!
- irow = lat
- if (lat.gt.plat/2) irow = plat - lat + 1
-
- call fft991(u_cosphi(1,1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,plev,+1)
- call fft991(v_cosphi(1,1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,plev,+1)
- if(present(vort)) then
- call fft991(vort_tmp(1,1,lat),work,trig(1,irow),ifax(1,irow),1, &
- plondfft,plon,plev,+1)
- vort(:plon,:,lat) = vort_tmp(:plon,:,lat)
- end if
- if(present(div)) then
- call fft991(div_tmp(1,1,lat),work,trig(1,irow),ifax(1,irow),1,plondfft, &
- plon,plev,+1)
- div(:plon,:,lat) = div_tmp(:plon,:,lat)
- end if
-!
-! Convert U,V to u,v
-!
- zsqcs = sqrt(cs(irow))
- do k=1,plev
- do i=1,plon
- u3(i,k,lat) = u_cosphi(i,k,lat)/zsqcs
- v3(i,k,lat) = v_cosphi(i,k,lat)/zsqcs
- end do
- end do
- enddo
- deallocate( u_cosphi )
- deallocate( v_cosphi )
- if ( present(div) ) deallocate( div_tmp )
- if ( present(vort) ) deallocate( vort_tmp )
-
- return
-end subroutine spetru_uv
-
-end module spetru
diff --git a/src/dynamics/eul/sphdep.F90 b/src/dynamics/eul/sphdep.F90
deleted file mode 100644
index e7ebeeeb73..0000000000
--- a/src/dynamics/eul/sphdep.F90
+++ /dev/null
@@ -1,765 +0,0 @@
-
-subroutine sphdep(jcen ,jgc ,dt ,ra ,iterdp , &
- locgeo ,ub ,uxl ,uxr ,lam , &
- phib ,lbasiy ,lammp ,phimp ,lamdp , &
- phidp ,idp ,jdp ,vb ,vxl , &
- vxr ,nlon ,nlonex )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Compute departure points for semi-Lagrangian transport on surface of
-! sphere using midpoint quadrature. Computations are done in:
-!
-! 1) "local geodesic" coordinates for "locgeo" = .true.
-! 2) "global spherical" coordinates for "locgeo" = .false.
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plev, plon, plat
- use scanslt, only: platd, plond, beglatex, endlatex, i1, nxpt, j1
- use cam_abortutils, only: endrun
- use cam_logfile, only: iulog
-
- implicit none
-#include <parslt.h>
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nlon ! longitude dimension
- integer , intent(in) :: nlonex(platd) ! extended longitude dimension
- integer , intent(in) :: jcen ! index of lat slice (extnd)
- integer , intent(in) :: jgc ! index of lat slice (model)
- real(r8), intent(in) :: dt ! time step (seconds)
- real(r8), intent(in) :: ra ! 1./(radius of earth)
- integer , intent(in) :: iterdp ! number of iterations
- logical , intent(in) :: locgeo ! computation type flag
- real(r8), intent(in) :: ub (plond,plev,beglatex:endlatex) ! x-deriv
- real(r8), intent(in) :: vb (plond,plev,beglatex:endlatex) ! x-deriv
- real(r8), intent(in) :: uxl(plond,plev,beglatex:endlatex) ! left x-deriv (u)
- real(r8), intent(in) :: uxr(plond,plev,beglatex:endlatex) ! right x-deriv
- real(r8), intent(in) :: vxl(plond,plev,beglatex:endlatex) ! left x-deriv (v)
- real(r8), intent(in) :: vxr(plond,plev,beglatex:endlatex) ! right x-deriv
- real(r8), intent(in) :: lam(plond,platd) ! long. coord. of model grid
- real(r8), intent(in) :: phib(platd) ! lat. coord. of model grid
- real(r8), intent(in) :: lbasiy(4,2,platd) ! lat interpolation weights
- real(r8), intent(inout) :: lammp(plon,plev) ! long coord of midpoint
- real(r8), intent(inout) :: phimp(plon,plev) ! lat coord of midpoint
- real(r8), intent(out) :: lamdp(plon,plev) ! long coord of dep. point
- real(r8), intent(out) :: phidp(plon,plev) ! lat coord of dep. point
- integer , intent(out) :: idp(plon,plev,4) ! long index of dep. point
- integer , intent(out) :: jdp(plon,plev) ! lat index of dep. point
-!
-! jcen Index in extended grid corresponding to latitude being
-! forecast.
-! jgc Index in model grid corresponding to latitude being
-! forecast.
-! dt Time interval that parameterizes the parcel trajectory.
-! ra Reciprocal of radius of earth.
-! iterdp Number of iterations used for departure point calculation.
-! locgeo Logical flag to indicate computation in "local geodesic" or
-! "global spherical" space.
-! ub Longitudinal velocity components in spherical coordinates.
-! uxl x-derivatives of u at the left (west) edge of given interval
-! vxl x-derivatives of v at the left (west) edge of given interval
-! uxr x-derivatives of u at the right (east) edge of given interval
-! vxr x-derivatives of v at the right (east) edge of given interval
-! lam Longitude values for the extended grid.
-! phib Latitude values for the extended grid.
-! lbasiy Weights for Lagrange cubic interpolation on the unequally
-! spaced latitude grid.
-! lammp Longitude coordinates of the trajectory mid-points of the
-! parcels that correspond to the global grid points contained
-! in the latitude slice being forecast. On entry lammp
-! is an initial guess.
-! phimp Latitude coordinates of the trajectory mid-points of the
-! parcels that correspond to the global grid points contained
-! in the latitude slice being forecast. On entry phimp
-! is an initial guess.
-! lamdp Longitude coordinates of the departure points that correspond
-! to the global grid points contained in the latitude slice
-! being forecast. lamdp is constrained so that
-! 0.0 .le. lamdp(i) .lt. 2*pi .
-! phidp Latitude coordinates of the departure points that correspond
-! to the global grid points contained in the latitude slice
-! being forecast. If phidp is computed outside the latitudinal
-! domain of the extended grid, then an abort will be called by
-! subroutine "trjgl".
-! idp Longitude index of departure points. This index points into
-! the extended arrays, e.g.,
-! lam (idp(i,k)) .le. lamdp(i,k) .lt. lam (idp(i,k)+1).
-! jdp Latitude index of departure points. This index points into
-! the extended arrays, e.g.,
-! phib(jdp(i,k)) .le. phidp(i,k) .lt. phib(jdp(i,k)+1).
-!-----------------------------------------------------------------------
-
- !------------------------ local variables ------------------------------
- integer iter ! index
- integer i, j, k ! indices
- integer imax, imin, kmin, kmax ! indices
- real(r8) finc ! time step factor
- real(r8) dttmp ! time step (seconds)
- real(r8) dlam(platd) ! increment of grid in x-direction
- real(r8) phicen ! latitude coord of current lat slice
- real(r8) cphic ! cos(phicen)
- real(r8) sphic ! sin(phicen)
- real(r8) upr (plon,plev) ! u in local geodesic coords
- real(r8) vpr (plon,plev) ! v in local geodesic coords
- real(r8) lampr(plon,plev) ! relative long coord of dep pt
- real(r8) phipr(plon,plev) ! relative lat coord of dep pt
- real(r8) uvmp (plon,plev,2) ! u/v (spherical) interpltd to dep pt
- real(r8) fint (plon,plev,ppdy,2) ! u/v x-interpolants
- real(r8) phidpmax
- real(r8) phidpmin
- real(r8) phimpmax
- real(r8) phimpmin
-!-----------------------------------------------------------------------
-!
- do j=1,platd
- dlam(j) = lam(nxpt+2,j) - lam(nxpt+1,j)
- end do
- phicen = phib(jcen)
- cphic = cos( phicen )
- sphic = sin( phicen )
-!
-! Convert latitude coordinates of trajectory midpoints from spherical
-! to local geodesic basis.
-!
- if( locgeo ) call s2gphi(lam(i1,jcen) ,cphic ,sphic ,lammp ,phimp, &
- phipr ,nlon )
-!
-! Loop over departure point iterates.
-!
- do 30 iter = 1,iterdp
-!
-! Compute midpoint indicies.
-!
- call bandij(dlam ,phib ,lammp ,phimp ,idp , &
- jdp ,nlon )
-!
-! Hermite cubic interpolation to the x-coordinate of each
-! departure point at each y-coordinate required to compute the
-! y-interpolants.
-!
- call herxin(1 ,1 ,ub ,uxl ,uxr , &
- lam ,lammp ,idp ,jdp ,fint(1,1,1,1), &
- nlon ,nlonex )
-
- call herxin(1 ,1 ,vb ,vxl ,vxr , &
- lam ,lammp ,idp ,jdp ,fint(1,1,1,2), &
- nlon ,nlonex )
-
- call lagyin(2 ,fint ,lbasiy ,phimp ,jdp , &
- jcen ,uvmp ,nlon )
-!
-! Put u/v on unit sphere
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k = 1,plev
- do i = 1,nlon
- uvmp(i,k,1) = uvmp(i,k,1)*ra
- uvmp(i,k,2) = uvmp(i,k,2)*ra
- end do
- end do
-!
-! For local geodesic:
-!
-! a) Convert velocity coordinates at trajectory midpoints from
-! spherical coordinates to local geodesic coordinates,
-! b) Estimate midpoint parcel trajectory,
-! c) Convert back to spherical coordinates
-!
-! Else, for global spherical
-!
-! Estimate midpoint trajectory with no conversions
-!
- if ( locgeo ) then
- call s2gvel(uvmp(1,1,1),uvmp(1,1,2) ,lam(i1,jcen) ,cphic ,sphic , &
- lammp ,phimp ,upr ,vpr ,nlon )
- call trajmp(dt ,upr ,vpr ,phipr ,lampr , &
- nlon )
- dttmp = 0.5_r8*dt
- call g2spos(dttmp ,lam(i1,jcen) ,phib ,phicen ,cphic , &
- sphic ,upr ,vpr ,lampr ,phipr , &
- lammp ,phimp ,nlon )
- else
- call trjmps(dt ,uvmp(1,1,1) ,uvmp(1,1,2), phimp ,lampr , &
- phipr ,nlon )
- finc = 1._r8
- call trjgl (finc ,phicen ,lam(i1,jcen) ,lampr ,phipr , &
- lammp ,phimp ,nlon )
- end if
-!
-! Test that the latitudinal extent of trajectory is NOT over the poles
-! Distributed memory case: check that the latitudinal extent of the
-! trajectory is not more than "jintmx" gridpoints away.
-!
- phimpmax = -1.e36_r8
- phimpmin = 1.e36_r8
- do k=1,plev
- do i=1,nlon
- if (phimp(i,k)>phimpmax) then
- phimpmax = phimp(i,k)
- imax = i
- kmax = k
- end if
- if (phimp(i,k)<phimpmin) then
- phimpmin = phimp(i,k)
- imin = i
- kmin = k
- end if
- end do
- end do
-#if ( defined SPMD )
- if ( phimp(imax,kmax) >= phib(endlatex-nxpt) ) then
-#else
- if ( phimp(imax,kmax) >= phib(j1+plat) ) then
-#endif
- write(iulog,*)'SPHDEP: ****** MODEL IS BLOWING UP: CFL condition likely violated *********'
- write(iulog,9000) imax,kmax,jgc
- write(iulog,*)' Possible solutions: a) reduce time step'
- write(iulog,*)' b) if initial run, set "DIVDAMPN = 1." in namelist and rerun'
- write(iulog,*)' c) modified code may be in error'
- call endrun
-#if ( defined SPMD )
- else if( phimp(imin,kmin) < phib(beglatex+nxpt) ) then
-#else
- else if( phimp(imin,kmin) < phib(j1-1) ) then
-#endif
- write(iulog,*)'SPHDEP: ****** MODEL IS BLOWING UP: CFL condition likely violated *********'
- write(iulog,9000) imin,kmin,jgc
- write(iulog,*)' Possible solutions: a) reduce time step'
- write(iulog,*)' b) if initial run, set "DIVDAMPN = 1." in namelist and rerun'
- write(iulog,*)' c) modified code may be in error'
- call endrun
- end if
-
-30 continue ! End of iter=1,iterdp loop
-!
-! Compute departure points in geodesic coordinates, and convert back
-! to spherical coordinates.
-!
-! Else, compute departure points directly in spherical coordinates
-!
- if (locgeo) then
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k = 1,plev
- do i = 1,nlon
- lampr(i,k) = 2._r8*lampr(i,k)
- phipr(i,k) = 2._r8*phipr(i,k)
- end do
- end do
- dttmp = dt
- call g2spos(dttmp ,lam(i1,jcen) ,phib ,phicen ,cphic , &
- sphic ,upr ,vpr ,lampr ,phipr , &
- lamdp ,phidp ,nlon )
- else
- finc = 2._r8
- call trjgl (finc ,phicen ,lam(i1,jcen) ,lampr ,phipr , &
- lamdp ,phidp ,nlon )
- end if
-!
-! Test that the latitudinal extent of trajectory is NOT over the poles
-! Distributed memory case: check that the latitudinal extent of the
-! trajectory is not more than "jintmx" gridpoints away.
-!
- phidpmax = -1.e36_r8
- phidpmin = 1.e36_r8
- do k=1,plev
- do i=1,nlon
- if (phidp(i,k)>phidpmax) then
- phidpmax = phidp(i,k)
- imax = i
- kmax = k
- end if
- if (phidp(i,k)<phidpmin) then
- phidpmin = phidp(i,k)
- imin = i
- kmin = k
- end if
- end do
- end do
-#if ( defined SPMD )
- if ( phidp(imax,kmax) >= phib(endlatex-nxpt) ) then
-#else
- if ( phidp(imax,kmax) >= phib(j1+plat) ) then
-#endif
- write(iulog,*)'SPHDEP: ****** MODEL IS BLOWING UP: CFL condition likely violated *********'
- write(iulog,9000) imax,kmax,jgc
- write(iulog,*)' Possible solutions: a) reduce time step'
- write(iulog,*)' b) if initial run, set "DIVDAMPN = 1." in namelist and rerun'
- write(iulog,*)' c) modified code may be in error'
- call endrun
-#if ( defined SPMD )
- else if( phidp(imin,kmin) < phib(beglatex+nxpt) ) then
-#else
- else if( phidp(imin,kmin) < phib(j1-1) ) then
-#endif
- write(iulog,*)'SPHDEP: ****** MODEL IS BLOWING UP: CFL condition likely violated *********'
- write(iulog,9000) imin,kmin,jgc
- write(iulog,*)' Possible solutions: a) reduce time step'
- write(iulog,*)' b) if initial run, set "DIVDAMPN = 1." in namelist and rerun'
- write(iulog,*)' c) modified code may be in error'
- call endrun
- end if
-!
-! Compute departure point indicies.
-!
- call bandij(dlam ,phib ,lamdp ,phidp ,idp , &
- jdp ,nlon )
-
-9000 format(//'Parcel associated with longitude ',i5,', level ',i5, &
- ' and latitude ',i5,' is outside the model domain.')
-
- return
-end subroutine sphdep
-
-!============================================================================================
-
-subroutine g2spos(dttmp ,lam ,phib ,phi ,cosphi , &
- sinphi ,upr ,vpr ,lamgc ,phigc , &
- lamsc ,phisc ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Transform position coordinates for a set of points, each of which is
-! associated with a grid point in a global latitude slice, from local
-! geodesic to spherical coordinates.
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev, plat
- use scanslt, only: plond1, platd, j1
- implicit none
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: dttmp ! time step
- real(r8), intent(in) :: lam(plond1) ! model longitude coordinates
- real(r8), intent(in) :: phib(platd) ! extended grid latitude coordinates
- real(r8), intent(in) :: phi ! current latitude coordinate (radians)
- real(r8), intent(in) :: cosphi ! cos of current latitude
- real(r8), intent(in) :: sinphi ! sin of current latitude
- real(r8), intent(in) :: upr (plon,plev) ! u-wind in geodesic coord
- real(r8), intent(in) :: vpr (plon,plev) ! v-wind in geodesic coord
- real(r8), intent(in) :: lamgc(plon,plev) ! geodesic long coord. of dep. point
- real(r8), intent(in) :: phigc(plon,plev) ! geodesic lat coord. of dep. point
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(out):: lamsc(plon,plev) ! spherical long coord. of dep. point
- real(r8), intent(out):: phisc(plon,plev) ! spherical lat coord. of dep. point
-!
-!
-! dttmp Time step over which midpoint/endpoint trajectory is
-! calculated (seconds).
-! lam Longitude coordinates of the global grid points in spherical
-! system. The grid points in the global array are the reference
-! points for the local geodesic systems.
-! phib Latitude values for the extended grid.
-! phi Latitude coordinate (in the global grid) of the current
-! latitude slice.
-! cosphi cos( phi )
-! sinphi sin( phi )
-! upr zonal velocity at departure point in local geodesic coord
-! vpr Meridional velocity at departure point in local geodesic coord
-! lamgc Longitude coordinate of points in geodesic coordinates.
-! phigc Latitude coordinate of points in geodesic coordinates.
-! lamsc Longitude coordinate of points in spherical coordinates.
-! phisc Latitude coordinate of points in spherical coordinates.
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i,ii,k ! indices
- integer nval(plev) ! number of values returned from whenfgt
- integer indx(plon,plev) ! index holder
- real(r8) pi ! 4.*atan(1.)
- real(r8) twopi ! 2.*pi
- real(r8) pi2 ! pi/2
- real(r8) sgnphi ! holds sign of phi
- real(r8) sphigc ! sin(phigc)
- real(r8) cphigc ! cos(phigc)
- real(r8) clamgc ! cos(lamgc)
- real(r8) slam2 ! sin(lamgc)**2
- real(r8) phipi2 ! tmp variable
- real(r8) slamgc(plon,plev) ! sin(lamgc)
- real(r8) dlam(plon,plev) ! zonal extent of trajectory
- real(r8) coeff ! tmp variable
- real(r8) distmx ! max distance
- real(r8) dist(plon,plev) ! approx. distance traveled along traj.
- real(r8) fac ! 1. - 10*eps, eps from mach. precision
- integer s_nval
-!-----------------------------------------------------------------------
-!
- fac = 1._r8 - 10._r8*epsilon (fac)
- pi = 4._r8*atan(1._r8)
- twopi = pi*2._r8
- pi2 = pi/2._r8
- coeff = (1.1_r8*dttmp)**2
- distmx = (sign(pi2,phi) - phi)**2/coeff
- sgnphi = sign( 1._r8, phi )
-
-!$OMP PARALLEL DO PRIVATE (K, I, SPHIGC, CPHIGC, CLAMGC, S_NVAL)
- do k=1,plev
- do i=1,nlon
- sphigc = sin( phigc(i,k) )
- cphigc = cos( phigc(i,k) )
- slamgc(i,k) = sin( lamgc(i,k) )
- clamgc = cos( lamgc(i,k) )
- phisc(i,k) = asin((sphigc*cosphi + cphigc*sinphi*clamgc)*fac)
- if ( abs(phisc(i,k)) .ge. phib(j1+plat)*fac ) then
- phisc(i,k) = sign( phib(j1+plat),phisc(i,k) )*fac
- end if
- dlam(i,k) = asin((slamgc(i,k)*cphigc/cos(phisc(i,k)))*fac)
-!
-! Compute estimated trajectory distance based upon winds alone
-!
- dist(i,k) = upr(i,k)**2 + vpr(i,k)**2
- end do
-!
-! Determine which trajectories may have crossed over pole
-!
- s_nval = 0
- do i=1,nlon
- if (dist(i,k) > distmx) then
- s_nval = s_nval + 1
- indx(s_nval,k) = i
- end if
- end do
- nval(k) = s_nval
- end do
-!
-! Check that proper branch of arcsine is used for calculation of
-! dlam for those trajectories which may have crossed over pole.
-!
-!$OMP PARALLEL DO PRIVATE (K, II, I, SLAM2, PHIPI2)
- do k=1,plev
- do ii=1,nval(k)
- i = indx(ii,k)
- slam2 = slamgc(i,k)**2
- phipi2 = asin((sqrt((slam2 - 1._r8)/(slam2 - 1._r8/cosphi**2)))*fac)
- if (sgnphi*phigc(i,k) > phipi2) then
- dlam(i,k) = sign(pi,lamgc(i,k)) - dlam(i,k)
- end if
- end do
-
- do i=1,nlon
- lamsc(i,k) = lam(i) + dlam(i,k)
-!
-! Restrict longitude to be in the range [0, twopi).
-!
- if( lamsc(i,k) >= twopi ) lamsc(i,k) = lamsc(i,k) - twopi
- if( lamsc(i,k) < 0.0_r8 ) lamsc(i,k) = lamsc(i,k) + twopi
- end do
- end do
-
- return
-end subroutine g2spos
-
-!============================================================================================
-
-subroutine s2gphi(lam ,cosphi ,sinphi ,lamsc ,phisc , &
- phigc ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Calculate transformed local geodesic latitude coordinates for a set
-! of points, each of which is associated with a grid point in a global
-! latitude slice. Transformation is spherical to local geodesic.
-! (Williamson and Rasch, 1991)
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
- use scanslt, only: plond1
- implicit none
-
-!------------------------------Arguments--------------------------------
- real(r8), intent(in) :: lam(plond1) ! long coordinates of model grid
- real(r8), intent(in) :: cosphi ! cos(latitude)
- real(r8), intent(in) :: sinphi ! sin(latitude)
- real(r8), intent(in) :: lamsc(plon,plev) ! spher. long coords of dep points
- real(r8), intent(in) :: phisc(plon,plev) ! spher. lat coords of dep points
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(out) :: phigc(plon,plev) ! loc geod. lat coords of dep points
-!
-! lam longitude coordinates of the global grid points in spherical
-! system. The grid points in the global array are the reference
-! points for the local geodesic systems.
-! cosphi cosine of the latitude of the global latitude slice.
-! sinphi sine of the latitude of the global latitude slice.
-! lamsc longitude coordinate of dep. points in spherical coordinates.
-! phisc latitude coordinate of dep. points in spherical coordinates.
-! phigc latitude coordinate of dep. points in local geodesic coords.
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i,k ! longitude, level indices
- real(r8) sphisc ! |
- real(r8) cphisc ! | -- temporary variables
- real(r8) clamsc ! |
-!-----------------------------------------------------------------------
-!
-!$OMP PARALLEL DO PRIVATE (K, I, SPHISC, CPHISC, CLAMSC)
- do k = 1,plev
- do i = 1,nlon
- sphisc = sin( phisc(i,k) )
- cphisc = cos( phisc(i,k) )
- clamsc = cos( lam(i) - lamsc(i,k) )
- phigc(i,k) = asin( sphisc*cosphi - cphisc*sinphi*clamsc )
- end do
- end do
-
- return
-end subroutine s2gphi
-
-!============================================================================================
-
-subroutine s2gvel(udp ,vdp ,lam ,cosphi ,sinphi , &
- lamdp ,phidp ,upr ,vpr ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Transform velocity components at departure points associated with a
-! single latitude slice from spherical coordinates to local geodesic
-! coordinates. (Williamson and Rasch, 1991)
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
- use scanslt, only: plond1
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(in) :: udp(plon,plev) ! u in spherical coords.
- real(r8), intent(in) :: vdp(plon,plev) ! v in spherical coords.
- real(r8), intent(in) :: lam(plond1) ! x-coordinates of model grid
- real(r8), intent(in) :: cosphi ! cos(latitude)
- real(r8), intent(in) :: sinphi ! sin(latitude)
- real(r8), intent(in) :: lamdp(plon,plev) ! spherical longitude coord of dep pt.
- real(r8), intent(in) :: phidp(plon,plev) ! spherical latitude coord of dep pt.
- real(r8), intent(out) :: upr(plon,plev) ! u in local geodesic coords.
- real(r8), intent(out) :: vpr(plon,plev) ! v in local geodesic coords.
-!
-! udp u-component of departure point velocity in spherical coords.
-! vdp v-component of departure point velocity in spherical coords.
-! lam Longitude of arrival point position (model grid point) in spherical coordinates.
-! cosphi Cos of latitude of arrival point positions (model grid pt).
-! sinphi Sin of latitude of arrival point positions (model grid pt).
-! lamdp Longitude of departure point position in spherical coordinates.
-! phidp Latitude of departure point position in spherical coordinates.
-! upr u-component of departure point velocity in geodesic coords.
-! vpr v-component of departure point velocity in geodesic coords.
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i,k ! longitude, level indices
- real(r8) cdlam ! |
- real(r8) clamp ! |
- real(r8) cphid ! |
- real(r8) cphip ! |
- real(r8) dlam ! | -- temporary variables
- real(r8) sdlam ! |
- real(r8) slamp ! |
- real(r8) sphid ! |
- real(r8) sphip ! |
-!-----------------------------------------------------------------------
-!
-!$OMP PARALLEL DO PRIVATE (K, I, DLAM, SDLAM, CDLAM, SPHID, CPHID, SPHIP, &
-!$OMP CPHIP, SLAMP, CLAMP)
- do k = 1,plev
- do i = 1,nlon
- dlam = lam(i) - lamdp(i,k)
- sdlam = sin( dlam )
- cdlam = cos( dlam )
- sphid = sin( phidp(i,k) )
- cphid = cos( phidp(i,k) )
- sphip = sphid*cosphi - cphid*sinphi*cdlam
- cphip = cos( asin( sphip ) )
- slamp = -sdlam*cphid/cphip
- clamp = cos( asin( slamp ) )
- vpr(i,k) = (vdp(i,k)*(cphid*cosphi + sphid*sinphi*cdlam) - &
- udp(i,k)*sinphi*sdlam)/cphip
- upr(i,k) = (udp(i,k)*cdlam + vdp(i,k)*sphid*sdlam + &
- vpr(i,k)*slamp*sphip)/clamp
- end do
- end do
-
- return
-end subroutine s2gvel
-
-!============================================================================================
-
-subroutine trajmp(dt ,upr ,vpr ,phipr ,lampr , &
- nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Estimate mid-point of parcel trajectory (geodesic coordinates) based
-! upon horizontal wind field.
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(in) :: dt ! time step (seconds)
- real(r8), intent(in) :: upr(plon,plev) ! u-component of wind in local geodesic
- real(r8), intent(in) :: vpr(plon,plev) ! v-component of wind in local geodesic
- real(r8), intent(inout) :: phipr(plon,plev) ! latitude coord of trajectory mid-point
- real(r8), intent(out) :: lampr(plon,plev) ! longitude coord of traj. mid-point
-!
-! dt Time interval that corresponds to the parcel trajectory.
-! upr u-coordinate of velocity corresponding to the most recent
-! estimate of the trajectory mid-point (in geodesic system).
-! vpr v-coordinate of velocity corresponding to the most recent
-! estimate of the trajectory mid-point (in geodesic system).
-! phipr Phi value at trajectory mid-point (geodesic coordinates).
-! On entry this is the most recent estimate.
-! lampr Lambda value at trajectory mid-point (geodesic coordinates).
-!-----------------------------------------------------------------------
-
-!---------------------------Local variables-----------------------------
- integer i,k ! index
-!-----------------------------------------------------------------------
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i = 1,nlon
- lampr(i,k) = -.5_r8*dt* upr(i,k) / cos( phipr(i,k) )
- phipr(i,k) = -.5_r8*dt* vpr(i,k)
- end do
- end do
-
- return
-end subroutine trajmp
-
-!============================================================================================
-
-subroutine trjgl(finc ,phicen ,lam ,lampr ,phipr , &
- lamp ,phip ,nlon )
-
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Map relative trajectory mid/departure point coordinates to global
-! latitude/longitude coordinates and test limits
-!
-! Method:
-!
-! Author: J. Olson
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
- use scanslt, only: plond1
- implicit none
-
-!------------------------------Arguments--------------------------------
- integer , intent(in) :: nlon ! longitude dimension
- real(r8), intent(in) :: finc ! number of time increments
- real(r8), intent(in) :: phicen ! current latitude value in extnded grid
- real(r8), intent(in) :: lam(plond1) ! longitude values for the extended grid
- real(r8), intent(in) :: lampr(plon,plev) ! relative x-coordinate of departure pt.
- real(r8), intent(in) :: phipr(plon,plev) ! relative y-coordinate of departure pt.
- real(r8), intent(out) :: lamp (plon,plev) ! long coords of traj midpoints
- real(r8), intent(out) :: phip (plon,plev) ! lat coords of traj midpoints
-!
-! finc Time step factor (1. for midpoint, 2. for dep. point)
-! phicen Latitude value for current latitude being forecast.
-! lam Longitude values for the extended grid.
-! lampr Longitude coordinates (relative to the arrival point) of the
-! trajectory mid-points of the parcels that correspond to the
-! global grid points contained in the latitude slice being forecast.
-! phipr Latitude coordinates (relative to the arrival point) of the
-! trajectory mid-points of the parcels that correspond to the
-! global grid points contained in the latitude slice being forecast.
-! lamp Longitude coordinates of the trajectory mid-points of the
-! parcels that correspond to the global grid points contained
-! in the latitude slice being forecast.
-! phip Latitude coordinates of the trajectory mid-points of the
-! parcels that correspond to the global grid points contained
-! in the latitude slice being forecast.
-!-----------------------------------------------------------------------
-
-!--------------------------Local variables------------------------------
- integer i ! longitude index
- integer k ! level index
- real(r8) pi ! 3.14.......
- real(r8) twopi ! 2*pi
-!-----------------------------------------------------------------------
-!
- pi = 4._r8*atan(1._r8)
- twopi = pi*2._r8
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k = 1,plev
- do i = 1,nlon
- lamp(i,k) = lam(i) + finc*lampr(i,k)
- phip(i,k) = phicen + finc*phipr(i,k)
- if(lamp(i,k) >= twopi) lamp(i,k) = lamp(i,k) - twopi
- if(lamp(i,k) < 0.0_r8) lamp(i,k) = lamp(i,k) + twopi
- end do
- end do
-
- return
-end subroutine trjgl
-
diff --git a/src/dynamics/eul/spmd_dyn.F90 b/src/dynamics/eul/spmd_dyn.F90
deleted file mode 100644
index b9928fe43f..0000000000
--- a/src/dynamics/eul/spmd_dyn.F90
+++ /dev/null
@@ -1,1111 +0,0 @@
-module spmd_dyn
-
-!-----------------------------------------------------------------------
-!
-! Purpose: SPMD implementation of CAM spectral Eulerian dynamics.
-!
-! Author: CCM Core Group
-! Modified: P. Worley, September 2002, November 2003, December 2003,
-! November 2004, January 2005, April 2007
-!
-!-----------------------------------------------------------------------
-
-#if (defined SPMD)
-
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plat, numlats, &
- beglat, endlat, begirow, endirow, plev
- use spmd_utils, only: iam, masterproc, npes, proc_smp_map
- use scamMod, only: single_column
- use scanslt, only: beglatex, endlatex, numbnd, numlatsex
- use mpishorthand, only: mpir8, mpicom
- use cam_abortutils, only: endrun
- use cam_logfile, only: iulog
-
- implicit none
-
- private
- save
-
- public spmdinit_dyn, compute_gsfactors, spmdbuf
- public spmd_readnl
-
- logical, public :: local_dp_map=.false. ! flag indicates that mapping between dynamics
- ! and physics decompositions does not require
- ! interprocess communication
- integer, public :: block_buf_nrecs ! number of local grid points (lon,lat,lev)
- ! in dynamics decomposition (including level 0)
- integer, public :: chunk_buf_nrecs ! number of local grid points (lon,lat,lev)
- ! in physics decomposition (including level 0)
-
- integer, public, allocatable :: &
- cut(:,:), &! partition for MPI tasks
- cutex(:,:) ! extended partition
- integer, public :: proc(plat) ! MPI task id associated with a given lat.
- integer, public :: neighs ! number of south neighbors to comm guardcells
- integer, public, allocatable :: neighs_proc(:) ! sorted south process neighbors
- integer, public :: neighn ! number of north neighbors to comm guardcells
- integer, public, allocatable :: neighn_proc(:) ! sorted north process neighbors
- integer, public :: npessp ! number of MPI tasks in spectral space
- integer, public :: maxlats ! max number of lats on any MPI task
- integer, public :: maxcols ! max number of columns on any MPI task
- integer, public, allocatable :: nlat_p(:) ! number of latitudes per MPI task
- integer, public, allocatable :: ncol_p(:) ! number of columns per MPI task
- integer, public :: realloc4_steps ! number of swaps in realloc4 algorithms
- integer, public, allocatable :: realloc4_proc(:)
- ! swap partner in each step of
- ! realloc4 algorithms
- integer, public, allocatable :: realloc4_step(:)
- ! step in realloc4 algorithms
- ! in which communicate with a given
- ! process
- integer, public :: allgather_steps ! number of swaps in allgather algorithm
- integer, public, allocatable :: allgather_proc(:)
- ! swap partner in each step of
- ! allgather (realloc5/7) algorithm
- integer, public, allocatable :: allgather_step(:)
- ! step in allgather (realloc5/7) algorithm
- ! in which communicate with a given
- ! process
-!
- logical, private, parameter :: def_equi_by_col = .true. ! default
- logical, private :: dyn_equi_by_col = def_equi_by_col
- ! flag indicating whether to assign
- ! latitudes to equidistribute columns or
- ! latitudes. This only matters when using a
- ! reduced grid.
-!
- logical, private, parameter :: def_mirror = .false. ! default
- logical, private :: mirror = def_mirror ! flag indicating whether latitudes and their
- ! reflections across the equator should assigned
- ! to consecutive processes
-!
-! Dynamics communication transpose algorithm option:
-! 0: use mpi_alltoallv
-! 1: use point-to-point MPI-1 two-sided implementation
-! 2: use point-to-point MPI-2 one-sided implementation if supported,
-! otherwise use MPI-1 implementation
-! 3: use Co-Array Fortran implementation if supported,
-! otherwise use MPI-1 implementation
- integer, private, parameter :: min_alltoall = 0
- integer, private, parameter :: max_alltoall = 3
- integer, private, parameter :: def_alltoall = 0 ! default
- integer, public :: dyn_alltoall = def_alltoall
-!
-! Dynamics communication allgather (realloc5/7) algorithm option:
-! 0: use mpi_allgatherv
-! 1: use point-to-point MPI-1 two-sided implementation
-! 2: use point-to-point MPI-2 one-sided implementation if supported,
-! otherwise use MPI-1 implementation
-! 3: use Co-Array Fortran implementation if supported,
-! otherwise use MPI-1 implementation
- integer, private, parameter :: min_allgather = 0
- integer, private, parameter :: max_allgather = 3
- integer, private, parameter :: def_allgather = 0 ! default
- integer, public :: dyn_allgather = def_allgather
-!
-! Dynamics dyn_npes option:
-! 1 <= dyn_npes <= min( 2*(npes/2), plat )
- integer, private, parameter :: min_npes = 1
- integer, private, parameter :: max_npes = plat
- integer, private, parameter :: def_npes = plat
- integer, public :: dyn_npes = def_npes
-!
-! Dynamics dyn_npes_stride option:
-! 1 <= dyn_npes_stride <= npes/dyn_npes
- integer, private, parameter :: min_npes_stride = 1
- integer, private, parameter :: max_npes_stride = plat
- integer, private, parameter :: def_npes_stride = 1
- integer, public :: dyn_npes_stride = def_npes_stride
-!
-! MPI communicator for active dynamics processes
-!
- integer, public :: mpicom_dyn_active
-!
-! Collective communication send/receive buffers
-#if (defined CAF)
- real(r8), public, allocatable :: buf1(:)[:],buf2(:)[:] ! buffers for packing MPI msgs
-#else
- real(r8), public, allocatable :: buf1(:),buf2(:) ! buffers for packing MPI msgs
-#endif
- integer, public :: spmdbuf_siz = 0 ! buffer size (in r8s)
- integer, public :: buf1win ! buf1 Window id
- integer, public :: buf2win ! buf2 Window id
-
-contains
-
-!----------------------------------------------------------------------
-
- subroutine spmd_readnl(nlfilename)
-
- ! !USES:
- use units, only: getunit, freeunit
- use namelist_utils, only: find_group_name
- use spmd_utils, only: npes, masterproc
- use pmgrid, only: plat, plev, plon
- use mpishorthand
-
- implicit none
-
- !
- ! !PARAMETERS:
- character(len=*), intent(in) :: nlfilename
-
-! !DESCRIPTION: Read in EUL-specific namelist variables. Must be
-! performed before dyn\_init
-!
-! !REVISION HISTORY:
-! 2010.05.15 Sawyer Creation
-!
-!EOP
-!=========================================================================
-!BOC
-! Local variables
- integer :: ierr ! error code
- integer :: unitn ! namelist unit number
- character(len=*), parameter :: subname = "spmd_readnl"
-
- namelist /spmd_dyn_inparm/ dyn_alltoall, &
- dyn_allgather, &
- dyn_equi_by_col,&
- dyn_npes, &
- dyn_npes_stride
-
- if (masterproc) then
- write(iulog,*) 'Read in spmd_dyn_inparm namelist from: ', trim(nlfilename)
- unitn = getunit()
- open( unitn, file=trim(nlfilename), status='old' )
-
- ! Look for dyn_eul_inparm group name in the input file. If found, leave the
- ! file positioned at that namelist group.
- call find_group_name(unitn, 'spmd_dyn_inparm', status=ierr)
- if (ierr == 0) then ! found spmd_dyn_inparm
- read(unitn, spmd_dyn_inparm, iostat=ierr) ! read the spmd_dyn_inparm namelist group
- if (ierr /= 0) then
- call endrun( subname//':: namelist read returns an'// &
- ' error condition for spmd_dyn_inparm' )
- end if
- end if
- close( unitn )
- call freeunit( unitn )
- endif
-
- call mpibcast (dyn_alltoall ,1,mpiint,0,mpicom)
- call mpibcast (dyn_allgather ,1,mpiint,0,mpicom)
- call mpibcast (dyn_equi_by_col,1,mpilog,0,mpicom)
- call mpibcast (dyn_npes ,1,mpiint,0,mpicom)
- call mpibcast (dyn_npes_stride,1,mpiint,0,mpicom)
-
- if ((dyn_alltoall.lt.min_alltoall).or. &
- (dyn_alltoall.gt.max_alltoall)) then
- write(iulog,*) &
- 'spmd_readnl: ERROR: dyn_alltoall=', &
- dyn_alltoall, &
- ' is out of range. It must be between ', &
- min_alltoall,' and ',max_alltoall
- call endrun
- endif
-
- if ((dyn_allgather.lt.min_allgather).or. &
- (dyn_allgather.gt.max_allgather)) then
- write(iulog,*) &
- 'spmd_readnl: ERROR: dyn_allgather=', &
- dyn_allgather, &
- ' is out of range. It must be between ', &
- min_allgather,' and ',max_allgather
- call endrun
- endif
- !
- if ((dyn_npes.lt.min_npes).or. &
- (dyn_npes.gt.max_npes)) then
- write(iulog,*) &
- 'spmd_readnl: ERROR: dyn_npes=', &
- dyn_npes, &
- ' is out of range. It must be between ', &
- min_npes,' and ',max_npes
- call endrun
- endif
- !
- if ((dyn_npes_stride.lt.min_npes_stride).or. &
- (dyn_npes_stride.gt.max_npes_stride)) then
- write(iulog,*) &
- 'spmd_readnl: ERROR: dyn_npes_stride=', &
- dyn_npes_stride, &
- ' is out of range. It must be between ', &
- min_npes_stride,' and ',max_npes_stride
- call endrun
- endif
-
-
- end subroutine spmd_readnl
-
-
-!========================================================================
-
- subroutine spmdinit_dyn ()
-!-----------------------------------------------------------------------
-!
-! Purpose: Distribute latitudes among available processes
-!
-! Method: Distribution is S->N for processes 0->dyn_npes
-!
-! Author: CCM Core Group
-! Modified: P. Worley, November 2003 to improve SMP load balance, and to
-! change distribution to
-! S->E for processes 0,2,..,dyn_npes-2
-! and
-! N->E for processes 1,3,..,dyn_npes-1
-! when mirror flag is set (at request of physics)
-! Modified: P. Worley, November 2004 to improve load balance for
-! reduced grid by equidistributing columns (not latitudes)
-! in latitude decomposition. Used when equi_by_col flag is set.
-! On by default, and gives identical decomposition as
-! equidistributing by latitude when using a full grid.
-! Modified: P. Worley, April 2007 to support idle processes when
-! in the dynamics (dyn_npes < npes)
-!
-!-----------------------------------------------------------------------
- use comspe, only: numm
- use spmd_utils
-#if (defined MODCM_DP_TRANSPOSE)
- use parutilitiesmodule, only : parinit
-#endif
-!-----------------------------------------------------------------------
-!
-! Local workspace
-!
- integer i ! loop index
- integer tot_cols ! total number of columns in computational grid
- integer m2,m3,m5 ! 2, 3, 5 prime factors for problem decomposition
- integer tot_nx ! total number of latitudes/columns in
- ! computational grid
- integer nx_base ! approx. number of latitudes/columns per proc
- integer nx_p(0:npes-1) ! number of latitudes/columns per process
- integer nx_smp(0:npes-1) ! number of latitudes/columns per SMP
- integer nproc_smp(0:npes-1) ! number of MPI processes per SMP
- integer workleft ! amount of work still to be parcelled out
-
- integer smpid ! SMP id
- integer smpids ! SMP id for SH process
- integer smpidn ! SMP id for NH process
- integer procj ! process offset loop index
- integer procid ! process id
- integer procids ! process id SH
- integer procidn ! process id NH
- integer procid_s ! strided process id
- integer procids_s ! strided process id SH
- integer procidn_s ! strided process id NH
-
- integer max_ncols ! maximum number of columns assigned to a process
- integer min_max_ncols ! minmax number of columns assigned
- ! to a process over all latitude assignments
- integer ncol ! number of columns assigned to current process
- integer ncol_curtot ! current total number of columns assigned
- integer ncol_curgoal ! target number of columns to be assigned to process
- integer lat ! latitude index
- integer iend ! ending latitude band of work for a given proc
- integer neighn_minlat(plat) ! minimum latitude in north neighbor
- integer neighs_maxlat(plat) ! maximum latitude in south neighbor
- integer active_proc ! +1 for active dynamics processes
- integer ierror ! MPI error return
-
- real(r8) avgnx_proc(0:npes-1) ! average number of latitudes/columns per
- ! MPI process in a given SMP node
- real(r8) minavgnx_proc ! minimum average number of
- ! latitudes/columns per
- ! MPI process over SMP nodes
- real(r8) alpha ! slop factor in assigning latitudes to processes
- real(r8) opt_alpha! best slop factor in assigning latitudes to processes
-
- logical done ! exit flag for latitude assignment loop
-!
-!-----------------------------------------------------------------------
-!
-! Initialize Pilgrim library
-!
-#if (defined MODCM_DP_TRANSPOSE)
- call parinit(mpicom)
-#endif
-!
-! Initialize mirror flag
-!
- mirror = phys_mirror_decomp_req
-!
-! Allocate memory for MPI task partition array
-! and extended partition
-!
- allocate (cut (2,0:npes-1))
- cut(1,0:npes-1) = 1
- cut(2,0:npes-1) = 0
-!
- allocate (cutex(2,0:npes-1))
- cutex(1,0:npes-1) = 1
- cutex(2,0:npes-1) = 0
-!
-! Allocate memory for number of lats per proc
-!
- allocate (nlat_p (0:npes-1))
- nlat_p(0:npes-1) = 0
-!
-! Allocate memory for number of columns per proc
-!
- allocate (ncol_p (0:npes-1))
- ncol_p(0:npes-1) = 0
-!
-! determine total number of columns
-!
- tot_cols = 0
- do lat=1,plat
- tot_cols = tot_cols + plon
- enddo
-!
-! Make sure number of PEs, latitudes, and columns are kosher
-!
- call factor (plat, m2, m3, m5)
-
- if (.not. single_column) then
- if (m2 < 1) then
- call endrun('SPMDINIT_DYN: Problem size is not divisible by 2')
- end if
- end if
-
-
- if (masterproc) then
- write(iulog,*) 'Problem factors: 2**',m2,' * 3**',m3,' * 5**',m5
- end if
-
- if (npes > 1) then
- if (dyn_npes > min( 2*(npes/2), plat ) ) then
- dyn_npes = min( 2*(npes/2), plat )
- endif
- if (dyn_npes_stride > npes/dyn_npes) then
- dyn_npes_stride = npes/dyn_npes
- endif
- else
- dyn_npes = 1
- dyn_npes_stride = 1
- endif
-
- if (.not. single_column) then
- if ((dyn_equi_by_col) .and. (mod(tot_cols,2) /= 0)) then
- write(iulog,*)'SPMDINIT_DYN: Total number of columns(', &
- tot_cols,') must be a multiple of 2'
- call endrun('SPMDINIT_DYN: number of columns must be multiple of 2')
- end if
- end if
-!
-! Initialization for inactive processes
-!
- beglat = 1
- endlat = 0
- numlats = 0
- begirow = 1
- endirow = 0
-
- beglatex = 1
- endlatex = 0
- numlatsex = 0
-!
-! Special initialization for dyn_npes == 1 case
-!
- if (dyn_npes .eq. 1) then
-!
- nlat_p(0) = plat
- cut(1,0) = 1
- cut(2,0) = plat
-!
- ncol_p(0) = 0
- do lat=1,plat
- ncol_p(0) = ncol_p(0) + plon
- enddo
-!
- if (iam .eq. 0) then
- beglat = 1
- endlat = plat
- numlats = plat
- begirow = 1
- endirow = plat/2
- endif
-!
- else
-!
-! Determine approximate number of columns or latitudes per process
-!
- if (dyn_equi_by_col) then
- tot_nx = tot_cols
- else
- tot_nx = plat
- endif
- nx_base = tot_nx/dyn_npes
- do procid=0,dyn_npes-1
- procid_s = dyn_npes_stride*procid
- nx_p(procid_s) = nx_base
- enddo
-!
-! Calculate initial distribution of columns or latitudes and
-! distribution of processes by SMP
-!
- nx_smp(0:npes-1) = 0
- nproc_smp(0:npes-1) = 0
- do procid=0,dyn_npes-1
- procid_s = dyn_npes_stride*procid
- smpid = proc_smp_map(procid_s)
- nproc_smp(smpid) = nproc_smp(smpid) + 1
- enddo
-!
- do smpid=0,nsmps-1
- nx_smp(smpid) = nx_base*nproc_smp(smpid)
- avgnx_proc(smpid) = real(nx_base,r8)
- enddo
-!
-! Equi-distribute remaining columns or latitudes across SMPs
-! without increasing per process imbalance beyond minimum
-!
- workleft = tot_nx - dyn_npes*nx_base
- do while (workleft > 0)
-!
-! (a) Find minimun number of columns or latitudes assigned to an SMP
-!
- minavgnx_proc = avgnx_proc(0)
- do smpid=1,nsmps-1
- if (minavgnx_proc > avgnx_proc(smpid)) then
- minavgnx_proc = avgnx_proc(smpid)
- endif
- enddo
-!
-! (b) Assign an additional column or latitude to processes with
-! nx_base latitudes/columns in SMPs with the minimum
-! average number of latitudes/columns
-!
- do procid=dyn_npes/2-1,0,-1
- if (mirror) then
- procids = 2*procid
- procidn = procids + 1
- else
- procids = procid
- procidn = dyn_npes - procids - 1
- endif
-!
- procids_s = dyn_npes_stride*procids
- procidn_s = dyn_npes_stride*procidn
-!
- smpids = proc_smp_map(procids_s)
- smpidn = proc_smp_map(procidn_s)
- if ((nx_p(procids_s) .eq. nx_base) .and. &
- ((avgnx_proc(smpids) .eq. minavgnx_proc) .or. &
- (avgnx_proc(smpidn) .eq. minavgnx_proc)) .and. &
- (workleft > 0)) then
-!
- nx_p(procids_s) = nx_p(procids_s) + 1
- nx_smp(smpids) = nx_smp(smpids) + 1
- avgnx_proc(smpids) = &
- real(nx_smp(smpids),r8)/real(nproc_smp(smpids),r8)
-!
- nx_p(procidn_s) = nx_p(procids_s)
- nx_smp(smpidn) = nx_smp(smpidn) + 1
- avgnx_proc(smpidn) = &
- real(nx_smp(smpidn),r8)/real(nproc_smp(smpidn),r8)
-!
- workleft = workleft - 2
- endif
- enddo
- end do
-!
-! Partition latitudes over processes, equidistributing either
-! a) columns, or
-! b) latitudes
-!
- if (dyn_equi_by_col) then
-!
-! Evaluate different latitude assignments
-!
- min_max_ncols = tot_cols
- do i=0,10
- alpha = .05_r8*i
- max_ncols = 0
-!
- iend = 0
- ncol_curtot = 0
- ncol_curgoal = 0
- do procid=0,dyn_npes/2-1
- if (mirror) then
- procids = 2*procid
- else
- procids = procid
- endif
- procids_s = dyn_npes_stride*procids
- ncol_curgoal = ncol_curgoal + nx_p(procids_s)
- ncol = 0
-!
- done = .false.
-!
-! Add latitudes until near column per process goal for current process
-!
- do while ((.not. done) .and. &
- (ncol_curtot < ncol_curgoal))
- if (iend .ge. plat/2) then
- write(iulog,*)'SPMDINIT_DYN: error in assigning latitudes to processes'
- call endrun
- endif
- if (ncol_curtot + plon .le. &
- ncol_curgoal + alpha*plon) then
- iend = iend + 1
- ncol = ncol + plon
- ncol_curtot = ncol_curtot + plon
- else
- done = .true.
- endif
- enddo
- if (ncol > max_ncols) max_ncols = ncol
-!
- enddo
- if (max_ncols < min_max_ncols) then
- min_max_ncols = max_ncols
- opt_alpha = alpha
- endif
- enddo
-!
-! Determine latitude assignments when equidistributing columns
-!
- iend = 0
- ncol_curtot = 0
- ncol_curgoal = 0
- do procid=0,dyn_npes/2-1
- if (mirror) then
- procids = 2*procid
- procidn = procids + 1
- else
- procids = procid
- procidn = dyn_npes - procids - 1
- endif
-!
- procids_s = dyn_npes_stride*procids
- procidn_s = dyn_npes_stride*procidn
-!
- ncol_curgoal = ncol_curgoal + nx_p(procids_s)
- ncol_p(procids_s) = 0
-!
- cut(1,procids_s) = iend + 1
- cut(2,procids_s) = iend
- done = .false.
-!
-! Add latitudes until near column per process goal for current process
-!
- do while ((.not. done) .and. &
- (ncol_curtot < ncol_curgoal))
- if (ncol_curtot + plon .le. &
- ncol_curgoal + opt_alpha*plon) then
- iend = iend + 1
- cut(2,procids_s) = iend
- ncol_p(procids_s) = ncol_p(procids_s) + plon
- ncol_curtot = ncol_curtot + plon
- nlat_p(procids_s) = nlat_p(procids_s) + 1
- else
- done = .true.
- endif
- enddo
-!
-! Assign mirror latitudes
-!
- cut(1,procidn_s) = plat - cut(2,procids_s) + 1
- cut(2,procidn_s) = plat - cut(1,procids_s) + 1
- ncol_p(procidn_s) = ncol_p(procids_s)
- nlat_p(procidn_s) = nlat_p(procids_s)
-!
-! Save local information
-!
- if (iam == procids_s .or. iam == procidn_s) then
- beglat = cut(1,iam)
- endlat = cut(2,iam)
- numlats = nlat_p(iam)
- begirow = cut(1,procids_s)
- endirow = cut(2,procids_s)
- end if
-!
- enddo
-!
- else
-!
-! Determine latitude assignments when
-! equidistributing latitudes
-!
- iend = 0
- do procid=0,dyn_npes/2-1
- if (mirror) then
- procids = 2*procid
- procidn = procids + 1
- else
- procids = procid
- procidn = dyn_npes - procids - 1
- endif
-!
- procids_s = dyn_npes_stride*procids
- procidn_s = dyn_npes_stride*procidn
-!
- nlat_p(procids_s) = nx_p(procids_s)
- cut(1,procids_s) = iend + 1
- cut(2,procids_s) = iend + nlat_p(procids_s)
- iend = iend + nlat_p(procids_s)
-!
- ncol_p(procids_s) = 0
- do lat=cut(1,procids_s),cut(2,procids_s)
- ncol_p(procids_s) = ncol_p(procids_s) + plon
- enddo
-!
-! Assign mirror latitudes
-!
- nlat_p(procidn_s) = nx_p(procidn_s)
- cut(1,procidn_s) = plat - cut(2,procids_s) + 1
- cut(2,procidn_s) = plat - cut(1,procids_s) + 1
-!
- ncol_p(procidn_s) = 0
- do lat=cut(1,procidn_s),cut(2,procidn_s)
- ncol_p(procidn_s) = ncol_p(procidn_s) + plon
- enddo
-!
-! Save local information
-!
- if (iam == procids_s .or. iam == procidn_s) then
- beglat = cut(1,iam)
- endlat = cut(2,iam)
- numlats = nlat_p(iam)
- begirow = cut(1,procids_s)
- endirow = cut(2,procids_s)
- end if
-!
- enddo
- endif
-!
- endif
-!
-! Calculate maximum number of latitudes and columns assigned to a process
-!
- maxlats = maxval(nlat_p)
- maxcols = maxval(ncol_p)
-!
- do procid=0,dyn_npes-1
- procid_s = dyn_npes_stride*procid
- if (masterproc) then
- write(iulog,*)'procid ',procid_s,' assigned ', &
- cut(2,procid_s)-cut(1,procid_s)+1,' latitude values from', &
- cut(1,procid_s),' through ',cut(2,procid_s),' containing', &
- ncol_p(procid_s),' vertical columns'
- end if
-!
-! Determine which process is responsible for the defined latitudes
-!
- do lat=cut(1,procid_s),cut(2,procid_s)
- proc(lat) = procid_s
- end do
-!
-! The extended regions are simply "numbnd" wider at each
-! side. The extended region do not go beyond 1 and plat, though
-!
- cutex(1,procid_s) = cut(1,procid_s) - numbnd
- cutex(2,procid_s) = cut(2,procid_s) + numbnd
- if (iam == procid_s) then
- beglatex = cutex(1,procid_s) + numbnd
- endlatex = cutex(2,procid_s) + numbnd
- numlatsex = endlatex - beglatex + 1
- end if
- end do
-!
-! Determine neighbor processes needed for boundary communication.
-! North first.
-!
- neighn = 0
- neighn_minlat(:) = -1
- do procid=0,dyn_npes-1
- procid_s = dyn_npes_stride*procid
- if (procid_s /= iam) then
- if ((cut(1,procid_s) > cut(2,iam)) .and. &
- (cut(1,procid_s) <= cut(2,iam)+numbnd)) then
- neighn_minlat(cut(1,procid_s)) = procid_s
- neighn = neighn + 1
- endif
- endif
- enddo
-!
-! Sort north processes by increasing latitude
-!
- allocate (neighn_proc (neighn))
- neighn = 0
- do lat=1,plat
- if (neighn_minlat(lat) /= -1) then
- neighn = neighn + 1
- neighn_proc(neighn) = neighn_minlat(lat)
- endif
- enddo
-!
-! South next.
-!
- neighs = 0
- neighs_maxlat(:) = -1
- do procid=0,dyn_npes-1
- procid_s = dyn_npes_stride*procid
- if (procid_s /= iam) then
- if ((cut(2,procid_s) < cut(1,iam)) .and. &
- (cut(2,procid_s) >= cut(1,iam)-numbnd)) then
- neighs_maxlat(cut(2,procid_s)) = procid_s
- neighs = neighs + 1
- endif
- endif
- enddo
-!
-! Sort south processes by decreasing latitude
-!
- allocate (neighs_proc (neighs))
- neighs = 0
- do lat=plat,1,-1
- if (neighs_maxlat(lat) /= -1) then
- neighs = neighs + 1
- neighs_proc(neighs) = neighs_maxlat(lat)
- endif
- enddo
-!
- if (masterproc) then
- write(iulog,*)'-----------------------------------------'
- write(iulog,*)'Number of lats passed north & south = ',numbnd
- write(iulog,*)'Node Partition Extended Partition'
- write(iulog,*)'-----------------------------------------'
- do procid=0,dyn_npes-1
- procid_s = dyn_npes_stride*procid
- write(iulog,200) procid_s,cut(1,procid_s),cut(2,procid_s) ,cutex(1,procid_s), &
- cutex(2,procid_s)
-200 format(i3,4x,i3,'-',i3,7x,i3,'-',i3)
- end do
- end if
-! write(iulog,*)'iam=',iam,'Number of south neighbors needed for bndry exchange = ',neighs
-! write(iulog,*)'iam=',iam,'Number of north neighbors needed for bndry exchange = ',neighn
-
- call decomp_wavenumbers ()
-!
-! Make communicator for active dynamics processors (for use in realloc4a/4b)
- if (beglat <= endlat) then
- active_proc = 1
- else
- active_proc = 0
- endif
- call mpi_comm_split(mpicom, active_proc, iam, mpicom_dyn_active, ierror)
-!
-! Precompute swap partners and number of steps in realloc4 alltoall algorithm.
-! First, determine number of swaps.
-!
- realloc4_steps = 0
- do procj=1,ceil2(npes)-1
- procid = pair(npes,procj,iam)
- if (procid >= 0) then
- if (((numm(iam) > 0) .and. (nlat_p(procid) > 0)) .or. &
- ((numm(procid) > 0) .and. (numlats > 0))) then
- realloc4_steps = realloc4_steps + 1
- end if
- end if
- end do
-!
-! Second, determine swap partners.
-!
- allocate( realloc4_proc(realloc4_steps) )
- allocate( realloc4_step(0:npes-1) )
- realloc4_step(:) = -1
- realloc4_steps = 0
- do procj=1,ceil2(npes)-1
- procid = pair(npes,procj,iam)
- if (procid >= 0) then
- if (((numm(iam) > 0) .and. (nlat_p(procid) > 0)) .or. &
- ((numm(procid) > 0) .and. (numlats > 0))) then
- realloc4_steps = realloc4_steps + 1
- realloc4_proc(realloc4_steps) = procid
- realloc4_step(procid) = realloc4_steps
- end if
- end if
- end do
-!
-! Precompute swap partners in realloc5/7 allgather algorithm.
- allocate( allgather_proc(npes-1) )
- allocate( allgather_step(0:npes-1) )
- allgather_step(:) = -1
- allgather_steps = 0
- do procj=1,ceil2(npes)-1
- procid = pair(npes,procj,iam)
- if (procid >= 0) then
- allgather_steps = allgather_steps + 1
- allgather_proc(allgather_steps) = procid
- allgather_step(procid) = allgather_steps
- end if
- end do
-!
- return
- end subroutine spmdinit_dyn
-
-!========================================================================
-
- subroutine factor (nitems, m2, m3, m5)
-!-----------------------------------------------------------------------
-!
-! Purpose: Factor a given number into powers of 2,3,5
-!
-! Method: Brute force application of "mod" function
-!
-! Author: CCM Core Group
-!
-!-----------------------------------------------------------------------
-!
-! Arguments
-!
- integer, intent(in) :: nitems ! Number to be factored into powers of 2,3,5
- integer, intent(out) :: m2,m3,m5 ! Powers of 2, 3, and 5 respectively
-!
-! Local workspace
-!
- integer num ! current number to be factored
-!
-!-----------------------------------------------------------------------
-!
- num = nitems
- m2 = 0
- m3 = 0
- m5 = 0
-
-2 if (mod(num,2) == 0) then
- m2 = m2 + 1
- num = num/2
- goto 2
- end if
-
-3 if (mod(num,3) == 0) then
- m3 = m3 + 1
- num = num/3
- goto 3
- end if
-
-5 if (mod(num,5) == 0) then
- m5 = m5 + 1
- num = num/5
- goto 5
- end if
-
- if (num /= 1) then
- write(iulog,*) 'FACTOR: ',nitems,' has a prime factor other than 2, 3, or 5. Aborting...'
- call endrun
- end if
-
- return
- end subroutine factor
-
-!========================================================================
-
- subroutine decomp_wavenumbers
-!-----------------------------------------------------------------------
-!
-! Purpose: partition the spectral work among the given number of processes
-!
-! Method: Approximately equidistribute both the number of spectral
-! coefficients and the number of wavenumbers assigned to each
-! MPI task using a modified version of the mapping due to
-! Barros and Kauranne.
-!
-! Author: P. Worley, September 2002
-!
-!-----------------------------------------------------------------------
- use pspect, only: pmmax
- use comspe, only: numm, maxm, locm, locrm, nlen, lpspt, lnstart
-!
-! Local workspace
-!
- integer procid ! process id
- integer procid_s ! strided process id
- integer m, lm ! global and local fourier wavenumber indices
- integer mstride ! Stride over wavenumbers used in decomposition
- integer begm1 ! Starting Fourier wavenumbers owned by an MPI task
- integer begm2 ! when using Barros & Kauranne decomposition
- integer speccount(0:npes-1)
- ! number of spectral coefficients assigned to
- ! each MPI task
-!-----------------------------------------------------------------------
-!
-! determine upper bound on number of wavenumbers to be assigned to each
-! process
- if (mod(pmmax,dyn_npes) .eq. 0) then
- maxm = pmmax/dyn_npes
- else
- maxm = (pmmax/dyn_npes) + 1
- endif
- allocate ( numm(0:npes-1) )
- allocate ( locm(1:maxm, 0:npes-1) )
- allocate ( locrm(1:2*maxm, 0:npes-1) )
-!
-! assign wavenumbers to approximately equidistribute the number
-! of spectral coefficients assigned to each process
- numm(:) = 0
- locm(:,:) = huge(1)
- locrm(:,:) = huge(1)
- speccount(:) = 0
- mstride = 2*dyn_npes
- npessp = 0
- do procid = 0,dyn_npes-1
- procid_s = dyn_npes_stride*procid
- begm1 = procid + 1
- begm2 = mstride - procid
- do m=begm1,pmmax,mstride
- numm(procid_s) = numm(procid_s) + 1
- locm(numm(procid_s),procid_s) = m
- speccount(procid_s) = speccount(procid_s) + nlen(m)
- enddo
- do m=begm2,pmmax,mstride
- numm(procid_s) = numm(procid_s) + 1
- locm(numm(procid_s),procid_s) = m
- speccount(procid_s) = speccount(procid_s) + nlen(m)
- enddo
-!
- if (numm(procid_s) .gt. 0) then
- npessp = npessp + 1
- endif
-!
- enddo
-!
- do procid = 0,dyn_npes-1
- procid_s = dyn_npes_stride*procid
- if (masterproc) then
- write(iulog,*)'procid ',procid_s,' assigned ', speccount(procid_s), &
- ' spectral coefficients and ', numm(procid_s), &
- ' m values: ', (locm(lm,procid_s),lm=1,numm(procid_s))
- end if
- do lm=1,numm(procid_s)
- locrm(2*lm-1,procid_s) = 2*locm(lm,procid_s)-1
- locrm(2*lm ,procid_s) = 2*locm(lm,procid_s)
- enddo
- enddo
-!
-! Calculate number of local spectral coefficients
- lpspt = 0
- do lm=1,numm(iam)
- lpspt = lpspt + nlen(locm(lm,iam))
- enddo
-!
-! Evaluate displacement info based on truncation params and
-! wavenumber assignment
- allocate ( lnstart(1:maxm) )
- lnstart(1) = 0
- do lm=2,numm(iam)
- lnstart(lm) = lnstart(lm-1) + nlen(locm(lm-1,iam))
- enddo
-!
- return
- end subroutine decomp_wavenumbers
-
-!========================================================================
-
- subroutine spmdbuf
-!-----------------------------------------------------------------------
-!
-! Purpose: allocate spmd pack buffers used in collective communications
-!
-! Author: CCM Core Group
-!
-! Note: Call after phys_grid_init
-!
-!-----------------------------------------------------------------------
- use error_messages, only: alloc_err
- use comspe, only: maxm
- use constituents, only: pcnst
-!-----------------------------------------------------------------------
-!
-! Local workspace
-!
- integer :: maxcount(5),m
- integer :: length,i,lm,istat1,istat2
- integer :: bsiz, glb_bsiz ! buffer size (in bytes)
-!
-! realloc4a max: 8 2 plev*numm*numlats (e.g. tdyn)
-! 1 2 *numm*numlats (bpstr)
-!
- maxcount(1) = (npes-1)*maxlats*(2*maxm*(plev*8 + 1))
-!
-! realloc4b max: 8 2 plev*numm*numlats (e.g. vort)
-! 4 2 *numm*numlats (e.g. dps)
-!
- maxcount(2) = (npes-1)*maxlats*(2*maxm*(plev*8 + 4))
-!
-! realloc5 max: 6 numlats (e.g. tmass)
-! 5 numlats *pcnst (e.g. hw1lat)
-! 2 4*numlats*pcnst (e.g. hw2al)
-!
- maxcount(3) = npes*maxlats*(6 + (5 + 2*4)*pcnst)
-!
-! realloc7 max: 3 plev *numlats (e.g. vmax2d)
-! 5 *numlats (e.g. psurf)
-!
- maxcount(4) = npes*maxlats*(3*plev + 5)
-!
-! dp_coupling max:
-!
- if (.not. local_dp_map) then
- maxcount(5) = (5 + pcnst)*max(block_buf_nrecs,chunk_buf_nrecs)
- else
- maxcount(5) = 0
- endif
-!
- m = maxval(maxcount)
- call mpipack_size (m, mpir8, mpicom, bsiz)
- call mpiallmaxint(bsiz, glb_bsiz, 1, mpicom)
- if (masterproc) then
- write(iulog,*) 'SPMDBUF: Allocating SPMD buffers of size ',glb_bsiz
- endif
- spmdbuf_siz = glb_bsiz/8 + 1
-#if (defined CAF)
- allocate(buf1(spmdbuf_siz)[*], stat=istat1)
- allocate(buf2(spmdbuf_siz)[*], stat=istat2)
-#else
- allocate(buf1(spmdbuf_siz), stat=istat1)
- allocate(buf2(spmdbuf_siz), stat=istat2)
-#endif
- call alloc_err( istat1, 'spmdbuf', 'buf1', spmdbuf_siz )
- call alloc_err( istat2, 'spmdbuf', 'buf2', spmdbuf_siz )
- call mpiwincreate(buf1,spmdbuf_siz*8,mpicom,buf1win)
- call mpiwincreate(buf2,spmdbuf_siz*8,mpicom,buf2win)
- buf1 = 0.0_r8
- buf2 = 0.0_r8
- return
- end subroutine spmdbuf
-
-!========================================================================
-
- subroutine compute_gsfactors (numperlat, numtot, numperproc, displs)
-!-----------------------------------------------------------------------
-!
-! Purpose: Compute arguments for gatherv, scatterv
-!
-! Author: CCM Core Group
-!
-!-----------------------------------------------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: numperlat ! number of elements per latitude
-!
-! Output arguments
-!
- integer, intent(out) :: numtot ! total number of elements (to send or recv)
- integer, intent(out) :: numperproc(0:npes-1) ! per-PE number of items to receive
- integer, intent(out) :: displs(0:npes-1) ! per-PE displacements
-!
-! Local variables
-!
- integer :: p ! index
-
- numtot = numperlat*numlats
-
- do p=0,npes-1
- numperproc(p) = numperlat*nlat_p(p)
- end do
-
- displs(0) = 0
- do p=1,npes-1
- displs(p) = numperlat*(cut(1,p)-1)
- end do
-
- end subroutine compute_gsfactors
-
-#endif
-
-end module spmd_dyn
diff --git a/src/dynamics/eul/stats.F90 b/src/dynamics/eul/stats.F90
deleted file mode 100644
index 72df933fc9..0000000000
--- a/src/dynamics/eul/stats.F90
+++ /dev/null
@@ -1,110 +0,0 @@
-subroutine stats(lat ,pint ,pdel ,pstar , &
- vort ,div ,t ,q ,nlon )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Accumulation of diagnostic statistics for 1 latitude.
-!
-! Method:
-!
-! Author:
-! Original version: J. Rosinski
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, J. Hack, August 1992
-! Reviewed: D. Williamson, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev, plevp, plat
- use pspect
- use commap
-
- implicit none
-
-#include <comsta.h>
-!
-! Input arguments
-!
- integer, intent(in) :: lat ! latitude index (S->N)
- integer, intent(in) :: nlon
-
- real(r8), intent(in) :: pint(plon,plevp) ! pressure at model interfaces
- real(r8), intent(in) :: pdel(plon,plev) ! pdel(k) = pint(k+1) - pint(k)
- real(r8), intent(in) :: pstar(plon) ! ps + psr (surface pressure)
- real(r8), intent(in) :: vort(plon,plev) ! vorticity
- real(r8), intent(in) :: div(plon,plev) ! divergence
- real(r8), intent(in) :: t(plon,plev) ! temperature
- real(r8), intent(in) :: q(plon,plev) ! moisture
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) prat ! pdel(i,k)/pint(i,plevp)
-
- integer i,k ! longitude, level indices
- integer ifld ! field index
-!
-!-----------------------------------------------------------------------
-!
-! Compute statistics for current latitude line
-!
- psurf(lat) = 0._r8
- do i=1,nlon
- psurf(lat) = psurf(lat) + pstar(i)
- end do
- psurf(lat)= w(lat)*psurf(lat)/nlon
-
-!$OMP PARALLEL DO PRIVATE (IFLD, K, I, PRAT)
- do ifld=1,4
- if (ifld == 1) then
-
- rmsz (lat) = 0._r8
- do k=1,plev
- do i=1,nlon
- prat = pdel(i,k)/pint(i,plevp)
- rmsz(lat) = rmsz(lat) + vort(i,k)*vort(i,k)*prat
- end do
- end do
- rmsz(lat) = w(lat)*rmsz(lat)/nlon
-
- elseif (ifld == 2) then
-
- rmsd (lat) = 0._r8
- do k=1,plev
- do i=1,nlon
- prat = pdel(i,k)/pint(i,plevp)
- rmsd(lat) = rmsd(lat) + div(i,k)*div(i,k)*prat
- end do
- end do
- rmsd(lat) = w(lat)*rmsd(lat)/nlon
-
- elseif (ifld == 3) then
-
- rmst (lat) = 0._r8
- do k=1,plev
- do i=1,nlon
- prat = pdel(i,k)/pint(i,plevp)
- rmst(lat) = rmst(lat) + (t(i,k)**2)*prat
- end do
- end do
- rmst(lat) = w(lat)*rmst(lat)/nlon
-
- else
-
- stq (lat) = 0._r8
- do k=1,plev
- do i=1,nlon
- prat = pdel(i,k)/pint(i,plevp)
- stq(lat) = stq(lat) + q(i,k)*pdel(i,k)
- end do
- end do
- stq (lat) = w(lat)*stq(lat)/nlon
-
- endif
- enddo
-!
- return
-end subroutine stats
diff --git a/src/dynamics/eul/stepon.F90 b/src/dynamics/eul/stepon.F90
deleted file mode 100644
index 4c86f1d27e..0000000000
--- a/src/dynamics/eul/stepon.F90
+++ /dev/null
@@ -1,425 +0,0 @@
-module stepon
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Module for time-stepping of the CAM Eulerian Spectral dynamics.
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use shr_sys_mod, only: shr_sys_flush
- use pmgrid, only: plev, plat, plevp, plon, beglat, endlat
- use spmd_utils, only: masterproc
- use scanslt, only: advection_state
- use prognostics, only: ps, u3, v3, t3, q3, qminus, div, &
- dpsl, dpsm, omga, phis, n3, n3m2, n3m1
- use camsrfexch, only: cam_out_t
- use ppgrid, only: begchunk, endchunk
- use physics_types, only: physics_state, physics_tend
- use time_manager, only: is_first_step, get_step_size
- use scamMod, only: use_iop,doiopupdate,use_pert_frc,wfld,wfldh,single_column,setiopupdate, readiopdata
- use perf_mod
-
- use aerosol_properties_mod, only: aerosol_properties
- use aerosol_state_mod, only: aerosol_state
- use microp_aero, only: aerosol_state_object, aerosol_properties_object
-
- implicit none
- private
- save
-
- public stepon_init ! Initialization
- public stepon_run1 ! Run method phase 1
- public stepon_run2 ! Run method phase 2
- public stepon_run3 ! Run method phase 3
- public stepon_final ! Finalization
-!
-! Private module data
-!
- type(physics_state), pointer :: phys_state(:) ! Physics state data
- type(physics_tend ), pointer :: phys_tend(:) ! Physics tendency data
-
- real(r8) :: detam(plev) ! intervals between vert full levs.
- real(r8) :: cwava(plat) ! weight applied to global integrals
- real(r8), allocatable :: t2(:,:,:) ! temp tendency
- real(r8), allocatable :: fu(:,:,:) ! u wind tendency
- real(r8), allocatable :: fv(:,:,:) ! v wind tendency
- real(r8), allocatable :: flx_net(:,:) ! net flux from physics
- real(r8), allocatable :: fq(:,:,:,:) ! Q tendencies,for eul_nsplit>1
- real(r8), allocatable :: t2_save(:,:,:) ! temp tendency
- real(r8), allocatable :: fu_save(:,:,:) ! u wind tendency
- real(r8), allocatable :: fv_save(:,:,:) ! v wind tendency
- real(r8) :: coslat(plon) ! cosine of latitude
- real(r8) :: rcoslat(plon) ! Inverse of coseine of latitude
- real(r8) :: rpmid(plon,plev) ! inverse of midpoint pressure
- real(r8) :: pdel(plon,plev) ! Pressure depth of layer
- real(r8) :: pint(plon,plevp) ! Pressure at interfaces
- real(r8) :: pmid(plon,plev) ! Pressure at midpoint
- type(advection_state) :: adv_state ! Advection state data
-
- real(r8) :: etamid(plev) ! vertical coords at midpoints or pmid if single_column
-
- class(aerosol_properties), pointer :: aero_props_obj => null()
- logical :: aerosols_transported = .false.
-
-!=======================================================================
-contains
-!=======================================================================
-
-subroutine stepon_init(dyn_in, dyn_out)
-!-----------------------------------------------------------------------
-!
-! Purpose: Initialization, primarily of dynamics.
-!
-!-----------------------------------------------------------------------
- use dyn_comp, only: dyn_import_t, dyn_export_t
- use scanslt, only: scanslt_initial
- use commap, only: clat
- use cam_history, only: write_camiop
- use constituents, only: pcnst
- use physconst, only: gravit
- use eul_control_mod,only: eul_nsplit
- use iop, only:init_iop_fields
-!-----------------------------------------------------------------------
-! Arguments
-!
- type(dyn_import_t) :: dyn_in ! included for compatibility
- type(dyn_export_t) :: dyn_out ! included for compatibility
-!-----------------------------------------------------------------------
-! Local variables
-!
- integer :: k, lat, i
- !-----------------------------------------------------------------------
-
- call t_startf ('stepon_startup')
-
- call scanslt_initial(adv_state, etamid, gravit, detam, cwava)
- !
- ! Initial guess for trajectory midpoints in spherical coords.
- ! nstep = 0: use arrival points as initial guess for trajectory midpoints.
- ! nstep > 0: use calculated trajectory midpoints from previous time
- ! step as first guess.
- ! NOTE: reduce number of iters necessary for convergence after nstep = 1.
- !
- if (is_first_step()) then
- do lat=beglat,endlat
- if (.not. single_column) then
- do i=1,plon
- coslat(i) = cos(clat(lat))
- rcoslat(i) = 1._r8/coslat(i)
- end do
- endif
- !
- ! Set current time pressure arrays for model levels etc.
- !
- call plevs0(plon, plon, plev, ps(1,lat,n3), pint, pmid, pdel)
- !
- do k=1,plev
- do i=1,plon
- rpmid(i,k) = 1._r8/pmid(i,k)
- end do
- end do
-
- if (.not. single_column) then
- !
- ! Calculate vertical motion field
- !
- call omcalc (rcoslat, div(1,1,lat,n3), u3(1,1,lat,n3), v3(1,1,lat,n3), dpsl(1,lat), &
- dpsm(1,lat), pmid, pdel, rpmid ,pint(1,plevp), &
- omga(1,1,lat), plon)
- else
-
- omga(1,:,lat)=wfld(:)
- endif
- end do
- end if
-
- allocate(t2(plon,plev,beglat:endlat))
- allocate(fu(plon,plev,beglat:endlat))
- allocate(fv(plon,plev,beglat:endlat))
- allocate( flx_net(plon,beglat:endlat))
- if (eul_nsplit>1) then
- allocate(fq(plon,plev,pcnst,beglat:endlat))
- allocate(t2_save(plon,plev,beglat:endlat))
- allocate(fu_save(plon,plev,beglat:endlat))
- allocate(fv_save(plon,plev,beglat:endlat))
- endif
- !
- ! Beginning of basic time step loop
- !
- call t_stopf ('stepon_startup')
-
-
- if (is_first_step() .and. write_camiop) then
- call init_iop_fields()
- endif
-
- ! get aerosol properties
- aero_props_obj => aerosol_properties_object()
-
- if (associated(aero_props_obj)) then
- ! determine if there are transported aerosol contistuents
- aerosols_transported = aero_props_obj%number_transported()>0
- end if
-
-end subroutine stepon_init
-
-!
-!=======================================================================
-!
-
-subroutine stepon_run1( ztodt, phys_state, phys_tend , pbuf2d, dyn_in, dyn_out)
-!-----------------------------------------------------------------------
-!
-! Purpose: Phase 1 run method of dynamics. Set the time-step
-! to use for physics. And couple from dynamics to physics.
-!
-!-----------------------------------------------------------------------
- use dyn_comp, only: dyn_import_t, dyn_export_t
- use time_manager, only: get_nstep
- use prognostics, only: pdeld
-
- use dp_coupling, only: d_p_coupling
- use eul_control_mod,only: eul_nsplit
- use physics_buffer, only : physics_buffer_desc
- real(r8), intent(out) :: ztodt ! twice time step unless nstep=0
- type(physics_state), intent(inout) :: phys_state(begchunk:endchunk)
- type(physics_tend), intent(inout) :: phys_tend(begchunk:endchunk)
- type(physics_buffer_desc), pointer :: pbuf2d(:,:)
- type(dyn_import_t) :: dyn_in ! included for compatibility
- type(dyn_export_t) :: dyn_out ! included for compatibility
-
- real(r8) :: dtime ! timestep size
-
- integer :: c
- class(aerosol_state), pointer :: aero_state_obj
- nullify(aero_state_obj)
-
- !-----------------------------------------------------------------------
-
- dtime = get_step_size()
-
- ztodt = 2.0_r8*dtime
-
- ! If initial time step adjust dt
- if (is_first_step()) ztodt = dtime
-
- ! subcycling case, physics dt is always dtime
- if (eul_nsplit>1) ztodt = dtime
-
- ! Dump state variables to IC file
- call t_startf ('diag_dynvar_ic')
- call diag_dynvar_ic (phis, ps(:,beglat:endlat,n3m1), t3(:,:,beglat:endlat,n3m1), u3(:,:,beglat:endlat,n3m1), &
- v3(:,:,beglat:endlat,n3m1), q3(:,:,:,beglat:endlat,n3m1) )
- call t_stopf ('diag_dynvar_ic')
- !
- !----------------------------------------------------------
- ! Couple from dynamics to physics
- !----------------------------------------------------------
- !
- call t_startf ('d_p_coupling')
- call d_p_coupling (ps(:,beglat:endlat,n3m2), t3(:,:,beglat:endlat,n3m2), u3(:,:,beglat:endlat,n3m2), &
- v3(:,:,beglat:endlat,n3m2), q3(:,:,:,beglat:endlat,n3m2), &
- omga, phis, phys_state, phys_tend, pbuf2d, pdeld(:,:,:,n3m2))
- call t_stopf ('d_p_coupling')
-
- !----------------------------------------------------------
- ! update aerosol state object from CAM physics state constituents
- !----------------------------------------------------------
- if (aerosols_transported) then
-
- do c = begchunk,endchunk
- aero_state_obj => aerosol_state_object(c)
- ! pass number mass or number mixing ratios of aerosol constituents
- ! to aerosol state object
- call aero_state_obj%set_transported(phys_state(c)%q)
- end do
-
- end if
-
-end subroutine stepon_run1
-
-!
-!=======================================================================
-!
-
-subroutine stepon_run2( phys_state, phys_tend, dyn_in, dyn_out )
-!-----------------------------------------------------------------------
-!
-! Purpose: Phase 2 run method of dynamics. Couple from physics
-! to dynamics.
-!
-!-----------------------------------------------------------------------
- use dyn_comp, only: dyn_import_t, dyn_export_t
- use dp_coupling, only: p_d_coupling
- type(physics_state), intent(inout):: phys_state(begchunk:endchunk)
- type(physics_tend), intent(in):: phys_tend(begchunk:endchunk)
- type(dyn_import_t) :: dyn_in ! included for compatibility
- type(dyn_export_t) :: dyn_out ! included for compatibility
-
- integer :: c
- class(aerosol_state), pointer :: aero_state_obj
-
- !----------------------------------------------------------
- ! update physics state with aerosol constituents
- !----------------------------------------------------------
- nullify(aero_state_obj)
-
- if (aerosols_transported) then
- do c = begchunk,endchunk
- aero_state_obj => aerosol_state_object(c)
- ! get mass or number mixing ratios of aerosol constituents
- call aero_state_obj%get_transported(phys_state(c)%q)
- end do
- end if
-
- call t_startf ('p_d_coupling')
- call p_d_coupling (phys_state, phys_tend, t2, fu, fv, flx_net, &
- qminus )
- call t_stopf ('p_d_coupling')
-end subroutine stepon_run2
-
-!
-!=======================================================================
-!
-
-subroutine stepon_run3( ztodt, cam_out, phys_state, dyn_in, dyn_out )
-!-----------------------------------------------------------------------
-!
-! Purpose: Final phase of dynamics run method. Run the actual dynamics.
-!
-!-----------------------------------------------------------------------
- use dyn_comp, only: dyn_import_t, dyn_export_t
- use eul_control_mod,only: eul_nsplit
- use prognostics, only: ps
- use iop, only: iop_update_prognostics
- use hycoef, only: hyam, hybm, hyai, hybi, ps0
-
- real(r8), intent(in) :: ztodt ! twice time step unless nstep=0
- type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk)
- type(physics_state), intent(in):: phys_state(begchunk:endchunk)
- type(dyn_import_t) :: dyn_in ! included for compatibility
- type(dyn_export_t) :: dyn_out ! included for compatibility
- real(r8) :: dt_dyn0,dt_dyn
- integer :: stage
- if (single_column) then
-
- ! Determine whether it is time for an IOP update;
- ! doiopupdate set to true if model time step > next available IOP
- if (use_iop) then
- call setiopupdate
- end if
-
- ! Read IOP data and update prognostics if needed
-
- if (doiopupdate) then
- call readiopdata(hyam, hybm, hyai, hybi, ps0)
- call iop_update_prognostics(n3,ps=ps)
- end if
- endif
-
- !----------------------------------------------------------
- ! DYNPKG Call the Dynamics Package
- !----------------------------------------------------------
- call t_startf ('dynpkg')
-
- if (eul_nsplit==1) then
- call dynpkg(adv_state, t2 ,fu ,fv ,etamid , &
- cwava ,detam ,flx_net ,ztodt)
- else
- dt_dyn0 = ztodt/eul_nsplit
- dt_dyn = dt_dyn0
- if (is_first_step()) dt_dyn = 2*dt_dyn0
-
- ! convert q adjustment to a tendency
- fq = (qminus(:,:,:,:) - q3(:,:,:,:,n3m2))/ztodt
- ! save a copy of t2,fu,fv
- t2_save=t2
- fu_save=fu
- fv_save=fv
-
- call apply_fq(qminus,q3(:,:,:,:,n3m2),fq,dt_dyn0)
- call dynpkg(adv_state, t2 ,fu ,fv ,etamid , &
- cwava ,detam ,flx_net ,dt_dyn0)
-
- do stage=2,eul_nsplit
- t2=t2_save
- fu=fu_save
- fv=fv_save
- call apply_fq(qminus,q3(:,:,:,:,n3m2),fq,dt_dyn)
- call dynpkg(adv_state, t2 ,fu ,fv ,etamid , &
- cwava ,detam ,flx_net ,dt_dyn)
- enddo
- endif
-
- call t_stopf ('dynpkg')
-end subroutine stepon_run3
-
-
-
-subroutine apply_fq(qminus,q3,fq,dt)
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plat, plev, plevp, beglat, endlat
- use constituents, only: pcnst
-
- real(r8), intent(in) :: q3(plon,plev,beglat:endlat,pcnst)
- real(r8), intent(in) :: fq(plon,plev,beglat:endlat,pcnst)
- real(r8), intent(out) :: qminus(plon,plev,beglat:endlat,pcnst)
- real(r8), intent(in) :: dt
-
- !local
- real(r8) :: q_tmp,fq_tmp
- integer :: q,c,k,i
-
- do q=1,pcnst
- do c=beglat,endlat
- do k=1,plev
- do i=1,plon
- fq_tmp = dt*fq(i,k,c,q)
- q_tmp = q3(i,k,c,q)
- ! if forcing is > 0, do nothing (it makes q less negative)
- if (fq_tmp<0 .and. q_tmp+fq_tmp<0 ) then
- ! reduce magnitude of forcing so it wont drive q negative
- ! but we only reduce the magnitude of the forcing, dont increase
- ! its magnitude or change the sign
-
- ! if q<=0, then this will set fq=0 (q already negative)
- ! if q>0, then we know from above that fq < -q < 0, so we
- ! can reduce the magnitive of fq by setting fq = -q:
- fq_tmp = min(-q_tmp,0._r8)
- endif
- qminus(i,k,c,q) = q_tmp + fq_tmp
- enddo
- enddo
- enddo
- enddo
-
-end subroutine
-
-
-!
-!=======================================================================
-!
-
-subroutine stepon_final(dyn_in, dyn_out)
-!-----------------------------------------------------------------------
-!
-! Purpose: Stepon finalization.
-!
-!-----------------------------------------------------------------------
- use dyn_comp, only: dyn_import_t, dyn_export_t
- use scanslt, only: scanslt_final
- type(dyn_import_t) :: dyn_in ! included for compatibility
- type(dyn_export_t) :: dyn_out ! included for compatibility
-
- call scanslt_final( adv_state )
- deallocate(t2)
- deallocate(fu)
- deallocate(fv)
- deallocate(flx_net)
-
-end subroutine stepon_final
-!
-!=======================================================================
-!
-
-end module stepon
diff --git a/src/dynamics/eul/tfilt_massfix.F90 b/src/dynamics/eul/tfilt_massfix.F90
deleted file mode 100644
index 0a43280a09..0000000000
--- a/src/dynamics/eul/tfilt_massfix.F90
+++ /dev/null
@@ -1,484 +0,0 @@
-module tfilt_massfix
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Time filter (second half of filter for vorticity and divergence only)
-!
-!-----------------------------------------------------------------------
- implicit none
- private
- save
-
- public tfilt_massfixrun
-!
-! Private module data
-!
-
-!=======================================================================
-contains
-!=======================================================================
-
-subroutine tfilt_massfixrun (ztodt, lat, u3m1, u3, &
- v3m1, v3, t3m1, t3, q3m1, &
- q3, psm1, ps, alpha, &
- etamid, qfcst, vort, div, vortm2, &
- divm2, qminus, psm2, um2, &
- vm2, tm2, qm2, vortm1, divm1, &
- omga, dpsl, dpsm, beta, hadv , &
- nlon, pdeldry, pdelm1dry, pdelm2dry)
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Time filter (second half of filter for vorticity and divergence only)
-!
-! Method:
-!
-! Author:
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use cam_control_mod, only: ideal_phys, tj2016_phys
- use cam_history, only: outfld, write_camiop
- use eul_control_mod, only: fixmas,eps
- use pmgrid, only: plon, plev, plevp, plat
- use commap, only: clat
- use constituents, only: pcnst, qmin, cnst_cam_outfld, &
- tottnam, tendnam, cnst_get_type_byind, fixcnam, &
- hadvnam, vadvnam
- use time_manager, only: get_nstep
- use physconst, only: cpair, gravit
- use scamMod, only: single_column, dqfxcam
- use phys_control, only: phys_getopts
- use qneg_module, only: qneg3
-
- use iop
- use constituents, only: cnst_get_ind, cnst_name
-
- implicit none
-
-!
-! Input arguments
-!
- real(r8), intent(in) :: ztodt ! two delta t (unless nstep<2)
-
- real(r8), intent(inout) :: qfcst(plon,plev,pcnst)! slt moisture forecast
- real(r8), intent(in) :: vort(plon,plev)
- real(r8), intent(in) :: div(plon,plev)
- real(r8), intent(inout) :: vortm2(plon,plev)
- real(r8), intent(inout) :: divm2(plon,plev)
- real(r8), intent(in) :: qminus(plon,plev,pcnst)
- real(r8), intent(inout) :: psm2(plon)
- real(r8), intent(inout) :: um2(plon,plev)
- real(r8), intent(inout) :: vm2(plon,plev)
- real(r8), intent(inout) :: tm2(plon,plev)
- real(r8), intent(inout) :: qm2(plon,plev,pcnst)
- real(r8), intent(inout) :: omga(plon,plev)
- real(r8), intent(in) :: dpsl(plon)
- real(r8), intent(in) :: dpsm(plon)
- real(r8), intent(in) :: beta ! energy fixer coefficient
- real(r8), intent(in) :: hadv(plon,plev,pcnst) ! horizonal q advection tendency
- real(r8), intent(in) :: alpha(pcnst)
- real(r8), intent(in) :: etamid(plev) ! vertical coords at midpoints
- real(r8), intent(in) :: u3(plon,plev)
- real(r8), intent(in) :: v3(plon,plev)
- real(r8), intent(inout) :: t3(plon,plev)
- real(r8), intent(inout) :: pdeldry(:,:) ! dry pressure difference at time n3
- real(r8), intent(inout) :: pdelm1dry(:,:) ! dry pressure difference at time n3m1
- real(r8), intent(in) :: pdelm2dry(:,:) ! dry pressure difference at time n3m2
-
-
- integer, intent(in) :: lat
- integer, intent(in) :: nlon
-
-! Input/Output arguments
-
- real(r8), intent(inout) :: q3(plon,plev,pcnst)
- real(r8), intent(inout) :: ps(plon)
- real(r8), intent(inout) :: vortm1(plon,plev)
- real(r8), intent(inout) :: psm1(plon)
- real(r8), intent(inout) :: u3m1(plon,plev)
- real(r8), intent(inout) :: v3m1(plon,plev)
- real(r8), intent(inout) :: t3m1(plon,plev)
- real(r8), intent(inout) :: divm1(plon,plev)
- real(r8), intent(inout) :: q3m1(plon,plev,pcnst)
-!
-! Local workspace
-!
- integer ifcnt ! Counter
- integer :: nstep ! current timestep number
- integer :: timefiltstep !
-
- real(r8) tfix (plon) ! T correction
- real(r8) engycorr(plon,plev) ! energy equivalent to T correction
- real(r8) rpmid(plon,plev) ! 1./pmid
- real(r8) pdel(plon,plev) ! pdel(k) = pint (k+1)-pint (k)
- real(r8) pint(plon,plevp) ! pressure at model interfaces (n )
- real(r8) pmid(plon,plev) ! pressure at model levels (time n)
- real(r8) utend(plon,plev) ! du/dt
- real(r8) vtend(plon,plev) ! dv/dt
- real(r8) ttend(plon,plev) ! dT/dt
- real(r8) qtend(plon,plev,pcnst)! dq/dt
- real(r8) pstend(plon) ! d(ps)/dt
- real(r8) vadv (plon,plev,pcnst) ! vertical q advection tendency
- real(r8) pintm1(plon,plevp) ! pressure at model interfaces (n-1)
- real(r8) pmidm1(plon,plev) ! pressure at model levels (time n-1)
- real(r8) pdelm1(plon,plev) ! pdelm1(k) = pintm1(k+1)-pintm1(k)
- real(r8) om2eps
- real(r8) corm
- real(r8) wm
- real(r8) absf
- real(r8) worst
- logical lfixlim ! flag to turn on fixer limiter
-
- real(r8) ta(plon,plev,pcnst) ! total advection of constituents
- real(r8) dqfx3(plon,plev,pcnst)! q tendency due to mass adjustment
- real(r8) coslat ! cosine(latitude)
- real(r8) rcoslat(plon) ! 1./cosine(latitude)
-! real(r8) engt ! Thermal energy integral
-! real(r8) engk ! Kinetic energy integral
-! real(r8) engp ! Potential energy integral
- integer i, k, m,j,ixcldliq,ixcldice,ixnumliq,ixnumice
- real(r8) :: u3forecast(plon,plev)
- real(r8) :: v3forecast(plon,plev)
- real(r8) :: t3forecast(plon,plev),delta_t3(plon,plev)
- real(r8) :: q3forecast(plon,plev,pcnst),delta_q3(plon,plev,pcnst)
- real(r8) fixmas_plon(plon)
- real(r8) beta_plon(plon)
- real(r8) clat_plon(plon)
- real(r8) alpha_plon(plon)
-
-!-----------------------------------------------------------------------
- nstep = get_nstep()
- if (write_camiop) then
- !
- ! Calculate 3d dynamics term
- !
- do k=1,plev
- do i=1,nlon
- divt3dsav(i,k,lat)=(t3(i,k)-tm2(i,k))/ztodt -t2sav(i,k,lat)
- divu3dsav(i,k,lat)=(u3(i,k)-um2(i,k))/ztodt -fusav(i,k,lat)
- divv3dsav(i,k,lat)=(v3(i,k)-vm2(i,k))/ztodt -fvsav(i,k,lat)
- t3forecast(i,k)=tm2(i,k)+ztodt*t2sav(i,k,lat)+ztodt*divt3dsav(i,k,lat)
- u3forecast(i,k)=um2(i,k)+ztodt*fusav(i,k,lat)+ztodt*divu3dsav(i,k,lat)
- v3forecast(i,k)=vm2(i,k)+ztodt*fvsav(i,k,lat)+ztodt*divv3dsav(i,k,lat)
- end do
- end do
- do i=1,nlon
- do m=1,pcnst
- do k=1,plev
- divq3dsav(i,k,m,lat)= (qfcst(i,k,m)-qminus(i,k,m))/ztodt
- q3forecast(i,k,m)=qminus(i,k,m)+divq3dsav(i,k,m,lat)*ztodt
- end do
- end do
- end do
-
-
- q3(:nlon,:,:)=q3forecast(:nlon,:,:)
- t3(:nlon,:)=t3forecast(:nlon,:)
- qfcst(:nlon,:,:)=q3(:nlon,:,:)
-
- !
- ! outflds for iop history tape - to get bit for bit with scam
- ! the n-1 values are put out. After the fields are written out
- ! the current time level of info will be buffered for output next
- ! timestep
- !
- call outfld('t',t3 ,plon ,lat )
- call outfld('q',q3 ,plon ,lat )
- call outfld('Ps',ps ,plon ,lat )
- call outfld('u',u3 ,plon ,lat )
- call outfld('v',v3 ,plon ,lat )
- !
- ! read single values into plon arrays for output to history tape
- ! it would be nice if history tape supported 1 dimensional array variables
- !
- fixmas_plon(:)=fixmas
- beta_plon(:)=beta
- clat_plon(:)=clat(lat)
-
- call outfld('fixmas',fixmas_plon,plon ,lat )
- call outfld('beta',beta_plon ,plon ,lat )
- call outfld('CLAT ',clat_plon ,plon ,lat )
- call outfld('divT3d',divt3dsav(1,1,lat) ,plon ,lat )
- call outfld('divU3d',divu3dsav(1,1,lat) ,plon ,lat )
- call outfld('divV3d',divv3dsav(1,1,lat) ,plon ,lat )
- do m =1,pcnst
- call outfld(trim(cnst_name(m))//'_dten',divq3dsav(1,1,m,lat) ,plon ,lat )
- end do
- end if
-
- coslat = cos(clat(lat))
- do i=1,nlon
- rcoslat(i) = 1._r8/coslat
- enddo
- lfixlim = .true.
-
-
-!
-! Set average dry mass to specified constant preserving horizontal
-! gradients of ln(ps). Proportionality factor was calculated in STEPON
-! for nstep=0 or SCAN2 otherwise from integrals calculated in INIDAT
-! and SCAN2 respectively.
-! Set p*.
-!
- do i=1,nlon
- ps(i) = ps(i)*fixmas
- end do
-!
-! Set current time pressure arrays for model levels etc.
-!
- call plevs0(nlon ,plon ,plev ,ps ,pint ,pmid ,pdel)
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- rpmid(i,k) = 1._r8/pmid(i,k)
- enddo
- enddo
-!
-! Add temperature correction for energy conservation
-!
- if (ideal_phys .or. tj2016_phys) then
- engycorr(:,:) = 0._r8
- else
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- engycorr(i,k) = (cpair/gravit)*beta*pdel(i,k)/ztodt
- t3 (i,k) = t3(i,k) + beta
- end do
- end do
- end if
- do i=1,nlon
- tfix(i) = beta/ztodt
- end do
-!
-! Output Energy correction term
-!
-! using do loop and select in order to enable functional parallelism with OpenMP
-!$OMP PARALLEL DO PRIVATE (I)
- do i=1,2
- select case (i)
- case (1)
- call outfld ('ENGYCORR',engycorr ,plon ,lat )
- case (2)
- call outfld ('TFIX ',tfix ,plon ,lat )
- end select
- end do
-
-!
-! Compute q tendency due to mass adjustment
-! If LFIXLIM = .T., then:
-! Check to see if fixer is exceeding a desired fractional limit of the
-! constituent mixing ratio ("corm"). If so, then limit the fixer to
-! that specified limit.
-!
- do m=1,pcnst
- if (cnst_get_type_byind(m).eq.'dry' ) then
- corm = 1.e36_r8
- else
- corm = 0.1_r8
- end if
-
-!$OMP PARALLEL DO PRIVATE (K, I, IFCNT, WORST, WM, ABSF)
- do k=1,plev
- do i=1,nlon
- if (single_column) then
- dqfx3(i,k,m) = dqfxcam(i,k,m)
- else
- dqfx3(i,k,m) = alpha(m)*etamid(k)*abs(qfcst(i,k,m) - qminus(i,k,m))
- if (write_camiop) then
- dqfx3sav(i,k,m,lat) = dqfx3(i,k,m)
- endif
- endif
- end do
- if (lfixlim) then
- ifcnt = 0
- worst = 0._r8
- wm = 0._r8
- do i = 1,nlon
- absf = abs(dqfx3(i,k,m))
- if (absf.gt.corm) then
- ifcnt = ifcnt + 1
- worst = max(absf,worst)
- wm = wm + absf
- dqfx3(i,k,m) = sign(corm,dqfx3(i,k,m))
- endif
- end do
- if (ifcnt.gt.0) then
- wm = wm/real(ifcnt,r8)
-
-! TBH: Commented out as of CAM CRB meeting on 6/20/03
-! write(iulog,1000) m,corm,ifcnt,k,lat,wm,worst
-
- endif
- endif
- do i=1,nlon
- dqfx3(i,k,m) = qfcst(i,k,m)*dqfx3(i,k,m)/ztodt
- q3 (i,k,m) = qfcst(i,k,m) + ztodt*dqfx3(i,k,m)
- ta (i,k,m) = (q3 (i,k,m) - qminus(i,k,m))/ztodt
- vadv (i,k,m) = (qfcst(i,k,m) - qminus(i,k,m))/ztodt - hadv(i,k,m)
- end do
- end do
- end do
-
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- pdeldry(i,k) = pdel(i,k)*(1._r8-q3(i,k,1))
- end do ! i
- end do ! k
-
- if (write_camiop) then
- do m=1,pcnst
- alpha_plon(:)= alpha(m)
- call outfld(trim(cnst_name(m))//'_alph',alpha_plon ,plon ,lat )
- call outfld(trim(cnst_name(m))//'_dqfx',dqfx3sav(1,1,m,lat) ,plon ,lat )
- end do
- end if
-!
-! Check for and correct invalid constituents
-!
- call qneg3 ('TFILT_MASSFIX',lat ,nlon ,plon ,plev , &
- 1, pcnst, qmin ,q3(1,1,1))
-!
-! Send slt tendencies to the history tape
-!
-!$OMP PARALLEL DO PRIVATE (M)
- do m=1,pcnst
- if ( cnst_cam_outfld(m) ) then
- call outfld(tottnam(m),ta(1,1,m),plon ,lat )
- end if
- end do
- if (.not. single_column) then
-!
-! Calculate vertical motion field
-!
- call omcalc (rcoslat ,div ,u3 ,v3 ,dpsl , &
- dpsm ,pmid ,pdel ,rpmid ,pint(1,plevp), &
- omga ,nlon )
-
- endif
-
-! write(iulog,*)'tfilt: lat=',lat
-! write(iulog,*)'omga=',omga
-!
-! Time filter (second half of filter for vorticity and divergence only)
-!
-! if(lat.eq.2) then
-! write(iulog,*)'tfilt: ps=',psm2(13),psm1(13),ps(13)
-! write(iulog,*)'tfilt: u=',um2(13,18),u3m1(13,18),u3(13,18)
-! write(iulog,*)'tfilt: t=',tm2(13,18),t3m1(13,18),t3(13,18)
-! write(iulog,*)'tfilt: water=',qm2(13,18,1),q3m1(13,18,1),q3(13,18,1)
-! write(iulog,*)'tfilt: cwat=',qm2(13,18,2),q3m1(13,18,2),q3(13,18,2)
-! write(iulog,*)'tfilt: vort=',vortm2(13,18),vortm1(13,18),vort(13,18)
-! write(iulog,*)'tfilt: div=',divm2(13,18),divm1(13,18),div(13,18)
-! end if
-
- om2eps = 1._r8 - 2._r8*eps
-
- if (nstep.ge.2) then
-!$OMP PARALLEL DO PRIVATE (K, I, M)
- do k=1,plev
- do i=1,nlon
- u3m1(i,k) = om2eps*u3m1(i,k) + eps*um2(i,k) + eps*u3(i,k)
- v3m1(i,k) = om2eps*v3m1(i,k) + eps*vm2(i,k) + eps*v3(i,k)
- t3m1(i,k) = om2eps*t3m1(i,k) + eps*tm2(i,k) + eps*t3(i,k)
- q3m1(i,k,1) = om2eps*q3m1(i,k,1) + eps*qm2(i,k,1) + eps*q3(i,k,1)
- vortm1(i,k) = om2eps*vortm1(i,k) + eps*vortm2(i,k) + eps*vort(i,k)
- divm1(i,k) = om2eps*divm1(i,k) + eps*divm2(i,k) + eps*div(i,k)
- end do
- do m=2,pcnst
- if (cnst_get_type_byind(m) .eq. 'wet') then
- do i=1,nlon
- q3m1(i,k,m) = om2eps*q3m1(i,k,m) + eps*qm2(i,k,m) + eps*q3(i,k,m)
- end do
- endif
- end do
- do m=2,pcnst
- if (cnst_get_type_byind(m) .eq. 'dry') then
- do i=1,nlon ! calculate numerator (timefiltered mass * pdeldry)
- q3m1(i,k,m) = (om2eps*pdelm1dry(i,k)*q3m1(i,k,m) + &
- eps*pdelm2dry(i,k)*qm2(i,k,m) + &
- eps*pdeldry(i,k)*q3(i,k,m))
- end do !i
- endif !dry
- end do !m
- do i=1,nlon ! calculate time filtered value of pdeldry
- pdelm1dry(i,k) = om2eps*pdelm1dry(i,k) + &
- eps*pdelm2dry(i,k) + eps*pdeldry(i,k)
- end do !i
- ! divide time filtered mass*pdeldry by timefiltered pdeldry
- do m=2,pcnst
- if (cnst_get_type_byind(m) == 'dry') then
- do i=1,nlon
- q3m1(i,k,m) = q3m1(i,k,m)/pdelm1dry(i,k)
- end do !i
- endif ! dry
- end do !m
-
- end do
- do i=1,nlon
- psm1(i) = om2eps*psm1(i) + eps*psm2(i) + eps*ps(i)
- end do
- end if
-
- call plevs0 (nlon ,plon ,plev ,psm1 ,pintm1 ,pmidm1 ,pdelm1)
-!
-! Compute time tendencies:comment out since currently not on h-t
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i=1,nlon
- ttend(i,k) = (t3(i,k)-tm2(i,k))/ztodt
- utend(i,k) = (u3(i,k)-um2(i,k))/ztodt
- vtend(i,k) = (v3(i,k)-vm2(i,k))/ztodt
- end do
- end do
-
-!$OMP PARALLEL DO PRIVATE (M, K, I)
- do m=1,pcnst
- do k=1,plev
- do i=1,nlon
- qtend(i,k,m) = (q3(i,k,m) - qm2(i,k,m))/ztodt
- end do
- end do
- end do
-
- do i=1,nlon
- pstend(i) = (ps(i) - psm2(i))/ztodt
- end do
-
-!$OMP PARALLEL DO PRIVATE (M)
- do m=1,pcnst
- if ( cnst_cam_outfld(m) ) then
- call outfld (tendnam(m),qtend(1,1,m),plon,lat)
- call outfld (fixcnam(m),dqfx3(1,1,m),plon,lat)
- call outfld (hadvnam(m),hadv (1,1,m),plon,lat)
- call outfld (vadvnam(m),vadv (1,1,m),plon,lat)
- end if
- end do
-
-! using do loop and select in order to enable functional parallelism with OpenMP
-!$OMP PARALLEL DO PRIVATE (I)
- do i=1,4
- select case (i)
- case (1)
- call outfld ('UTEND ',utend,plon,lat)
- case (2)
- call outfld ('VTEND ',vtend,plon,lat)
- case (3)
- call outfld ('TTEND ',ttend,plon,lat)
- case (4)
- call outfld ('LPSTEN ',pstend,plon,lat)
- end select
- end do
-
- return
-1000 format(' TIMEFILTER: WARNING: fixer for tracer ',i3,' exceeded ', &
- f8.5,' for ',i5,' points at k,lat = ',2i4, &
- ' Avg/Worst = ',1p2e10.2)
-
-end subroutine tfilt_massfixrun
-
-end module tfilt_massfix
diff --git a/src/dynamics/eul/trjmps.F90 b/src/dynamics/eul/trjmps.F90
deleted file mode 100644
index 9c856e38a9..0000000000
--- a/src/dynamics/eul/trjmps.F90
+++ /dev/null
@@ -1,71 +0,0 @@
-subroutine trjmps(dt ,upr ,vpr ,phimp ,lampr , &
- phipr ,nlon )
-!-----------------------------------------------------------------------
-!
-! Purpose:
-! Estimate mid-point interval of parcel trajectory (global spherical
-! coordinates).
-!
-! Method:
-!
-! Author:
-! Original version: J. Olson
-! Standardized: J. Rosinski, June 1992
-! Reviewed: D. Williamson, P. Rasch, August 1992
-! Reviewed: D. Williamson, P. Rasch, March 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid, only: plon, plev
-!-----------------------------------------------------------------------
- implicit none
-!------------------------------Arguments--------------------------------
-!
-! Input arguments
-!
- real(r8), intent(in) :: dt ! time step (seconds)
- real(r8), intent(in) :: upr (plon,plev) ! u-comp of wind at midpoint
- real(r8), intent(in) :: vpr (plon,plev) ! v-comp of wind at midpoint
- real(r8), intent(in) :: phimp(plon,plev) ! lat coord at midpoint
-
- integer, intent(in) :: nlon
-!
-! Output arguments
-!
- real(r8), intent(out) :: lampr(plon,plev) ! relative long coord of midpoint
- real(r8), intent(out) :: phipr(plon,plev) ! relative lat coord of midpoint
-!
-!-----------------------------------------------------------------------
-!
-! dt Time interval that corresponds to the parcel trajectory.
-! upr u-coordinate of velocity corresponding to the most recent
-! estimate of the trajectory mid-point.
-! vpr v-coordinate of velocity corresponding to the most recent
-! estimate of the trajectory mid-point.
-! phimp Phi value of trajectory midpoint (most recent estimate).
-! lampr Longitude coordinate of trajectory mid-point relative to the
-! arrival point.
-! phipr Latitude coordinate of trajectory mid-point relative to the
-! arrival point.
-!
-!---------------------------Local variables-----------------------------
-!
- integer i,k ! index
-!
-!-----------------------------------------------------------------------
-!
-!$OMP PARALLEL DO PRIVATE (K, I)
- do k=1,plev
- do i = 1,nlon
- lampr(i,k) = -.5_r8*dt* upr(i,k) / cos( phimp(i,k) )
- phipr(i,k) = -.5_r8*dt* vpr(i,k)
- end do
- end do
-!
- return
-end subroutine trjmps
diff --git a/src/dynamics/eul/tstep.F90 b/src/dynamics/eul/tstep.F90
deleted file mode 100644
index 53cdfa1d7b..0000000000
--- a/src/dynamics/eul/tstep.F90
+++ /dev/null
@@ -1,153 +0,0 @@
- subroutine tstep(lm ,zdt ,ztdtsq )
-!-----------------------------------------------------------------------
-!
-! Solution of the vertically coupled system of equations arising
-! from the semi-impicit equations for each spectral element along
-! two dimensional wavenumber n. The inverse matrix depends
-! only on two dimensional wavenumber and the reference atmosphere.
-! It is precomputed and stored for use during the forecast. The routine
-! overwrites the d,T and lnps coefficients with the new values.
-!
-!---------------------------Code history--------------------------------
-!
-! Original version: CCM1
-! Standardized: J. Rosinski, June 1992
-! Reviewed: B. Boville, D. Williamson, August 1992
-! Reviewed: B. Boville, D. Williamson, April 1996
-!
-!-----------------------------------------------------------------------
-!
-! $Id$
-! $Author$
-!
-!-----------------------------------------------------------------------
- use shr_kind_mod, only: r8 => shr_kind_r8
- use pmgrid
- use pspect
- use comspe
- use commap
- use spmd_utils, only : iam
- use hycoef, only : hypi, hypd
- implicit none
-
-!-----------------------------------------------------------------------
-!
-! Input arguments
-!
- integer, intent(in) :: lm ! local Fourier wavenumber index
-
- real(r8), intent(in) :: zdt ! timestep, dt (seconds)
- real(r8), intent(in) :: ztdtsq(pnmax) ! dt*(n(n+1)/a^2 where n is 2-d wavenumber
-!
-!---------------------------Local workspace-----------------------------
-!
- real(r8) z(2*pnmax,plev) ! workspace for computation of spectral array d
- real(r8) hhref ! href/2 (reference hydrostatic matrix / 2)
- real(r8) hbps ! bps/2 (ref. coeff. for lnps term in div. eq. / 2)
- real(r8) ztemp ! temporary workspace
-
- integer m ! global wavenumber index
- integer n,j ! 2-d wavenumber index
- integer k,kk ! level indices
- integer lmr,lmc ! real and imaginary spectral indices
- integer ir,ii ! real and imaginary spectral indices
- integer nn ! real and imaginary spectral indices
-!
-!-----------------------------------------------------------------------
-!
-! Complete rhs of helmholtz eq.
-!
- m = locm(lm,iam)
- lmr = lnstart(lm)
- lmc = 2*lmr
-!$OMP PARALLEL DO PRIVATE (K, HHREF, HBPS, N, IR, II, KK)
- do k=1,plev
-!
-! Coefficients for diagonal terms
-!
- hhref = 0.5_r8*href(k,k)
- hbps = 0.5_r8*bps(k)
-!
-! Loop along total wavenumber index (in spectral space)
-! Add lnps and diagonal (vertical space) T terms to d(t-1)
-!
- do n=1,nlen(m)
- ir = lmc + 2*n - 1
- ii = ir + 1
- d(ir,k) = d(ir,k) + ztdtsq(n+m-1)*(hhref*t(ir,k) + hbps*alps(ir))
- d(ii,k) = d(ii,k) + ztdtsq(n+m-1)*(hhref*t(ii,k) + hbps*alps(ii))
- end do
- if (k.lt.plev) then
- do kk=k+1,plev
-!
-! Add off-diagonal (vertical space) T terms to d(t-1)
-!
- hhref = 0.5_r8*href(kk,k)
- do n=1,nlen(m)
- ir = lmc + 2*n - 1
- ii = ir + 1
- d(ir,k) = d(ir,k) + ztdtsq(n+m-1)*hhref*t(ir,kk)
- d(ii,k) = d(ii,k) + ztdtsq(n+m-1)*hhref*t(ii,kk)
- end do
- end do
- end if
- end do ! k=1,plev (calculation level)
-!
-! Solution of helmholtz equation
-! First: initialize temporary space for solution
-!
- z = 0._r8
-!
-! Multiply right hand side by inverse matrix
-!
-!$OMP PARALLEL DO PRIVATE (K, KK, N, IR, II)
- do k=1,plev
- do kk=1,plev
- do n=1,nlen(m)
- ir = lmc + 2*n - 1
- ii = ir + 1
- z(2*n-1,k) = z(2*n-1,k) + bm1(kk,k,m+n-1)*d(ir,kk)
- z(2*n ,k) = z(2*n ,k) + bm1(kk,k,m+n-1)*d(ii,kk)
- end do
- end do ! inner loop over levels
- end do ! outer loop over levels
-!
-! Move solution for divergence to d
-!
-!$OMP PARALLEL DO PRIVATE (K, N, IR, II)
- do k=1,plev
- do n=1,nlen(m)
- ir = lmc + 2*n - 1
- ii = ir + 1
- d(ir,k) = z(2*n-1,k)
- d(ii,k) = z(2*n ,k)
- end do
- end do ! outer loop over levels
-!
-! Complete ln(pstar) and T forecasts
-! Add semi-implicit part to surface pressure (vector multiply)
-!
- do k=1,plev
- ztemp = zdt*hypd(k)/hypi(plevp)
- do n=1,nlen(m)
- ir = lmc + 2*n - 1
- ii = ir + 1
- alps(ir) = alps(ir) - ztemp*d(ir,k)
- alps(ii) = alps(ii) - ztemp*d(ii,k)
- end do
- end do
-!
-! Add semi-implicit part to temperature (matrix multiply)
-!
-!$OMP PARALLEL DO PRIVATE (K, KK, NN)
- do k=1,plev
- do kk=1,plev
- do nn = lmc+1, lmc+2*nlen(m)
- t(nn,k) = t(nn,k) - zdt*tau(kk,k)*d(nn,kk)
- end do
- end do
- end do
-!
- return
- end subroutine tstep
-
diff --git a/src/dynamics/se/dycore/interpolate_mod.F90 b/src/dynamics/se/dycore/interpolate_mod.F90
index 55093dad73..3d561c39d3 100644
--- a/src/dynamics/se/dycore/interpolate_mod.F90
+++ b/src/dynamics/se/dycore/interpolate_mod.F90
@@ -89,7 +89,7 @@ module interpolate_mod
! store the lat-lon grid
! gridtype = 1 equally spaced, including poles (FV scalars output grid)
- ! gridtype = 2 Gauss grid (CAM Eulerian)
+ ! gridtype = 2 Gauss grid
! gridtype = 3 equally spaced, no poles (FV staggered velocity)
! Seven possible history files, last one is inithist and should be native grid
integer :: nlat,nlon
diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90
index 3d5e6f8b84..5f7e7d9a60 100644
--- a/src/physics/cam/cam_diagnostics.F90
+++ b/src/physics/cam/cam_diagnostics.F90
@@ -221,9 +221,7 @@ subroutine diag_init_dry(pbuf2d)
call register_vector_field('UAP','VAP')
call addfld (apcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (after physics)')
- if (.not.dycore_is('EUL')) then
- call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)')
- end if
+ call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)')
call addfld ('TTEND_TOT', (/ 'lev' /), 'A', 'K/s', 'Total temperature tendency')
! outfld calls in diag_phys_tend_writeout
@@ -367,9 +365,7 @@ subroutine diag_init_dry(pbuf2d)
call add_default ('UAP ' , history_budget_histfile_num, ' ')
call add_default ('VAP ' , history_budget_histfile_num, ' ')
call add_default (apcnst(1) , history_budget_histfile_num, ' ')
- if (.not.dycore_is('EUL')) then
- call add_default ('TFIX ' , history_budget_histfile_num, ' ')
- end if
+ call add_default ('TFIX ' , history_budget_histfile_num, ' ')
end if
if (history_waccm) then
@@ -2068,14 +2064,10 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt)
! Total physics tendency for Temperature
! (remove global fixer tendency from total for FV and SE dycores)
- if (.not.dycore_is('EUL')) then
- call check_energy_get_integrals( heat_glob_out=heat_glob )
- ftem2(:ncol) = heat_glob/cpair
- call outfld('TFIX', ftem2, pcols, lchnk )
- ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) - heat_glob/cpair
- else
- ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver)
- end if
+ call check_energy_get_integrals( heat_glob_out=heat_glob )
+ ftem2(:ncol) = heat_glob/cpair
+ call outfld('TFIX', ftem2, pcols, lchnk )
+ ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) - heat_glob/cpair
call outfld('PTTEND',ftem3, pcols, lchnk )
ftem3(:ncol,:pver) = tend%dudt(:ncol,:pver)
call outfld('UTEND_PHYSTOT',ftem3, pcols, lchnk )
diff --git a/src/physics/cam/geopotential.F90 b/src/physics/cam/geopotential.F90
index ad49e470c4..52d4998133 100644
--- a/src/physics/cam/geopotential.F90
+++ b/src/physics/cam/geopotential.F90
@@ -88,7 +88,7 @@ subroutine geopotential_t( &
call cnst_get_ind('Q', ixq)
!
- ! original code for backwards compatability with FV and EUL
+ ! original code for backwards compatability with FV
!
if (.not.(dycore_is('MPAS') .or. dycore_is('SE'))) then
diff --git a/src/physics/cam/gw_movmtn.F90 b/src/physics/cam/gw_movmtn.F90
index 142b833eaa..2240042ce2 100644
--- a/src/physics/cam/gw_movmtn.F90
+++ b/src/physics/cam/gw_movmtn.F90
@@ -485,7 +485,7 @@ subroutine vorticity_flux_src (vorticity , ncol, pverx, alpha_gw_movmtn, vort_sr
steering_level(:ncol) = pverx - 20
launch_level(:ncol) = steering_level -10
- scale_factor = 1.e4 ! scales vorticity amp to u'w' in CLUBB
+ scale_factor = 1.e4_r8 ! scales vorticity amp to u'w' in CLUBB
!-----------------------------------
! Simple average over layers.
! Probably can do better
diff --git a/src/physics/cam/physics_types.F90 b/src/physics/cam/physics_types.F90
index 3228c27105..fb66116bb2 100644
--- a/src/physics/cam/physics_types.F90
+++ b/src/physics/cam/physics_types.F90
@@ -32,7 +32,6 @@ module physics_types
public physics_ptend_init
public physics_state_set_grid
public physics_dme_adjust ! adjust dry mass and energy for change in water
- ! cannot be applied to eul or sld dycores
public physics_state_copy ! copy a physics_state object
public physics_ptend_copy ! copy a physics_ptend object
public physics_ptend_sum ! accumulate physics_ptend objects
@@ -1209,9 +1208,6 @@ subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt)
! interfaces and midpoints to the surface pressure. The result is no longer in
! the original hybrid coordinate.
!
- ! This procedure cannot be applied to the "eul" or "sld" dycores because they
- ! require the hybrid coordinate.
- !
! Author: Byron Boville
! !REVISION HISTORY:
@@ -1263,7 +1259,7 @@ subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt)
state%ps(:ncol) = state%pint(:ncol,1)
!
- ! original code for backwards compatability with FV and EUL
+ ! original code for backwards compatability with FV
!
if (.not.(dycore_is('MPAS') .or. dycore_is('SE'))) then
do k = 1, pver
diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90
index 5aa84b55a4..0e83ad2707 100644
--- a/src/physics/cam/physpkg.F90
+++ b/src/physics/cam/physpkg.F90
@@ -2243,14 +2243,12 @@ subroutine tphysbc (ztodt, state, &
call tot_energy_phys(state, 'phBF')
call tot_energy_phys(state, 'dyBF',vc=vc_dycore)
- if (.not.dycore_is('EUL')) then
- call check_energy_cam_fix(state, ptend, nstep, flx_heat)
- call physics_update(state, ptend, ztodt, tend)
+ 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 )
- call check_energy_cam_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat)
- call outfld( 'EFIX', flx_heat , pcols, lchnk )
- end if
call tot_energy_phys(state, 'phBP')
call tot_energy_phys(state, 'dyBP',vc=vc_dycore)
! Save state for convective tendency calculations.
diff --git a/src/physics/cam7/physpkg.F90 b/src/physics/cam7/physpkg.F90
index d5ad2ee3e1..43b55137f9 100644
--- a/src/physics/cam7/physpkg.F90
+++ b/src/physics/cam7/physpkg.F90
@@ -2708,12 +2708,10 @@ subroutine tphysbc (ztodt, state, &
call tot_energy_phys(state, 'phBF')
call tot_energy_phys(state, 'dyBF',vc=vc_dycore)
- if (.not.dycore_is('EUL')) 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
+ 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 )
call tot_energy_phys(state, 'phBP')
call tot_energy_phys(state, 'dyBP',vc=vc_dycore)
diff --git a/src/physics/camrt/radiation.F90 b/src/physics/camrt/radiation.F90
index 3f298d93a4..d7e0cdbac6 100644
--- a/src/physics/camrt/radiation.F90
+++ b/src/physics/camrt/radiation.F90
@@ -852,7 +852,7 @@ subroutine radiation_tend( &
! This is used by the chemistry.
real(r8), pointer :: fsds(:) ! Surface solar down flux
- ! This is used for the energy checker and the Eulerian dycore.
+ ! This is used for the energy checker.
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
diff --git a/src/physics/simple/physpkg.F90 b/src/physics/simple/physpkg.F90
index 48bc0200f7..0bbb63dd7e 100644
--- a/src/physics/simple/physpkg.F90
+++ b/src/physics/simple/physpkg.F90
@@ -616,7 +616,7 @@ subroutine tphysac (ztodt, cam_in, cam_out, state, tend, pbuf)
to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:))
if (moist_physics) then
- ! Scale dry mass and energy (does nothing if dycore is EUL or SLD)
+ ! Scale dry mass and energy
call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.)
call cnst_get_ind('CLDICE', ixcldice, abort=.false.)
tmp_q (:ncol,:pver) = state%q(:ncol,:pver,1)
@@ -834,7 +834,7 @@ subroutine tphysbc (ztodt, state, tend, pbuf, cam_out, cam_in )
call t_startf('energy_fixer')
- if (adiabatic .and. (.not. dycore_is('EUL'))) then
+ if (adiabatic) 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)
diff --git a/src/utils/cam_grid_support.F90 b/src/utils/cam_grid_support.F90
index 48c33d4974..d4c7fc9792 100644
--- a/src/utils/cam_grid_support.F90
+++ b/src/utils/cam_grid_support.F90
@@ -1658,8 +1658,6 @@ function cam_grid_get_areawt(id) result(wtvals)
select case(trim(cam_grids(gridind)%name))
case('GLL')
wtname='area_weight_gll'
- case('EUL')
- wtname='gw'
case('FV')
wtname='gw'
case('INI')
@@ -3690,7 +3688,6 @@ subroutine cam_grid_get_patch_mask(this, lonl, lonu, latl, latu, patch, cco)
if ( (abs(lat - latmin) <= maxangle) .and. &
(abs(lon - lonmin) <= maxangle)) then
! maxangle could be pi but why waste all those trig functions?
- ! XXgoldyXX: What should we use for maxangle given coarse Eul grids?
if ((lat == latmin) .and. (lon == lonmin)) then
dist = 0.0_r8
else
diff --git a/src/utils/cam_pio_utils.F90 b/src/utils/cam_pio_utils.F90
index 7fd58b13cd..63691c8910 100644
--- a/src/utils/cam_pio_utils.F90
+++ b/src/utils/cam_pio_utils.F90
@@ -132,7 +132,7 @@ logical function use_scam_limits(File, start, kount, dimnames)
latidx, lonidx)
if (present(dimnames)) then
if (trim(dimnames(1)) == 'lon') then
- start(1) = lonidx ! First dim always lon for Eulerian dycore
+ start(1) = lonidx
! This could be generalized -- for now, stick with single column
kount(1) = 1
else
diff --git a/src/utils/spmd_utils.F90 b/src/utils/spmd_utils.F90
index ea6ca7a861..8cd5d040a2 100644
--- a/src/utils/spmd_utils.F90
+++ b/src/utils/spmd_utils.F90
@@ -69,8 +69,8 @@ module spmd_utils
!-----------------------------------------------------------------------
! Public interfaces ----------------------------------------------------
!-----------------------------------------------------------------------
- public pair ! $$$here... originally from eul|sld/spmd_dyn
- public ceil2 ! $$$here... originally from eul|sld/spmd_dyn
+ public pair
+ public ceil2
public spmdinit
public spmd_utils_readnl
#if ( defined SPMD )
diff --git a/test/system/TR8.sh b/test/system/TR8.sh
index 22ec597f5d..037cdb3b80 100755
--- a/test/system/TR8.sh
+++ b/test/system/TR8.sh
@@ -30,7 +30,7 @@ rc=$?
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/camrt
rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/carma
-rc=$?
+rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/rrtmg -s aer_src
rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/rrtmgp -s data,ext
@@ -81,8 +81,6 @@ ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/dynamics/se
rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/dynamics/fv
rc=`expr $? + $rc`
-ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/dynamics/eul
-rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/dynamics/mpas -s dycore
rc=`expr $? + $rc`
@@ -94,8 +92,6 @@ ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/dynamics/se
rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/dynamics/fv
rc=`expr $? + $rc`
-ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/dynamics/eul
-rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/dynamics/mpas -s dycore
rc=`expr $? + $rc`
@@ -104,8 +100,6 @@ fi
#Check other
if [ -d "${CAM_ROOT}/components/cam" ]; then
-ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/advection
-rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/control
rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/utils
@@ -113,8 +107,6 @@ rc=`expr $? + $rc`
else
-ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/advection
-rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/control
rc=`expr $? + $rc`
ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/utils
diff --git a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90 b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90
index 0e4fc2c202..3d0a26cc6e 100644
--- a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90
+++ b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90
@@ -571,8 +571,8 @@ subroutine binning(plev ,plato ,plono ,plat ,plon , &
! ! starting at 0 deg and moving
! ! eastward
real*8 gwo (plato) ! Output Gaussian wgts (if relevant grid)
- integer dyn_flag ! Dynamics flag of input grid: Eul=1, FV=0
- integer dyn_flago ! Dynamics flag of output grid: Eul=1, FV=0
+ integer dyn_flag ! Dynamics flag of input grid: FV=0
+ integer dyn_flago ! Dynamics flag of output grid: FV=0
real*8 bin_factor ! bin-box area expansion/contraction factor relative to
! ! output grid-box area.
!
diff --git a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90-EXTEND b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90-EXTEND
index 0e4fc2c202..3d0a26cc6e 100644
--- a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90-EXTEND
+++ b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90-EXTEND
@@ -571,8 +571,8 @@
! ! starting at 0 deg and moving
! ! eastward
real*8 gwo (plato) ! Output Gaussian wgts (if relevant grid)
- integer dyn_flag ! Dynamics flag of input grid: Eul=1, FV=0
- integer dyn_flago ! Dynamics flag of output grid: Eul=1, FV=0
+ integer dyn_flag ! Dynamics flag of input grid: FV=0
+ integer dyn_flago ! Dynamics flag of output grid: FV=0
real*8 bin_factor ! bin-box area expansion/contraction factor relative to
! ! output grid-box area.
!
diff --git a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90-ORIG b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90-ORIG
index 07e3c16dd5..c3c6f8113d 100644
--- a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90-ORIG
+++ b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.f90-ORIG
@@ -571,8 +571,8 @@
! ! starting at 0 deg and moving
! ! eastward
real*8 gwo (plato) ! Output Gaussian wgts (if relevant grid)
- integer dyn_flag ! Dynamics flag of input grid: Eul=1, FV=0
- integer dyn_flago ! Dynamics flag of output grid: Eul=1, FV=0
+ integer dyn_flag ! Dynamics flag of input grid: FV=0
+ integer dyn_flago ! Dynamics flag of output grid: FV=0
real*8 bin_factor ! bin-box area expansion/contraction factor relative to
! ! output grid-box area.
!
diff --git a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.stub b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.stub
index 063a496c56..cea7413b1c 100644
--- a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.stub
+++ b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/MAKEIC.stub
@@ -116,8 +116,8 @@ C ! starting from southern-most lat
C ! starting at 0 deg and moving
C ! eastward
real*8 gwo (plato) ! Output Gaussian wgts (if relevant grid)
- integer dyn_flag ! Dynamics flag of input grid: Eul=1, FV=0
- integer dyn_flago ! Dynamics flag of output grid: Eul=1, FV=0
+ integer dyn_flag ! Dynamics flag of input grid: FV=0
+ integer dyn_flago ! Dynamics flag of output grid: FV=0
real*8 bin_factor ! bin-box area expansion/contraction factor relative to
C ! output grid-box area.
C
diff --git a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC.ncl b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC.ncl
index e42ff54980..1b33ae37dd 100644
--- a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC.ncl
+++ b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC.ncl
@@ -62,9 +62,6 @@ begin
adjust_state_from_topo = field@adjust_state_from_topo
mass_fix = False
- if(dycore .eq. "eul") then
- mass_fix = True
- end if
;------------------------
; Define disk directories
@@ -231,8 +228,8 @@ begin
exit_script = False
- if(dycore .ne. "eul" .and. dycore .ne. "fv" .and. dycore .ne. "homme" ) then
- print("Error: 'dycore' must be: 'eul', 'fv', or 'homme'")
+ if(dycore .ne. "fv" .and. dycore .ne. "homme" ) then
+ print("Error: 'dycore' must be: 'fv', or 'homme'")
print(" 'dycore' is currently: "+dycore)
exit_script = True
end if
diff --git a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_Create_field_Master_List.ncl b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_Create_field_Master_List.ncl
index a2f5c49363..19a24719ad 100644
--- a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_Create_field_Master_List.ncl
+++ b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_Create_field_Master_List.ncl
@@ -10,7 +10,7 @@ function Create_field_Master_List(spectral_trunc_setting:integer, field:string )
;********************************************************************************************;
; ;
; Create_field_Master_List ;
-; spectral_trunc_setting : integer; Spectral truncation (Eulerian only) ;
+; spectral_trunc_setting : integer; Spectral truncation (if Gaussian grid) ;
; "field" is a master variable carrying meta-data needed for file ;
; processing ;
; ;
@@ -29,7 +29,7 @@ begin
Master_List@dimensions = new( (/field_dim/), string ) ; "2D" or "3D" designation
Master_List@horz_interp = new( (/field_dim/), string ) ; flag to indicate which type of horizontal interpolation to use
Master_List@vert_interp = new( (/field_dim/), string ) ; flag to indicate which type of vertical interpolation to use
- Master_List@spec_trunc = new( (/field_dim/), integer) ; Spectral truncation to use (if Eulerian dycore)
+ Master_List@spec_trunc = new( (/field_dim/), integer) ; Spectral truncation (if Gaussian grid).
Master_List@bin_factor = new( (/field_dim/), double ) ; bin factor to use if horizontal interpolation is "binning"
; (typical value: 1.)
Master_List@loutput = new( (/field_dim/), logical) ; Flag to output field (if False, field is used only for internal processing
@@ -56,7 +56,7 @@ begin
; Options for horizontal: "no_interp"
; "cubic" ; recommended only for non-tracer species
; "cubic_sp" ; should only be used for tracers and water products like Q, CLDLIQ, CLDICE, CLOUD, etc.
- ; "spectral" ; only for non-tracer species in the Eulerian dycore
+ ; "spectral" ; only for non-tracer species (if Gaussian grid)
; "binning" ; "conservative remapping" --> recommended for all horizontal interpolations
;
; Options for vertical: "no_interp"
@@ -733,9 +733,6 @@ begin
print(" Valid post-processing options are: '"+post_process_flags+"'")
exit
end if
- if( field@dycore .ne. "eul") then
- Master_List@spec_trunc(ifield) = -1
- end if
end do
delete(Master_List@_FillValue)
diff --git a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_ERAI.csh b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_ERAI.csh
index 45105f799e..a21e1099ed 100755
--- a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_ERAI.csh
+++ b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_ERAI.csh
@@ -23,11 +23,11 @@ setenv REF_DATE 20070901
# Output file format
setenv CASE ERAI_f09_L30 # Case name that will be appended to name of output file
-setenv DYCORE fv # Dycore ("eul" or "fv" are the current choices)
+setenv DYCORE fv # Dycore ("fv" is the only current choice)
setenv PRECISION float # "double" or "float" are the current choices of output precision
-setenv PTRM -1 # "M" spectral truncation (for "eul" dycore only; ignored for other dycores; "-1" = no trunc)
-setenv PTRN -1 # "N" spectral truncation (for "eul" dycore only; ignored for other dycores; "-1" = no trunc)
-setenv PTRK -1 # "K" spectral truncation (for "eul" dycore only; ignored for other dycores; "-1" = no trunc)
+setenv PTRM -1 # "M" spectral truncation (for Gaussian grid; "-1" = no trunc)
+setenv PTRN -1 # "N" spectral truncation (for Gaussian grid; "-1" = no trunc)
+setenv PTRK -1 # "K" spectral truncation (for Gaussian grid; "-1" = no trunc)
setenv PLAT 192 # Number of latitudes on output IC file
setenv PLON 288 # Number of longitudes on output IC file
setenv PLEV 30 # Number of vert levs on output IC file
diff --git a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_extract_analyses_info.ncl b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_extract_analyses_info.ncl
index cf0e726b5e..54cad74295 100644
--- a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_extract_analyses_info.ncl
+++ b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_extract_analyses_info.ncl
@@ -260,7 +260,7 @@ begin
if(ftype .eq. "CAM") then
- ; Standard CAM Eulerian or FV file
+ ; Standard CAM FV file
file_dim_names = getvardims (data)
diff --git a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_procedures.ncl b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_procedures.ncl
index c2acc74f2d..fece1c56f7 100644
--- a/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_procedures.ncl
+++ b/tools/nudging/Gen_Data/Gen_Data_FVdycore/Gen_Data_SETNAME_f09/makeIC_procedures.ncl
@@ -2493,7 +2493,7 @@ begin
; extracted
field@horz_interp = new( (/field_dim/), string ) ; flag to indicate which type of horizontal interpolation to use
field@vert_interp = new( (/field_dim/), string ) ; flag to indicate which type of vertical interpolation to use
- field@spec_trunc = new( (/field_dim/), integer) ; Spectral truncation to use (if Eulerian dycore)
+ field@spec_trunc = new( (/field_dim/), integer) ; Spectral truncation to use (if Gaussian grid)
field@bin_factor = new( (/field_dim/), double ) ; bin factor to use if horizontal interpolation is "binning"
; (typical value: 1.)
field@processed = new( (/field_dim/), logical) ; Set to False until field is processed
@@ -2738,24 +2738,12 @@ begin
;-------------------------
if(field@plevo .gt. 0) then
- if(field@dycore .eq. "eul") then
- filedimdef(cdf,(/"lat" ,"lon" ,"lev" ,"ilev" ,"time","scalar"/),\
- (/field@plato,field@plono,field@plevo,field@plevo+1,1 ,1 /),\
- (/False ,False , False , False , True , False /) )
- end if
-
if(field@dycore .eq. "fv") then
filedimdef(cdf,(/"lat" ,"lon" ,"slat" ,"slon" ,"lev" ,"ilev" ,"time","scalar"/),\
(/field@plato,field@plono,field@plato-1,field@plono,field@plevo,field@plevo+1,1 ,1 /),\
(/False ,False ,False ,False , False , False , True , False /) )
end if
else
- if(field@dycore .eq. "eul") then
- filedimdef(cdf,(/"lat" ,"lon" ,"time","scalar"/),\
- (/field@plato,field@plono,1 ,1 /),\
- (/False ,False , True , False /) )
- end if
-
if(field@dycore .eq. "fv") then
filedimdef(cdf,(/"lat" ,"lon" ,"slat" ,"slon" ,"time","scalar"/),\
(/field@plato,field@plono,field@plato-1,field@plono,1 ,1 /),\
@@ -2877,89 +2865,6 @@ begin
; Define dycore-specific parameters and coordinates
;--------------------------------------------------
-;---------
-; Eulerian
-;---------
-
- if(field@dycore .eq. "eul") then
-
- filevardef (cdf,"lat","double",(/"lat"/))
- cdf->lat@long_name = "latitude"
- cdf->lat@units = "degrees_north"
-
- filevardef (cdf,"lon","double",(/"lon"/))
- cdf->lon@long_name = "longitude"
- cdf->lon@units = "degrees_east"
-
- filevardef (cdf,"ntrm","integer",(/"scalar"/))
- cdf->ntrm@long_name = "spectral truncation parameter M"
-
- filevardef (cdf,"ntrn","integer",(/"scalar"/))
- cdf->ntrn@long_name = "spectral truncation parameter N"
-
- filevardef (cdf,"ntrk","integer",(/"scalar"/))
- cdf->ntrk@long_name = "spectral truncation parameter K"
-
- filevardef (cdf,"gw","double",(/"lat"/))
- cdf->gw@long_name = "gauss weights"
-
-;-----------------------
-; Pre-set some variables
-;-----------------------
-
- del_lon = (360./field@plono)
-
- cdf->lon = ispan(0,field@plono-1,1)*del_lon
- gau_info = gaus(field@plato/2)
- cdf->lat = gau_info(:,0)
- cdf->gw = gau_info(:,1)
-
- cdf->ntrm = field@ptrmo
- cdf->ntrn = field@ptrno
- cdf->ntrk = field@ptrko
-
- field@lat = cdf->lat
- field@lon = cdf->lon
-
-;---------------------------------------------------
-; Define field variables, dimensions, and attributes
-;---------------------------------------------------
-
- time_dim = "time"
- lev_dim = "lev"
- count = 0
- do i = 0,nfields-1
-
- if(field@loutput(i)) then
- count = count + 1
-
- print (" Declare space for output field: "+field(i)+ \
- " (field "+count+" of "+nfields_out+")")
-
- lat_dim = "lat"
- lon_dim = "lon"
-
- if(field@dimensions(i) .eq. "2D") then
- filevardef (cdf,field(i),field@precision,(/time_dim,lat_dim,lon_dim/))
- end if
- if(field@dimensions(i) .eq. "3D") then
- filevardef (cdf,field(i),field@precision,(/time_dim,lev_dim,lat_dim,lon_dim /))
- end if
-
- cdf->$field(i)$@long_name = field@long_name (i)
- cdf->$field(i)$@units = field@units (i)
- cdf->$field(i)$@source_file = fname(field@source_file (i))
- cdf->$field(i)$@source_field_name = field@source_field(i)
- cdf->$field(i)$@horz_interp_flag = field@horz_interp (i)
- if(field@dimensions(i) .eq. "3D") then
- cdf->$field(i)$@vert_interp_flag = field@vert_interp (i)
- end if
- end if
-
- end do
-
- end if
-
;---
; FV
;---
diff --git a/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/MAKEIC.f90 b/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/MAKEIC.f90
index da5561735c..a985fcf97a 100644
--- a/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/MAKEIC.f90
+++ b/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/MAKEIC.f90
@@ -571,8 +571,8 @@ subroutine binning(plev ,plato ,plono ,plat ,plon , &
! ! starting at 0 deg and moving
! ! eastward
real*8 gwo (plato) ! Output Gaussian wgts (if relevant grid)
- integer dyn_flag ! Dynamics flag of input grid: Eul=1, FV=0
- integer dyn_flago ! Dynamics flag of output grid: Eul=1, FV=0
+ integer dyn_flag ! Dynamics flag of input grid: FV=0
+ integer dyn_flago ! Dynamics flag of output grid: FV=0
real*8 bin_factor ! bin-box area expansion/contraction factor relative to
! ! output grid-box area.
!
diff --git a/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/MAKEIC.stub b/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/MAKEIC.stub
index 74963f0d30..6b0ccd939b 100644
--- a/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/MAKEIC.stub
+++ b/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/MAKEIC.stub
@@ -116,8 +116,8 @@ C ! starting from southern-most lat
C ! starting at 0 deg and moving
C ! eastward
real*8 gwo (plato) ! Output Gaussian wgts (if relevant grid)
- integer dyn_flag ! Dynamics flag of input grid: Eul=1, FV=0
- integer dyn_flago ! Dynamics flag of output grid: Eul=1, FV=0
+ integer dyn_flag ! Dynamics flag of input grid: FV=0
+ integer dyn_flago ! Dynamics flag of output grid: FV=0
real*8 bin_factor ! bin-box area expansion/contraction factor relative to
C ! output grid-box area.
C
diff --git a/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_Create_field_Master_List.ncl b/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_Create_field_Master_List.ncl
index 1731f775e4..5351042467 100644
--- a/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_Create_field_Master_List.ncl
+++ b/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_Create_field_Master_List.ncl
@@ -10,7 +10,7 @@ function Create_field_Master_List(spectral_trunc_setting:integer, field:string )
;********************************************************************************************;
; ;
; Create_field_Master_List ;
-; spectral_trunc_setting : integer; Spectral truncation (Eulerian only) ;
+; spectral_trunc_setting : integer; Spectral truncation (Gaussian grid only) ;
; "field" is a master variable carrying meta-data needed for file ;
; processing ;
; ;
@@ -29,7 +29,7 @@ begin
Master_List@dimensions = new( (/field_dim/), string ) ; "2D" or "3D" designation
Master_List@horz_interp = new( (/field_dim/), string ) ; flag to indicate which type of horizontal interpolation to use
Master_List@vert_interp = new( (/field_dim/), string ) ; flag to indicate which type of vertical interpolation to use
- Master_List@spec_trunc = new( (/field_dim/), integer) ; Spectral truncation to use (if Eulerian dycore)
+ Master_List@spec_trunc = new( (/field_dim/), integer) ; Spectral truncation to use (if Gaussian grid)
Master_List@bin_factor = new( (/field_dim/), double ) ; bin factor to use if horizontal interpolation is "conserve"
; (typical value: 1.)
Master_List@loutput = new( (/field_dim/), logical) ; Flag to output field (if False, field is used only for internal processing
@@ -746,9 +746,6 @@ begin
print(" Valid post-processing options are: '"+post_process_flags+"'")
exit
end if
- if( field@dycore .ne. "eul") then
- Master_List@spec_trunc(ifield) = -1
- end if
end do
delete(Master_List@_FillValue)
diff --git a/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_extract_analyses_info.ncl b/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_extract_analyses_info.ncl
index 5c10beed42..87ef53cbe1 100644
--- a/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_extract_analyses_info.ncl
+++ b/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_extract_analyses_info.ncl
@@ -265,7 +265,7 @@ begin
if(ftype .eq. "CAM") then
- ; Standard CAM Eulerian or FV file
+ ; Standard CAM FV file
file_dim_names = getvardims (data)
diff --git a/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_se_procedures.ncl b/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_se_procedures.ncl
index f04670080b..f5db9ae6bf 100644
--- a/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_se_procedures.ncl
+++ b/tools/nudging/Gen_Data/Gen_Data_SEdycore/Gen_Data_SETNAME_ne30/makeIC_se_procedures.ncl
@@ -1216,7 +1216,7 @@ begin
; interpolation to use
field@vert_interp =new( (/field_dim/), string ) ; flag to indicate which type of vertical
; interpolation to use
- field@spec_trunc =new( (/field_dim/), integer) ; Spectral truncation to use (if Eulerian dycore)
+ field@spec_trunc =new( (/field_dim/), integer) ; Spectral truncation to use (if Gaussian grid)
field@bin_factor =new( (/field_dim/), double ) ; bin factor to use if horizontal
; interpolation is "binning" (typical value: 1.)
field@processed =new( (/field_dim/), logical) ; Set to False until field is processed