From 27a96f2f84e8eb3754fc32dd422c84a505b5bfa8 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 12 Dec 2024 10:40:32 -0500 Subject: [PATCH 1/4] remove source for Eulerian dycore; remove configuration "-dyn eul" --- bld/config_files/definition.xml | 19 +- bld/config_files/horiz_grid.xml | 9 - bld/configure | 62 +- bld/namelist_files/use_cases/dabi_p2004.xml | 40 - cime_config/buildcpp | 15 - cime_config/config_component.xml | 8 +- cime_config/config_compsets.xml | 28 - cime_config/testdefs/testlist_cam.xml | 148 -- doc/ChangeLog | 105 ++ src/advection/slt/bandij.F90 | 85 -- src/advection/slt/basdy.F90 | 55 - src/advection/slt/basdz.F90 | 53 - src/advection/slt/basiy.F90 | 44 - src/advection/slt/difcor.F90 | 115 -- src/advection/slt/engy_tdif.F90 | 58 - src/advection/slt/engy_te.F90 | 64 - src/advection/slt/extx.F90 | 66 - src/advection/slt/extys.F90 | 137 -- src/advection/slt/extyv.F90 | 177 --- src/advection/slt/flxint.F90 | 45 - src/advection/slt/grdxy.F90 | 124 -- src/advection/slt/hadvtest.h | 2 - src/advection/slt/hordif1.F90 | 92 -- src/advection/slt/kdpfnd.F90 | 66 - src/advection/slt/lcbas.F90 | 58 - src/advection/slt/lcdbas.F90 | 71 - src/advection/slt/omcalc.F90 | 146 -- src/advection/slt/pdelb0.F90 | 49 - src/advection/slt/phcs.F90 | 238 --- src/advection/slt/plevs0.F90 | 63 - src/advection/slt/qmassa.F90 | 111 -- src/advection/slt/qmassd.F90 | 69 - src/advection/slt/reordp.F90 | 57 - src/advection/slt/scm0.F90 | 57 - src/advection/slt/xqmass.F90 | 150 -- src/dynamics/eul/bndexch.F90 | 248 ---- src/dynamics/eul/commap.F90 | 23 - src/dynamics/eul/comspe.F90 | 43 - src/dynamics/eul/comsta.h | 15 - src/dynamics/eul/courlim.F90 | 170 --- src/dynamics/eul/cubxdr.F90 | 83 -- src/dynamics/eul/cubydr.F90 | 130 -- src/dynamics/eul/cubzdr.F90 | 99 -- src/dynamics/eul/diag_dynvar_ic.F90 | 67 - src/dynamics/eul/dp_coupling.F90 | 475 ------ src/dynamics/eul/dycore.F90 | 28 - src/dynamics/eul/dycore_budget.F90 | 27 - src/dynamics/eul/dyn.F90 | 124 -- src/dynamics/eul/dyn_comp.F90 | 1174 --------------- src/dynamics/eul/dyn_grid.F90 | 1199 ---------------- src/dynamics/eul/dyndrv.F90 | 142 -- src/dynamics/eul/dynpkg.F90 | 151 -- src/dynamics/eul/eul_control_mod.F90 | 55 - src/dynamics/eul/grcalc.F90 | 513 ------- src/dynamics/eul/grmult.F90 | 322 ----- src/dynamics/eul/hdinti.F90 | 80 -- src/dynamics/eul/herxin.F90 | 143 -- src/dynamics/eul/heryin.F90 | 129 -- src/dynamics/eul/herzin.F90 | 107 -- src/dynamics/eul/hordif.F90 | 154 -- src/dynamics/eul/hrintp.F90 | 139 -- src/dynamics/eul/interp_mod.F90 | 65 - src/dynamics/eul/iop.F90 | 134 -- src/dynamics/eul/lagyin.F90 | 151 -- src/dynamics/eul/limdx.F90 | 100 -- src/dynamics/eul/limdy.F90 | 126 -- src/dynamics/eul/limdz.F90 | 96 -- src/dynamics/eul/linemsdyn.F90 | 563 -------- src/dynamics/eul/massfix.F90 | 37 - src/dynamics/eul/parslt.h | 13 - src/dynamics/eul/pmgrid.F90 | 29 - src/dynamics/eul/prognostics.F90 | 113 -- src/dynamics/eul/pspect.F90 | 18 - src/dynamics/eul/quad.F90 | 278 ---- src/dynamics/eul/realloc4.F90 | 423 ------ src/dynamics/eul/realloc7.F90 | 213 --- src/dynamics/eul/restart_dynamics.F90 | 553 ------- src/dynamics/eul/scan2.F90 | 774 ---------- src/dynamics/eul/scandyn.F90 | 207 --- src/dynamics/eul/scanslt.F90 | 1430 ------------------- src/dynamics/eul/scmforecast.F90 | 571 -------- src/dynamics/eul/settau.F90 | 543 ------- src/dynamics/eul/spegrd.F90 | 512 ------- src/dynamics/eul/spetru.F90 | 1287 ----------------- src/dynamics/eul/sphdep.F90 | 765 ---------- src/dynamics/eul/spmd_dyn.F90 | 1111 -------------- src/dynamics/eul/stats.F90 | 110 -- src/dynamics/eul/stepon.F90 | 425 ------ src/dynamics/eul/tfilt_massfix.F90 | 484 ------- src/dynamics/eul/trjmps.F90 | 71 - src/dynamics/eul/tstep.F90 | 153 -- 91 files changed, 122 insertions(+), 19759 deletions(-) delete mode 100644 bld/namelist_files/use_cases/dabi_p2004.xml delete mode 100644 src/advection/slt/bandij.F90 delete mode 100644 src/advection/slt/basdy.F90 delete mode 100644 src/advection/slt/basdz.F90 delete mode 100644 src/advection/slt/basiy.F90 delete mode 100644 src/advection/slt/difcor.F90 delete mode 100644 src/advection/slt/engy_tdif.F90 delete mode 100644 src/advection/slt/engy_te.F90 delete mode 100644 src/advection/slt/extx.F90 delete mode 100644 src/advection/slt/extys.F90 delete mode 100644 src/advection/slt/extyv.F90 delete mode 100644 src/advection/slt/flxint.F90 delete mode 100644 src/advection/slt/grdxy.F90 delete mode 100644 src/advection/slt/hadvtest.h delete mode 100644 src/advection/slt/hordif1.F90 delete mode 100644 src/advection/slt/kdpfnd.F90 delete mode 100644 src/advection/slt/lcbas.F90 delete mode 100644 src/advection/slt/lcdbas.F90 delete mode 100644 src/advection/slt/omcalc.F90 delete mode 100644 src/advection/slt/pdelb0.F90 delete mode 100644 src/advection/slt/phcs.F90 delete mode 100644 src/advection/slt/plevs0.F90 delete mode 100644 src/advection/slt/qmassa.F90 delete mode 100644 src/advection/slt/qmassd.F90 delete mode 100644 src/advection/slt/reordp.F90 delete mode 100644 src/advection/slt/scm0.F90 delete mode 100644 src/advection/slt/xqmass.F90 delete mode 100644 src/dynamics/eul/bndexch.F90 delete mode 100644 src/dynamics/eul/commap.F90 delete mode 100644 src/dynamics/eul/comspe.F90 delete mode 100644 src/dynamics/eul/comsta.h delete mode 100644 src/dynamics/eul/courlim.F90 delete mode 100644 src/dynamics/eul/cubxdr.F90 delete mode 100644 src/dynamics/eul/cubydr.F90 delete mode 100644 src/dynamics/eul/cubzdr.F90 delete mode 100644 src/dynamics/eul/diag_dynvar_ic.F90 delete mode 100644 src/dynamics/eul/dp_coupling.F90 delete mode 100644 src/dynamics/eul/dycore.F90 delete mode 100644 src/dynamics/eul/dycore_budget.F90 delete mode 100644 src/dynamics/eul/dyn.F90 delete mode 100644 src/dynamics/eul/dyn_comp.F90 delete mode 100644 src/dynamics/eul/dyn_grid.F90 delete mode 100644 src/dynamics/eul/dyndrv.F90 delete mode 100644 src/dynamics/eul/dynpkg.F90 delete mode 100644 src/dynamics/eul/eul_control_mod.F90 delete mode 100644 src/dynamics/eul/grcalc.F90 delete mode 100644 src/dynamics/eul/grmult.F90 delete mode 100644 src/dynamics/eul/hdinti.F90 delete mode 100644 src/dynamics/eul/herxin.F90 delete mode 100644 src/dynamics/eul/heryin.F90 delete mode 100644 src/dynamics/eul/herzin.F90 delete mode 100644 src/dynamics/eul/hordif.F90 delete mode 100644 src/dynamics/eul/hrintp.F90 delete mode 100644 src/dynamics/eul/interp_mod.F90 delete mode 100644 src/dynamics/eul/iop.F90 delete mode 100644 src/dynamics/eul/lagyin.F90 delete mode 100644 src/dynamics/eul/limdx.F90 delete mode 100644 src/dynamics/eul/limdy.F90 delete mode 100644 src/dynamics/eul/limdz.F90 delete mode 100644 src/dynamics/eul/linemsdyn.F90 delete mode 100644 src/dynamics/eul/massfix.F90 delete mode 100644 src/dynamics/eul/parslt.h delete mode 100644 src/dynamics/eul/pmgrid.F90 delete mode 100644 src/dynamics/eul/prognostics.F90 delete mode 100644 src/dynamics/eul/pspect.F90 delete mode 100644 src/dynamics/eul/quad.F90 delete mode 100644 src/dynamics/eul/realloc4.F90 delete mode 100644 src/dynamics/eul/realloc7.F90 delete mode 100644 src/dynamics/eul/restart_dynamics.F90 delete mode 100644 src/dynamics/eul/scan2.F90 delete mode 100644 src/dynamics/eul/scandyn.F90 delete mode 100644 src/dynamics/eul/scanslt.F90 delete mode 100644 src/dynamics/eul/scmforecast.F90 delete mode 100644 src/dynamics/eul/settau.F90 delete mode 100644 src/dynamics/eul/spegrd.F90 delete mode 100644 src/dynamics/eul/spetru.F90 delete mode 100644 src/dynamics/eul/sphdep.F90 delete mode 100644 src/dynamics/eul/spmd_dyn.F90 delete mode 100644 src/dynamics/eul/stats.F90 delete mode 100644 src/dynamics/eul/stepon.F90 delete mode 100644 src/dynamics/eul/tfilt_massfix.F90 delete mode 100644 src/dynamics/eul/trjmps.F90 delete mode 100644 src/dynamics/eul/tstep.F90 diff --git a/bld/config_files/definition.xml b/bld/config_files/definition.xml index 0b7b6bca45..eeee8504a2 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 = Coupling framework: mct or nuopc. Default: mct. - -Dynamics package: eul, fv, fv3, se, or mpas. + +Dynamics package: fv, fv3, se, or mpas. Switch to turn on waccm physics: 0 => no, 1 => yes. @@ -148,15 +148,15 @@ Modifications that allow perturbation growth testing: 0=off, 1=on. 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. Single column IOP -Supported for Eulerian and SE dycores. +Only supported for SE dycore. 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. Horizontal grid specifier. The recognized values depend on @@ -195,15 +195,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. - -Maximum Fourier wavenumber. - - -Highest degree of the Legendre polynomials for m=0. - - -Highest degree of the associated Legendre polynomials. - Maximum number of columns in a chunk (physics data structure). 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 @@ - - - - - - - - - diff --git a/bld/configure b/bld/configure index 9bee5d2077..a0f44bd467 100755 --- a/bld/configure +++ b/bld/configure @@ -78,7 +78,7 @@ OPTIONS -cppdefs A string of user specified CPP defines. Appended to Makefile defaults. E.g. -cppdefs '-DVAR1 -DVAR2' -cpl Coupling framework [mct | nuopc]. Default: mct. - -dyn Dynamical core option: [eul | fv | se | fv3 | mpas]. Default: fv. + -dyn 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 Specify horizontal grid. Use nlatxnlon for spectral grids; dlatxdlon for fv grids (dlat and dlon are the grid cell size @@ -123,7 +123,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 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 ]. @@ -700,14 +699,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); @@ -1222,10 +1213,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 } @@ -1239,10 +1230,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 } @@ -1256,9 +1247,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'; } @@ -1934,12 +1922,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'; } @@ -2358,11 +2340,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"; @@ -2539,9 +2516,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 ); @@ -2570,26 +2547,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/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 @@ - - - - - 10101 - - -atm/cam/inic/gaus/DABIp2004.128x256.L30.nc -atm/cam/inic/gaus/DABIp2004.128x256.L60.nc -atm/cam/inic/gaus/DABIp2004.64x128.L30.nc - - -.false. - - - 9.806D0 - 6.371D6 - - 86165.45950602833D0 - - 28.97027035191638D0 - - 1004.5D0 - - - 2 - 1 - 7.D5 - 0 - - -.true. -'I' --24 -30 - - 'U','V','T','PS','OMEGA' - - - 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 2ab0a50558..cd53700caf 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -12,7 +12,7 @@ CAM cam6 physics: CAM cam5 physics: CAM cam4 physics: - CAM simplified and non-versioned physics : + CAM simplified and non-versioned physics : CAM dry adiabatic configurarion (no physics forcing): - CAM dry adiabatic baroclinic instability (Polvani et al., 2004): CAM moist Held-Suarez forcing (Thatcher and Jablonowski, 2016): CAM moist simple model (Frierson, 2006): CAM dry Held-Suarez forcing (Held and Suarez (1994)): @@ -111,10 +110,9 @@ char - eul,fv,fv3,se,mpas + fv,fv3,se,mpas fv - eul se fv3 mpas @@ -195,7 +193,6 @@ -phys adiabatic - -phys adiabatic -phys tj2016 -analytic_ic -phys grayrad -analytic_ic -phys held_suarez -analytic_ic @@ -314,7 +311,6 @@ sd_trop_strat2_cam6 sd_cam6 - dabi_p2004 held_suarez_1994 dctest_tj2016 dctest_frierson diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index c04f925dda..cd3a6d405b 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -89,20 +89,9 @@ - - FDABIP04 - 2000_CAM%DABIP04_SLND_SICE_SOCN_SROF_SGLC_SWAV - - - - - FHS94 2000_CAM%HS94_SLND_SICE_SOCN_SROF_SGLC_SWAV - - - @@ -123,103 +112,86 @@ FSCAMARM95 2000_CAM60%FSCAMARM95_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMARM97 2000_CAM60%SCAMARM97_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMATEX 2000_CAM60%SCAMATEX_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMBOMEX 2000_CAM60%SCAMBOMEX_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMCGILSS11 2000_CAM60%SCAMCGILSS11_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMCGILSS12 2000_CAM60%SCAMCGILSS12_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMCGILSS6 2000_CAM60%SCAMCGILSS6_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMDYCOMSRF01 2000_CAM60%SCAMDYCOMSRF01_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMDYCOMSRF02 2000_CAM60%SCAMDYCOMSRF02_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMGATE3 2000_CAM60%SCAMGATE3_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMMPACE 2000_CAM60%SCAMMPACE_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMRICO 2000_CAM60%SCAMRICO_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMSPARTICUS 2000_CAM60%SCAMSPARTICUS_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMTOGA2 2000_CAM60%SCAMTOGA2_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMTWP06 2000_CAM60%SCAMTWP06_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FSCAMCAMFRC 2000_CAM60%SCAMCAMFRC_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FCSCAM 2000_CAM60%SCAM%CT1S_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index c95f004d25..21572bdb98 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -322,37 +322,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1138,17 +1107,6 @@ - - - - - - - - - - - @@ -1159,17 +1117,6 @@ - - - - - - - - - - - @@ -1179,37 +1126,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1355,18 +1271,6 @@ - - - - - - - - - - - - @@ -1416,36 +1320,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1462,28 +1336,6 @@ - - - - - - - - - - - - - - - - - - - - - - diff --git a/doc/ChangeLog b/doc/ChangeLog index 746fead140..7ab015d919 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,110 @@ =============================================================== +Tag name: +Originator(s): eaton +Date: +One-line Summary: remove Eulerian dycore +Github PR URL: + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + +Describe any changes made to build system: + +Describe any changes made to the namelist: + +List any changes to the defaults for the boundary datasets: + +Describe any substantial timing or memory changes: + +Code reviewed by: + +List all files eliminated: + +bld/namelist_files/use_cases/dabi_p2004.xml +. removed. Is only set up for Eul 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: + +List all existing files that have been modified, and describe the changes: + +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 + +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. + +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: + +derecho/nvhpc/aux_cam: + +izumi/nag/aux_cam: + +izumi/gnu/aux_cam: + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers, i.e., +- what code configurations: +- what platforms/compilers: +- nature of change (roundoff; larger than roundoff but same climate; new + climate): + +If bitwise differences were observed, how did you show they were no worse +than roundoff? + +If this tag changes climate describe the run(s) done to evaluate the new +climate in enough detail that it(they) could be reproduced, i.e., +- source tag (all code used must be in the repository): +- platform/compilers: +- configure commandline: +- build-namelist command (or complete namelist): +- MSS location of output: + +MSS location of control simulations used to validate new climate: + +URL for AMWG diagnostics output used to validate new climate: + +=============================================================== +=============================================================== + Tag name: cam6_4_047 Originator(s): jedwards4b, fvitt Date: 19 November 2024 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/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 - -! -! 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 -!------------------------------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 -!------------------------------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 -!------------------------------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 -!------------------------------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 -!------------------------------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 -!------------------------------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 -!------------------------------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 -!------------------------------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 -!------------------------------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 -!----------------------------------------------------------------------- -! -! 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 - -!------------------------------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 -!---------------------------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)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 - -!------------------------------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)= 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)= 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 -! -! 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 - From d6e02407ce0cfdee74651752720c0eaf3c0505e0 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 27 Dec 2024 10:37:34 -0500 Subject: [PATCH 2/4] remove eulerian options from namelist; start removing control logic --- bld/build-namelist | 21 --- bld/namelist_files/namelist_defaults_cam.xml | 144 ------------------ bld/namelist_files/namelist_definition.xml | 101 ------------ .../use_cases/held_suarez_1994.xml | 10 -- doc/ChangeLog | 35 +++++ src/control/cam_budget.F90 | 2 +- src/control/cam_control_mod.F90 | 2 +- src/control/cam_history_support.F90 | 2 +- src/control/history_scam.F90 | 6 +- src/control/ncdio_atm.F90 | 4 +- src/control/scamMod.F90 | 2 +- test/system/TR8.sh | 4 - 12 files changed, 42 insertions(+), 291 deletions(-) diff --git a/bld/build-namelist b/bld/build-namelist index 66c3574a62..9bf92151a8 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -4059,27 +4059,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/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 462570da4a..d9f8db1ae6 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -3,14 +3,6 @@ -1200 -300 -600 -1200 -1800 -1800 -1800 - 1800 300 @@ -201,27 +193,6 @@ atm/waccm/ic/f2000.waccm-mam3_C48_L70.cam2.i.0017-01-01_c200625.nc atm/waccm/ic/f2000.waccm-mam3_C96_L70.cam2.i.0017-01-01_c200625.nc -atm/cam/inic/gaus/T341clim01.cam2.i.0024-01-01-00000.nc -atm/cam/inic/gaus/cami_0000-01-01_256x512_L26_c030918.nc - -atm/cam/inic/gaus/cami_0000-01-01_128x256_L26_c030918.nc -atm/cam/inic/gaus/cami_0000-09-01_128x256_L26_c040422.nc - -atm/cam/inic/gaus/cami_0000-01-01_64x128_T42_L26_c031110.nc -atm/cam/inic/gaus/cami_0000-09-01_64x128_L26_c030918.nc -atm/cam/inic/gaus/cami_0000-01-01_64x128_L30_c090102.nc -atm/cam/inic/gaus/cami_0000-09-01_64x128_L30_c031210.nc -atm/cam/inic/gaus/cami_0000-01-01_64x128_L32_c170510.nc -atm/cam/inic/gaus/cami_0000-01-01_64x128_L32_c170510.nc -atm/cam/inic/gaus/cami_0000-01-01_48x96_L26_c091218.nc -atm/cam/inic/gaus/cami_0000-09-01_48x96_L26_c040420.nc -atm/cam/inic/gaus/cami_0000-01-01_48x96_L30_c100426.nc -atm/cam/inic/gaus/cami_0000-09-01_32x64_L26_c030918.nc -atm/cam/inic/gaus/cami_0000-01-01_32x64_L30_c090107.nc -atm/cam/inic/gaus/cami_0000-01-01_8x16_L26_c030228.nc -atm/cam/inic/gaus/cami_0000-09-01_8x16_L26_c030918.nc -atm/cam/inic/gaus/cami_0000-01-01_8x16_L30_c090102.nc - atm/cam/inic/se/FCts4MTHIST_ne3pg3_spinup02.cam.i.1980-01-01_c240702.nc atm/cam/inic/se/cam6_QPC6_topo_ne3pg3_mg37_L32_01-01-31_c221214.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-09-01-00000.nc @@ -294,13 +265,6 @@ atm/cam/inic/mpas/cami_01-01-2000_00Z_mpasa120_L93_CFSR_c240814.nc -atm/cam/topo/topo-from-cami_0000-01-01_256x512_L26_c030918.nc -atm/cam/topo/USGS-gtopo30_128x256_c050520.nc -atm/cam/topo/T42_nc3000_Co060_Fi001_PF_nullRR_Nsw042_20180111.nc -atm/cam/topo/USGS-gtopo30_48x96_c050520.nc -atm/cam/topo/USGS-gtopo30_32x64_c050520.nc -atm/cam/topo/USGS-gtopo30_8x16_c050520.nc - atm/cam/topo/USGS_gtopo30_0.23x0.31_remap_c061107.nc atm/cam/topo/USGS_gtopo30_0.47x0.63_remap_c061106.nc atm/cam/topo/fv_0.47x0.63_nc3000_Co030_Fi001_PF_nullRR_Nsw021_20171023.nc @@ -718,24 +682,6 @@ atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_175001-201512_fv_1.9x2.5_c20181011.nc atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_175001-201512_fv_1.9x2.5_c20181011.nc - -atm/cam/scyc/DMS_emissions_128x256_clim_c040122.nc -atm/cam/scyc/DMS_emissions_64x128_c030722.nc -atm/cam/scyc/DMS_emissions_32x64_c030722.nc -atm/cam/scyc/DMS_emissions_4x5_noncon_c050306.nc - - -atm/cam/scyc/oxid_128x256_L26_clim_c040112.nc -atm/cam/scyc/oxid_3d_64x128_L26_c030722.nc -atm/cam/scyc/oxid_3d_32x64_L26_c030722.nc -atm/cam/scyc/oxid_4x5_L26_noncon_c050306.nc - - -atm/cam/scyc/SOx_emissions_128x256_L2_1850-2000_c040321.nc -atm/cam/scyc/SOx_emissions_64x128_L2_c030722.nc -atm/cam/scyc/SOx_emissions_32x64_L2_c030722.nc -atm/cam/scyc/SOx_emissions_4x5_noncon_c050306.nc - atm/cam/ggas/noaamisc.r8.nc @@ -2048,12 +1994,6 @@ atm/cam/chem/trop_mozart/ub/ubvals_b40.20th.track1_1996-2005_c110315.nc - - -atm/cam/rad/carbon_penner_cooke_doubled_64x128_c021120.nc -atm/cam/rad/carbon_penner_cooke_doubled_32x64_c021120.nc -atm/cam/rad/carbon_penner_cooke_doubled_4x5_c021120.nc - atm/cam/dst/dst_source2x2tunedcam6-2x2-04062017.nc atm/cam/dst/dst_source2x2_cam5.4_c150327.nc @@ -2069,7 +2009,6 @@ .true. 0.075D0 - 0.100D0 0.100D0 1.0D0 @@ -2688,9 +2627,6 @@ 0.920D0 0.913D0 - 0.903D0 - 0.905D0 - 0.880D0 0.910D0 0.100D0 @@ -2702,12 +2638,8 @@ 0.770D0 0.700D0 0.770D0 - 0.500D0 0.900D0 0.900D0 - 0.680D0 - 0.680D0 - 0.650D0 0.07D0 0.04D0 @@ -2729,16 +2661,10 @@ 25000.0D0 25000.0D0 25000.0D0 - 25000.0D0 - 25000.0D0 - 25000.0D0 40000.0D0 40000.0D0 40000.0D0 40000.0D0 - 40000.0D0 - 40000.0D0 - 40000.0D0 40000.0D0 750.0D2 @@ -2803,10 +2729,6 @@ 9.5e-6 9.5e-6 - 30.0e-6 - 20.0e-6 - 16.0e-6 - 1.0e-6 18.0e-6 4.0e-4 @@ -2816,13 +2738,9 @@ 10.0e-6 5.0e-6 - 5.0e-6 - 5.0e-6 - 5.0e-6 5.0e-6 10.0e-6 - 1.0e-6 1800.0D0 @@ -2833,10 +2751,6 @@ 2.0e-4 2.0e-4 - 1.0e-5 - 1.0e-5 - 1.0e-4 - 1.0e-4 1.0e-4 @@ -2873,10 +2787,6 @@ 0.0075D0 0.0035D0 0.0035D0 - 0.0020D0 - 0.0040D0 - 0.0040D0 - 0.0040D0 0.0030D0 0.0450D0 @@ -2894,10 +2804,6 @@ 0.0300D0 0.0035D0 0.0035D0 - 0.0020D0 - 0.0040D0 - 0.0040D0 - 0.0040D0 3.0E-6 1.0E-5 @@ -2906,9 +2812,6 @@ 3.0E-6 5.0E-6 5.0E-6 - 5.0E-6 - 5.0E-6 - 5.0E-6 .false. .true. @@ -3012,64 +2915,52 @@ atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/ARM95_4scam.nc 368.9e-6 atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/ARM97_4scam.nc 368.9e-6 atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-02-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-02-01-00000.nc atm/cam/scam/iop/ATEX_48hr_4scam.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/BOMEX_5day_4scam.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/S11_CTL_MixedLayerInit_reduced.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/S12_CTL_MixedLayerInit_reduced.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/S6_CTL_reduced.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/DYCOMSrf01_4day_4scam.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/DYCOMSrf02_48hr_4scam.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-08-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-08-01-00000.nc atm/cam/scam/iop/GATEIII_4scam_c170809.nc atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.ne3np4.nc -atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.Gaus_64x128.nc atm/cam/scam/iop/micre2017_3mo.macquarie2017.iop.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-10-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-10-01-00000.nc atm/cam/scam/iop/MPACE_4scam.nc 'CLDST', 'CNVCLD', @@ -3086,12 +2977,10 @@ atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/RICO_3day_4scam.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/SAS_ideal_4scam.nc 368.9e-6 .false. @@ -3099,56 +2988,23 @@ atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-04-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-04-01-00000.nc atm/cam/scam/iop/SPARTICUS_4scam.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-12-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-12-01-00000.nc atm/cam/scam/iop/TOGAII_4scam.nc atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-01-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-01-01-00000.nc atm/cam/scam/iop/TWP06_4scam.nc 1 1 atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc -atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/ARM97_4scam.nc - - - 2.5D5 - 2.5D7 - - - 4 - - 4 - - 1.0D18 - 2.0D16 - 2.0D16 - 1.17D16 - 7.14D14 - 1.5D14 - 1.5D13 - - 0.0D0 - 0.06D0 - 5 - - 1 - 12 - - -atm/cam/scam/iop/ARM95_4scam.nc - - 3 2 diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index bd003c779a..9a9e00d47e 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 - - - -del^2 horizontal diffusion coefficient. This is used above the Nth order -diffusion. -Default: set by build-namelist - - - -Order (N) of horizontal diffusion operator used below the sponge layers. -N must be a positive multiple of 2. -Default: 4 - - - -The order N horizontal diffusion operator will be used in and below the -layer specified by this variable. -Default: 4 - - - -Nth order horizontal diffusion coefficient. -Default: set by build-namelist - - - -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. - - - -Time filter coefficient. Default: 0.06 - - - -Number of levels over which to apply Courant limiter, starting at top of -model. -Default: 5 - - - -Number of dynamics timesteps per physics timestep. If zero, a best-estimate -will be automatically calculated. -Default: 1 - - - - - -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 - - - -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 - - - -Flag indicating whether to assign latitudes to equidistribute columns or -latitudes. This only matters when using a reduced grid. -Default: TRUE - - - -Number of processes assigned to dynamics (SE, EUL and SLD dycores). -Default: Total number of processes assigned to job. - - - -Stride for dynamics processes (EUL and SLD dycores). -E.g., if stride=2, assign every second process to the dynamics. -Default: 1 - - 10101 - -atm/cam/inic/gaus/HS1994.128x256.L30_c062216.nc -atm/cam/inic/gaus/HS1994.128x256.L60_c061516.nc -atm/cam/inic/gaus/HS1994.64x128.L30_c061616.nc - 1.0D-5 - - 4 - 1.17D16 - 7.14D14 - 0,-6 diff --git a/doc/ChangeLog b/doc/ChangeLog index 7ab015d919..d01d84f087 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -8,7 +8,10 @@ Github PR URL: Purpose of changes (include the issue number and title text for each relevant GitHub issue): +Resolve issue #1170 - Remove Eulerian dycore from cam_development + Describe any changes made to build system: +. remove option to build 'eul' dycore Describe any changes made to the namelist: @@ -33,6 +36,9 @@ List all files added and what they do: 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. @@ -46,6 +52,17 @@ bld/config_files/definition.xml 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 + cime_config/buildcpp . remove the translations for the Eulerian atm_grid values, e.g., CESM specified T5 but CAM's configure expected 8x16. @@ -65,6 +82,24 @@ 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. +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). + + +test/system/TR8.sh +. remove filepaths for 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 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 940dc8c177..cd8d991b71 100644 --- a/src/control/cam_history_support.F90 +++ b/src/control/cam_history_support.F90 @@ -298,7 +298,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/test/system/TR8.sh b/test/system/TR8.sh index cbdb400463..9247b75a65 100755 --- a/test/system/TR8.sh +++ b/test/system/TR8.sh @@ -77,8 +77,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` @@ -90,8 +88,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` From 5a422de1686f171ee1953e62697b36a6b39f399a Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 27 Dec 2024 12:50:39 -0500 Subject: [PATCH 3/4] remove/fix old comments; remove control logic for EUL --- .../testmods_dirs/cam/ghgrmp_e8/user_nl_cam | 2 - doc/ChangeLog | 47 +++++++++++-------- src/dynamics/se/dycore/interpolate_mod.F90 | 2 +- src/physics/cam/cam_diagnostics.F90 | 20 +++----- src/physics/cam/geopotential.F90 | 2 +- src/physics/cam/physics_types.F90 | 6 +-- src/physics/cam/physpkg.F90 | 10 ++-- src/physics/cam7/physpkg.F90 | 10 ++-- src/physics/camrt/radiation.F90 | 2 +- src/physics/simple/physpkg.F90 | 4 +- src/utils/cam_grid_support.F90 | 3 -- src/utils/cam_pio_utils.F90 | 2 +- src/utils/spmd_utils.F90 | 4 +- 13 files changed, 50 insertions(+), 64 deletions(-) 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 d01d84f087..88a9a92ec8 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -82,6 +82,9 @@ 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 @@ -96,6 +99,29 @@ src/control/ncdio_atm.F90 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/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 @@ -116,26 +142,7 @@ izumi/gnu/aux_cam: CAM tag used for the baseline comparison tests if different than previous tag: -Summarize any changes to answers, i.e., -- what code configurations: -- what platforms/compilers: -- nature of change (roundoff; larger than roundoff but same climate; new - climate): - -If bitwise differences were observed, how did you show they were no worse -than roundoff? - -If this tag changes climate describe the run(s) done to evaluate the new -climate in enough detail that it(they) could be reproduced, i.e., -- source tag (all code used must be in the repository): -- platform/compilers: -- configure commandline: -- build-namelist command (or complete namelist): -- MSS location of output: - -MSS location of control simulations used to validate new climate: - -URL for AMWG diagnostics output used to validate new climate: +Summarize any changes to answers: BFB =============================================================== =============================================================== 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 97dad2ba01..2a3d15597c 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 @@ -365,9 +363,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 @@ -2057,14 +2053,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/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 ba36670ce8..5ee357769e 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -2253,12 +2253,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_fix(state, ptend, nstep, flx_heat) - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) - call outfld( 'EFIX', flx_heat , pcols, lchnk ) - end if + call check_energy_fix(state, ptend, nstep, flx_heat) + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) + call outfld( 'EFIX', flx_heat , pcols, lchnk ) 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 83d03c46d1..94b45c963b 100644 --- a/src/physics/cam7/physpkg.F90 +++ b/src/physics/cam7/physpkg.F90 @@ -2698,12 +2698,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_fix(state, ptend, nstep, flx_heat) - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) - call outfld( 'EFIX', flx_heat , pcols, lchnk ) - end if + call check_energy_fix(state, ptend, nstep, flx_heat) + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) + call outfld( 'EFIX', flx_heat , pcols, lchnk ) 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 8c9c1586ef..43cbbbce4f 100644 --- a/src/physics/simple/physpkg.F90 +++ b/src/physics/simple/physpkg.F90 @@ -613,7 +613,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) @@ -830,7 +830,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_fix(state, ptend, nstep, flx_heat) call physics_update(state, ptend, ztodt, tend) call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) 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 350c421539..1195c43529 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 ) From 97ffeb9573c8ba492fedc7445481e804434551b1 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 30 Dec 2024 10:19:35 -0500 Subject: [PATCH 4/4] fix TR8.sh; update ChangeLog --- doc/ChangeLog | 4 ++-- test/system/TR8.sh | 4 ---- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 88a9a92ec8..aea822afc5 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -32,7 +32,7 @@ src/advection/* src/dynamics/eul/* . remove Eulerian dycore code. -List all files added and what they do: +List all files added and what they do: none List all existing files that have been modified, and describe the changes: @@ -124,7 +124,7 @@ src/utils/spmd_utils.F90 . remove old comment(s) test/system/TR8.sh -. remove filepaths for eul dycore +. remove filepaths for eul dycore and advection. 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, diff --git a/test/system/TR8.sh b/test/system/TR8.sh index 9247b75a65..958af1defc 100755 --- a/test/system/TR8.sh +++ b/test/system/TR8.sh @@ -96,8 +96,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 @@ -105,8 +103,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