From 7f21b624dc1d464dbcbfbf36dbf095b8a24e2108 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 9 Oct 2025 10:22:07 -0400 Subject: [PATCH] v12: Remove ARIES and LatLot dynamics GCs --- .../ARIESg3_GridComp/ARIESg3_GridCompMod.F90 | 6107 ---------------- .../ARIESg3_GridComp/CMakeLists.txt | 37 - .../ARIESg3_GridComp/FVdycore_arch.mk | 39 - .../ARIESg3_GridComp/dynamics_vars.F90 | 2289 ------ .../ARIESg3_GridComp/fft99.F90 | 1207 ---- .../ARIESg3_GridComp/g3_dycore.F | 2012 ------ .../g3_dynamics_lattice_module.F | 108 - .../g3_dynamics_state_module.F | 133 - .../ARIESg3_GridComp/g3_fft.F | 456 -- .../ARIESg3_GridComp/g3_gcmutil.F | 259 - .../ARIESg3_GridComp/g3_grids.F | 3253 --------- .../ARIESg3_GridComp/g3_mpi_util.F | 45 - .../ARIESg3_GridComp/g3_mymalloc.F | 262 - .../ARIESg3_GridComp/g3_mymalloc_interface | 69 - .../ARIESg3_GridComp/g3_wrapper.F | 1041 --- .../ARIESg3_GridComp/gmap.F90 | 516 -- .../ARIESg3_GridComp/par_xsum.F90 | 167 - .../ARIESg3_GridComp/pft_module.F90 | 467 -- .../ARIESg3_GridComp/remap.F90 | 158 - .../ARIESg3_GridComp/shr_kind_mod.F90 | 27 - .../GEOSsuperdyn_GridComp/CMakeLists.txt | 2 - .../FVdycore_GridComp/BlendingMod.F90 | 195 - .../FVdycore_GridComp/CMakeLists.txt | 22 - .../FVdycore_GridCompMod.F90 | 6242 ----------------- .../FVdycore_GridComp/FVdycore_arch.mk | 17 - .../FVdycore_GridComp/FVdycore_dynamics.rc | 6 - .../FVdycore_GridComp/FVdycore_wrapper.F90 | 2073 ------ .../FVdycore_GridComp/FVperf_module.F90 | 143 - .../FVdycore_GridComp/G3_AVRX.F90 | 245 - .../FVdycore_GridComp/benergy.F90 | 377 - .../FVdycore_GridComp/cd_core.F90 | 1246 ---- .../FVdycore_GridComp/diag_module.F90 | 221 - .../FVdycore_GridComp/dynamics_vars.F90 | 2305 ------ .../FVdycore_GridComp/epvd.F90 | 271 - .../FVdycore_GridComp/fft99.F90 | 1207 ---- .../FVdycore_GridComp/fill_module.F90 | 584 -- .../FVdycore_GridComp/geopk.F90 | 630 -- .../FVdycore_GridComp/glosum.F90 | 114 - .../FVdycore_GridComp/gmap.F90 | 516 -- .../FVdycore_GridComp/mapz_module.F90 | 1334 ---- .../FVdycore_GridComp/mfz_comp.F90 | 309 - .../FVdycore_GridComp/par_vecsum.F90 | 91 - .../FVdycore_GridComp/par_xsum.F90 | 167 - .../FVdycore_GridComp/pft_module.F90 | 467 -- .../FVdycore_GridComp/pkez.F90 | 187 - .../FVdycore_GridComp/pmaxmin.F90 | 65 - .../FVdycore_GridComp/remap.F90 | 158 - .../FVdycore_GridComp/shr_kind_mod.F90 | 27 - .../FVdycore_GridComp/sw_core.F90 | 1315 ---- .../FVdycore_GridComp/te_map.F90 | 1213 ---- .../FVdycore_GridComp/tp_core.F90 | 2644 ------- .../FVdycore_GridComp/trac2d.F90 | 455 -- 52 files changed, 43500 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/ARIESg3_GridCompMod.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/CMakeLists.txt delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/FVdycore_arch.mk delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/dynamics_vars.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/fft99.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dycore.F delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_lattice_module.F delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_state_module.F delete mode 100755 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_fft.F delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_gcmutil.F delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_grids.F delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mpi_util.F delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc.F delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc_interface delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_wrapper.F delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/gmap.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/par_xsum.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/pft_module.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/remap.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/shr_kind_mod.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/BlendingMod.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/CMakeLists.txt delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_GridCompMod.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_arch.mk delete mode 100755 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_dynamics.rc delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_wrapper.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVperf_module.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/G3_AVRX.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/benergy.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/cd_core.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/diag_module.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/dynamics_vars.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/epvd.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fft99.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fill_module.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/geopk.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/glosum.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/gmap.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/mapz_module.F90 delete mode 100755 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/mfz_comp.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_vecsum.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_xsum.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pft_module.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pkez.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pmaxmin.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/remap.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/shr_kind_mod.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/sw_core.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/te_map.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/tp_core.F90 delete mode 100644 GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/trac2d.F90 diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/ARIESg3_GridCompMod.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/ARIESg3_GridCompMod.F90 deleted file mode 100644 index 48774fbc9..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/ARIESg3_GridCompMod.F90 +++ /dev/null @@ -1,6107 +0,0 @@ -! $Id: ARIESg3_GridCompMod.F90,v 1.19.112.1.2.1 2019/07/23 15:31:37 mmanyin Exp $ - -#include "MAPL_Generic.h" - - - -!----------------------------------------------------------------------- -! ESMA - Earth System Modeling Applications -!----------------------------------------------------------------------- - Module ARIESg3_GridCompMod - -!BOP -! -! !MODULE: ARIESg3_GridCompMod --- ARIESr/GEOS3 Dynamical Core Grid Component -! - - -! !USES: - - use ESMF ! ESMF base class - use MAPL ! GEOS base class - use dynamics_vars, only : T_TRACERS, T_FVDYCORE_VARS, & - T_FVDYCORE_GRID, T_FVDYCORE_STATE - -! !PUBLIC MEMBER FUNCTIONS: - - implicit none - private - - public SetServices ! Register component methods - -! !DESCRIPTION: This module implements the FVCAM Dynamical Core as -! an ESMF gridded component. -! -! \paragraph*{Overview} -! -! This module contains an ESMF wrapper for the Finite-Volume -! Dynamical Core used in the Community Atmospheric Model -! (FVCAM). This component will hereafter be referred -! to as the ``FVdycore'' ESMF gridded component. FVdycore -! consists of four sub-components, -! -! \begin{itemize} -! \item {\tt cd\_core:} The C/D-grid dycore component -! \item {\tt te\_map:} Vertical remapping algorithm -! \item {\tt trac2d:} Tracer advection -! \item {\tt benergy:} Energy balance -! \end{itemize} -! -! Subsequently the ESMF component design for FV dycore -! will be described. -! -! \paragraph*{Internal State} -! -! FVdycore maintains an internal state consisting of the -! following fields: control variables -! -! \begin{itemize} -! \item {\tt U}: U winds on a D-grid (m/s) -! \item {\tt V}: V winds on a D-grid (m/s) -! \item {\tt PT}: Scaled Virtual Potential Temperature(T$_v$/PKZ) -! \item {\tt PE}: Edge pressures -! \item {\tt Q}: Tracers -! \item {\tt PKZ}: Consistent mean for p$^\kappa$ -! \end{itemize} -! -! as well as a GRID (to be mentioned later) -! and same additional run-specific variables -! (dt, iord, jord, nsplit -- to be mentioned later) -! -! Note: {\tt PT} is not updated if the flag {\tt CONVT} is true. -! -! The internal state is updated each time FVdycore is called. -! -! \paragraph*{Import State} -! -! The import state consists of the tendencies of the -! control variables plus the surface geopotential heights: -! -! \begin{itemize} -! \item {\tt DUDT}: U wind tendency on a A-grid (m/s) -! \item {\tt DVDT}: V wind tendency on a A-grid (m/s) -! \item {\tt DTDT}: Delta-pressure-weighted temperature tendency -! \item {\tt DPEDT}: Edge pressure tendency -! \item {\tt PHIS}: Surface Geopotential Heights -! \end{itemize} -! -! These are by definition on an A-grid and have an XY -! domain decomposition. -! -! \paragraph*{Export State} -! -! The export state can provide the following variables: -! -! \begin{itemize} -! \item {\tt U}: U winds on a A-grid (m/s) -! \item {\tt V}: V winds on a A-grid (m/s) -! \item {\tt U\_CGRID}: U winds on a C-grid (m/s) -! \item {\tt V\_CGRID}: V winds on a C-grid (m/s) -! \item {\tt U\_DGRID}: U winds on a D-grid (m/s) -! \item {\tt V\_DGRID}: V winds on a D-grid (m/s) -! \item {\tt T}: Temperature (K) -! \item {\tt Q}: Tracers -! \item {\tt TH}: Potential Temperature (K) -! \item {\tt ZL}: Mid-Layer Heights (m) -! \item {\tt ZLE}: Edge Heights (m) -! \item {\tt PLE}: Edge pressures (Pa) -! \item {\tt PLK}: $P^\kappa$ at Mid-Layers -! \item {\tt OMEGA}: Vertical pressure velocity (pa/s) -! \item {\tt PTFX}: Mass-Weighted PT flux on C-Grid (K Pa m$^2$/s) -! \item {\tt PTFY}: Mass-Weighted PT flux on C-Grid (K Pa m$^2$/s) -! \item {\tt MFX\_UR}: Mass-Weighted U-Wind on C-Grid (Pa m$^2$/s) -! \item {\tt MFY\_UR}: Mass-Weighted V-wind on C-Grid (Pa m$^2$/s) -! \item {\tt MFX}: Remapped Mass-Weighted U-Wind on C-Grid (Pa m$^2$/s) -! \item {\tt MFY}: Remapped Mass-Weighted V-wind on C-Grid (Pa m$^2$/s) -! \item {\tt MFZ}: Remapped Vertical mass flux (kg/(m$^2$*s)) -! \item {\tt MFX\_A}: Remapped Mass-Weighted U-Wind on A-Grid (Pa m$^2$/s) -! \item {\tt MFY\_A}: Remapped Mass-Weighted V-wind on A-Grid (Pa m$^2$/s) -! \item {\tt PV}: Ertel's Potential Vorticity (m$^2$ / kg*s) -! \item {\tt DUDT}: U-wind Tendency (m/s/s) -! \item {\tt DVDT}: V-wind Tendency (m/s/s) -! \item {\tt DTDT}: Mass-Weighted Temperature Tendency (Pa K/s) -! \item {\tt AREA}: Cell areas on the A-Grid (m$^2$, polar caps at J=1, J=JM) -! \end{itemize} -! -! All variables are on an A-grid with points at the poles, and have an XY decomposition. -! -! \paragraph*{Grids and Decompositions} -! -! The current version supports only a 1D latitude-based -! decomposition of the domain (with OMP task-parallelism -! in the vertical, resulting in reasonable scalability -! on large PE configurations). In the near future it will -! support a 2D domain decomposition, in which import and -! export state are decomposed in longitude and latitude, -! while the internal state (for the most part) is -! decomposed in latitude and level. When needed, -! the data is redistributed (``transposed'') internally. -! -! There are two fundamental ESMF grids in use; -! \begin{itemize} -! \item {GRIDXY}: longitude-latitude ESMF grid (public) -! \item {GRIDYZ}: A latitude-level cross-sectional -! decomposition (private to this module) -! \end{itemize} -! -! PILGRIM will be used for communication until ESMF has -! sufficient functionality and performance to take over -! the task. The use of pilgrim requires a call to -! {\tt INIT\_SPMD} to set SPMD parameters, decompositions, -! etc. -! -! Currently, only a 1D decomposition in latitude is employed. -! Thus GRIDXY and GRIDYZ actually represent the same -! decomposition and no transposes are employed. -! -! \paragraph*{Required Files} -! -! The following files are needed for a standard restart run: -! -! \begin{itemize} -! \item Layout file -! \begin{itemize} -! \item {\tt nprxy\_x, nprxy\_y, npryz\_y, npryz\_z}: -! process dimensions in XY and YZ. -! \item {\tt imxy, jmxy, jmyz, kmyz}: distributions for XY and YZ -! \item {\tt iord, jord}: the order of the lon. and lat. algorithms -! \item {\tt dtime}: The large (advection) time step -! \item {\tt nsplit}: the ratio between the large and small time step -! (possibly zero for automatic determination), -! \end{itemize} -! \item Restart file -! \begin{itemize} -! \item date in standard format yy, mm, dd, hh, mm, ss -! \item dimensions im, jm, km, nq -! \item control variables {\tt U, V, PT, PE, Q} -! \end{itemize} -! \item Topography file -! -! \end{itemize} -! -! \paragraph*{Future Additions} -! -! \begin{itemize} -! \item Conservation of energy (CONSV == .TRUE. ) -! \item 2D decomposition (requires transposes in the coupler) -! \item Use r8 instead of r4 (currently supported in StopGap) -! \end{itemize} -! -!EOP - -! !REVISION HISTORY: -! -! 11Jul2003 Sawyer From Trayanov/da Silva EVAC -! 23Jul2003 Sawyer First informal tiptoe-through -! 29Jul2003 Sawyer Modifications based on comments from 23Jul2003 -! 28Aug2003 Sawyer First check-in; Internal state to D-grid -! 15Sep2003 Sawyer Extensive bug fixes, revisions -! 24Sep2003 Sawyer Modified names; corrected weighting of T, Q -! 22Oct2003 Sawyer pmgrid removed (data now in spmd_dyn) -! 25Nov2003 Sawyer Optimization for 1D decomposition (as in FVCAM) -! 03Dec2003 Sawyer Switched over to specified decompositions -! 04Dec2003 Sawyer Moved T_FVDYCORE_GRID to dynamics_vars -! 21Jan2004 Takacs Modified Import/Export, Added Generic State, Added TOPO utility -! 20Sep2004 Sawyer Revised cd_core, trac2d interfaces, refactoring -! 06Oct2004 Sawyer More refactoring, removed spmd_dyn -! 17Feb2005 Sawyer Added Ertel's potential vorticity to diagnostics -! 20Mar2005 Sawyer Tracers are now pointers into import state -! 12Apr2005 Sawyer Extensive changes to minimize tracer memory -! 18May2005 Sawyer Put FVdycore_wrapper in separate file; CAM/GEOS5 merge -! 16Nov2005 Takacs Added option for DCADJ, Merge with Daedalus_p5 -! 18Jan2006 Putman Added mass fluxes to export state -! 01Apr2009 Sawyer Upgraded to PILGRIM from cam3_6_33 -! -!---------------------------------------------------------------------- - - integer, parameter :: r8 = 8 - integer, parameter :: r4 = 4 - - real(r8), parameter :: RADIUS = MAPL_RADIUS - real(r8), parameter :: CP = MAPL_CP - real(r8), parameter :: PI = MAPL_PI_R8 - real(r8), parameter :: OMEGA = MAPL_OMEGA - real(r8), parameter :: KAPPA = MAPL_KAPPA - real(r8), parameter :: P00 = MAPL_P00 - real(r8), parameter :: GRAV = MAPL_GRAV - real(r8), parameter :: RGAS = MAPL_RGAS - real(r8), parameter :: RVAP = MAPL_RVAP - real(r8), parameter :: EPS = RVAP/RGAS-1.0 - - integer, parameter :: TIME_TO_RUN = 1 - integer, parameter :: CHECK_MAXMIN = 2 - - integer :: I, J, K ! Default declaration for loops. - -! Wrapper for extracting internal state -! ------------------------------------- - - type DYN_wrap - type (T_FVDYCORE_STATE), pointer :: DYN_STATE - end type DYN_wrap - -contains - -!---------------------------------------------------------------------- -!BOP -! -! !IROUTINE: SetServices --- Set services for FVCAM Dynamical Core - -! !INTERFACE: - - Subroutine SetServices ( gc, rc ) - -! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! gridded component - integer, intent(out), optional :: rc ! return code - - -! !DESCRIPTION: Set services (register) for the FVCAM Dynamical Core -! Grid Component. -! -!EOP -!---------------------------------------------------------------------- - - type (T_FVDYCORE_STATE), pointer :: dyn_internal_state - type (DYN_wrap) :: wrap - - integer :: status - character(len=ESMF_MAXSTR) :: IAm - character(len=ESMF_MAXSTR) :: COMP_NAME - -! Begin -!------ - - Iam = "SetServices" - call ESMF_GridCompGet( GC, name=COMP_NAME, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // Iam - -! Allocate this instance of the internal state and put it in wrapper. -! ------------------------------------------------------------------- - - allocate( dyn_internal_state, stat=status ) - VERIFY_(STATUS) - wrap%dyn_state => dyn_internal_state - -! Save pointer to the wrapped internal state in the GC -! ---------------------------------------------------- - - call ESMF_UserCompSetInternalState ( GC,'FVstate',wrap,status ) - VERIFY_(STATUS) - -!BOS -! !IMPORT STATE: - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DUDT', & - LONG_NAME = 'eastward_wind_tendency', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DVDT', & - LONG_NAME = 'northward_wind_tendency', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DTDT', & - LONG_NAME = 'delta-p_weighted_temperature_tendency', & - UNITS = 'Pa K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DQVANA', & - LONG_NAME = 'specific_humidity_vapor_increment_from_analysis', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DQLANA', & - LONG_NAME = 'specific_humidity_liquid_increment_from_analysis', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DQIANA', & - LONG_NAME = 'specific_humidity_ice_increment_from_analysis', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DOXANA', & - LONG_NAME = 'ozone_increment_from_analysis', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DPEDT', & - LONG_NAME = 'edge_pressure_tendency', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'PHIS', & - LONG_NAME = 'surface_geopotential_height', & - UNITS = 'm+2 s-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( gc, & - SHORT_NAME = 'TRADV', & - LONG_NAME = 'advected_quantities', & - UNITS = 'unknown', & - DATATYPE = MAPL_BundleItem, & - RC=STATUS ) - VERIFY_(STATUS) - -! !EXPORT STATE: - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KE', & - LONG_NAME = 'vertically_integrated_kinetic_energy', & - UNITS = 'J m-2' , & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TAVE', & - LONG_NAME = 'vertically_averaged_dry_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UAVE', & - LONG_NAME = 'vertically_averaged_zonal_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEPHY', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_physics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEPHY', & - LONG_NAME = 'total_potential_energy_tendency_due_to_physics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TEPHY', & - LONG_NAME = 'mountain_work_tendency_due_to_physics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEANA', & - LONG_NAME = 'total_kinetic_energy_tendency_due_to_analysis', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEANA', & - LONG_NAME = 'total_potential_energy_tendency_due_to_analysis', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TEANA', & - LONG_NAME = 'mountain_work_tendency_due_to_analysis', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEHOT', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_HOT', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEDP', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_pressure_change', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEADV', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_dynamics_advection', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEPG', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_pressure_gradient', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEDYN', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_dynamics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEDYN', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_dynamics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TEDYN', & - LONG_NAME = 'mountain_work_tendency_due_to_dynamics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KECDCOR', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_cdcore', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PECDCOR', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_cdcore', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TECDCOR', & - LONG_NAME = 'mountain_work_tendency_due_to_cdcore', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'QFIXER', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_CONSV', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEREMAP', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_remap', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEREMAP', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_remap', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TEREMAP', & - LONG_NAME = 'mountain_work_tendency_due_to_remap', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEGEN', & - LONG_NAME = 'vertically_integrated_generation_of_kinetic_energy', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DKERESIN', & - LONG_NAME = 'vertically_integrated_kinetic_energy_residual_from_inertial_terms', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DKERESPG', & - LONG_NAME = 'vertically_integrated_kinetic_energy_residual_from_PG_terms', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DMDTANA', & - LONG_NAME = 'vertically_integrated_mass_tendency_due_to_analysis', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DOXDTANAINT', & - LONG_NAME = 'vertically_integrated_ozone_tendency_due_to_analysis', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQVDTANAINT', & - LONG_NAME = 'vertically_integrated_water_vapor_tendency_due_to_analysis', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQLDTANAINT', & - LONG_NAME = 'vertically_integrated_liquid_water_tendency_due_to_analysis', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQIDTANAINT', & - LONG_NAME = 'vertically_integrated_ice_water_tendency_due_to_analysis', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DMDTDYN', & - LONG_NAME = 'vertically_integrated_mass_tendency_due_to_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DOXDTDYNINT', & - LONG_NAME = 'vertically_integrated_ozone_tendency_due_to_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTHVDTDYNINT', & - LONG_NAME = 'vertically_integrated_THV_tendency_due_to_dynamics', & - UNITS = 'K kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTHVDTREMAP', & - LONG_NAME = 'vertically_integrated_THV_tendency_due_to_vertical_remapping', & - UNITS = 'K kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTHVDTCONSV', & - LONG_NAME = 'vertically_integrated_THV_tendency_due_to_TE_conservation', & - UNITS = 'K kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTHVDTPHYINT', & - LONG_NAME = 'vertically_integrated_THV_tendency_due_to_physics', & - UNITS = 'K kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTHVDTANAINT', & - LONG_NAME = 'vertically_integrated_THV_tendency_due_to_analysis', & - UNITS = 'K kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQVDTDYNINT', & - LONG_NAME = 'vertically_integrated_water_vapor_tendency_due_to_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQLDTDYNINT', & - LONG_NAME = 'vertically_integrated_liquid_water_tendency_due_to_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQIDTDYNINT', & - LONG_NAME = 'vertically_integrated_ice_water_tendency_due_to_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'CONVKE', & - LONG_NAME = 'vertically_integrated_kinetic_energy_convergence', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'CONVTHV', & - LONG_NAME = 'vertically_integrated_thetav_convergence', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'CONVCPT', & - LONG_NAME = 'vertically_integrated_enthalpy_convergence', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'CONVPHI', & - LONG_NAME = 'vertically_integrated_geopotential_convergence', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U', & - LONG_NAME = 'eastward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V', & - LONG_NAME = 'northward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'T', & - LONG_NAME = 'air_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PL', & - LONG_NAME = 'mid_level_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'ZLE', & - LONG_NAME = 'edge_heights', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'ZL', & - LONG_NAME = 'mid_layer_heights', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'S', & - LONG_NAME = 'mid_layer_dry_static_energy', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PLE', & - LONG_NAME = 'edge_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TH', & - LONG_NAME = 'potential_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PLK', & - LONG_NAME = 'mid_layer_$p^\kappa$', & - UNITS = 'Pa$^\kappa$', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'OMEGA', & - LONG_NAME = 'vertical_pressure_velocity', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PTFX', & - LONG_NAME = 'pressure_weighted_eastward_potential_temperature_flux_unremapped', & - UNITS = 'K Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PTFY', & - LONG_NAME = 'pressure_weighted_northward_potential_temperature_flux_unremapped', & - UNITS = 'K Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFX_UR', & - LONG_NAME = 'pressure_weighted_eastward_wind_unremapped', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFY_UR', & - LONG_NAME = 'pressure_weighted_northward_wind_unremapped', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFX', & - LONG_NAME = 'pressure_weighted_eastward_wind', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFY', & - LONG_NAME = 'pressure_weighted_northward_wind', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFZ', & - LONG_NAME = 'vertical_mass_flux', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFX_A', & - LONG_NAME = 'zonal_mass_flux', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFY_A', & - LONG_NAME = 'meridional_mass_flux', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PV', & - LONG_NAME = 'ertels_isentropic_potential_vorticity', & - UNITS = 'm+2 kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'EPV', & - LONG_NAME = 'ertels_potential_vorticity', & - UNITS = 'K m+2 kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'Q', & - LONG_NAME = 'specific_humidity', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DUDTANA', & - LONG_NAME = 'tendency_of_eastward_wind_due_to_analysis', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DVDTANA', & - LONG_NAME = 'tendency_of_northward_wind_due_to_analysis', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTDTANA', & - LONG_NAME = 'tendency_of_air_temperature_due_to_analysis', & - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DDELPDTANA', & - LONG_NAME = 'tendency_of_pressure_thickness_due_to_analysis', & - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DUDTDYN', & - LONG_NAME = 'tendency_of_eastward_wind_due_to_dynamics', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DVDTDYN', & - LONG_NAME = 'tendency_of_northward_wind_due_to_dynamics',& - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTDTDYN', & - LONG_NAME = 'tendency_of_air_temperature_due_to_dynamics', & - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQVDTDYN', & - LONG_NAME = 'tendency_of_specific_humidity_due_to_dynamics', & - UNITS = 'kg kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQIDTDYN', & - LONG_NAME = 'tendency_of_ice_water_due_to_dynamics', & - UNITS = 'kg kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQLDTDYN', & - LONG_NAME = 'tendency_of_liquid_water_due_to_dynamics', & - UNITS = 'kg kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DOXDTDYN', & - LONG_NAME = 'tendency_of_ozone_due_to_dynamics', & - UNITS = 'mol mol-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PREF', & - LONG_NAME = 'reference_air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'AK', & - LONG_NAME = 'hybrid_sigma_pressure_a', & - UNITS = '1', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'BK', & - LONG_NAME = 'hybrid_sigma_pressure_b', & - UNITS = '1', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PS', & - LONG_NAME = 'surface_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TA', & - LONG_NAME = 'surface_air_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'QA', & - LONG_NAME = 'surface_specific_humidity', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'US', & - LONG_NAME = 'surface_eastward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VS', & - LONG_NAME = 'surface_northward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'SPEED', & - LONG_NAME = 'surface_wind_speed', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DZ', & - LONG_NAME = 'surface_layer_height', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'SLP', & - LONG_NAME = 'sea_level_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'H1000', & - LONG_NAME = 'height_at_1000_mb', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TROPP_EPV', & - LONG_NAME = 'tropopause_pressure_based_on_EPV_estimate', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TROPP_THERMAL', & - LONG_NAME = 'tropopause_pressure_based_on_thermal_estimate', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TROPP_BLENDED', & - LONG_NAME = 'tropopause_pressure_based_on_blended_estimate', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TROPT', & - LONG_NAME = 'tropopause_temperature_using_blended_TROPP_estimate', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TROPQ', & - LONG_NAME = 'tropopause_specific_humidity_using_blended_TROPP_estimate', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DELP', & - LONG_NAME = 'pressure_thickness', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U_CGRID', & - LONG_NAME = 'eastward_wind_on_C-Grid', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V_CGRID', & - LONG_NAME = 'northward_wind_on_C-Grid', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U_DGRID', & - LONG_NAME = 'eastward_wind_on_native_D-Grid', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V_DGRID', & - LONG_NAME = 'northward_wind_on_native_D-Grid', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TV', & - LONG_NAME = 'air_virtual_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'THV', & - LONG_NAME = 'scaled_virtual_potential_temperature', & - UNITS = 'K/Pa$^\kappa$', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DDELPDTDYN', & - LONG_NAME = 'tendency_of_pressure_thickness_due_to_dynamics', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UKE', & - LONG_NAME = 'eastward_flux_of_atmospheric_kinetic_energy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VKE', & - LONG_NAME = 'northward_flux_of_atmospheric_kinetic_energy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UCPT', & - LONG_NAME = 'eastward_flux_of_atmospheric_enthalpy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VCPT', & - LONG_NAME = 'northward_flux_of_atmospheric_enthalpy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UPHI', & - LONG_NAME = 'eastward_flux_of_atmospheric_potential_energy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VPHI', & - LONG_NAME = 'northward_flux_of_atmospheric_potential_energy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UQV', & - LONG_NAME = 'eastward_flux_of_atmospheric_water_vapor', & - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VQV', & - LONG_NAME = 'northward_flux_of_atmospheric_water_vapor', & - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UQL', & - LONG_NAME = 'eastward_flux_of_atmospheric_liquid_water', & - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VQL', & - LONG_NAME = 'northward_flux_of_atmospheric_liquid_water',& - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UQI', & - LONG_NAME = 'eastward_flux_of_atmospheric_ice', & - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VQI', & - LONG_NAME = 'northward_flux_of_atmospheric_ice', & - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DKE', & - LONG_NAME = 'tendency_of_atmosphere_kinetic_energy_content_due_to_dynamics',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DCPT', & - LONG_NAME = 'tendency_of_atmosphere_dry_energy_content_due_to_dynamics',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DPET', & - LONG_NAME = 'tendency_of_atmosphere_topographic_potential_energy_due_to_dynamics',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'WRKT', & - LONG_NAME = 'work_done_by_atmosphere_at_top', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQV', & - LONG_NAME = 'tendency_of_atmosphere_water_vapor_content_due_to_dynamics',& - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQL', & - LONG_NAME = 'tendency_of_atmosphere_liquid_water_content_due_to_dynamics',& - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQI', & - LONG_NAME = 'tendency_of_atmosphere_ice_content_due_to_dynamics',& - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'CNV', & - LONG_NAME = 'generation_of_atmosphere_kinetic_energy_content',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U850', & - LONG_NAME = 'eastward_wind_at_850_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U500', & - LONG_NAME = 'eastward_wind_at_500_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U250', & - LONG_NAME = 'eastward_wind_at_250_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V850', & - LONG_NAME = 'northward_wind_at_850_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V500', & - LONG_NAME = 'northward_wind_at_500_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V250', & - LONG_NAME = 'northward_wind_at_250_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'T850', & - LONG_NAME = 'air_temperature_at_850_hPa', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'T500', & - LONG_NAME = 'air_temperature_at_500_hPa', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'T250', & - LONG_NAME = 'air_temperature_at_250_hPa', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'Q850', & - LONG_NAME = 'specific_humidity_at_850_hPa', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'Q500', & - LONG_NAME = 'specific_humidity_at_500_hPa', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'Q250', & - LONG_NAME = 'specific_humidity_at_250_hPa', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'H850', & - LONG_NAME = 'height_at_850_hPa', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'H500', & - LONG_NAME = 'height_at_500_hPa', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'H250', & - LONG_NAME = 'height_at_250_hPa', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'OMEGA500', & - LONG_NAME = 'omega_at_500_hPa', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U50M', & - LONG_NAME = 'eastward_wind_at_50_meters', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V50M', & - LONG_NAME = 'northward_wind_at_50_meters', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'AREA', & - LONG_NAME = 'agrid_cell_area', & - UNITS = 'm+2' , & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PT', & - LONG_NAME = 'scaled_potential_temperature', & - UNITS = 'K Pa$^{-\kappa}$', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PE', & - LONG_NAME = 'air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - -! !INTERNAL STATE: - -!ALT: technically the first 2 records of "old" style FV restart have -! 6 ints: YYYY MM DD H M S -! 5 ints: I,J,K, KS (num true pressure levels), NQ (num tracers) headers - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'AK', & - LONG_NAME = 'hybrid_sigma_pressure_a', & - UNITS = 'Pa', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsVertOnly, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'BK', & - LONG_NAME = 'hybrid_sigma_pressure_b', & - UNITS = '1', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsVertOnly, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'U', & - LONG_NAME = 'eastward_wind', & - UNITS = 'm s-1', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'V', & - LONG_NAME = 'northward_wind', & - UNITS = 'm s-1', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'PT', & - LONG_NAME = 'scaled_potential_temperature', & - UNITS = 'K Pa$^{-\kappa}$', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'PE', & - LONG_NAME = 'air_pressure', & - UNITS = 'Pa', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'PKZ', & - LONG_NAME = 'pressure_to_kappa', & - UNITS = 'Pa$^\kappa$', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - -!EOS - - -! Set the Profiling timers -! ------------------------ - - call MAPL_TimerAdd(GC, name="INITIALIZE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="RUN1" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="-WRAPPER" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--CDCORE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--OMEGA" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--BUDGETS" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--EPVD" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---PRE_C_CORE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----PRE_C_CORE_COMM" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----C_DELP_LOOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---C_CORE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---C_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----YZ_TO_XY_C_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----XY_TO_YZ_C_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---PRE_D_CORE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----PRE_D_CORE_COMM" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----C_U_LOOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----C_V_PGRAD" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---D_CORE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---D_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----XY_TO_YZ_D_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----YZ_TO_XY_D_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---PRE_D_PGRAD" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----PRE_D_PGRAD_COMM_1", RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----D_DELP_LOOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---D_PGRAD_1" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---D_PGRAD_2" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---PRE_D_PGRAD_COMM_2" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--TRAC2D" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---TRAC2D_COMM" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---TRAC2D_TRACER" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----TRAC2D_TRACER_COMM", RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--REMAP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--BENERGY" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--TRANSPOSE_FWD" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="RUN2" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="FINALIZE" , RC=STATUS) - VERIFY_(STATUS) - -! Register services for this component -! ------------------------------------ - - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_INITIALIZE, Initialize, rc=status) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_RUN, Run1, rc=status) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_RUN, Run2, rc=status) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_FINALIZE, Finalize, rc=status) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_READRESTART, Coldstart, rc=status) - VERIFY_(STATUS) - -! Generic SetServices -!-------------------- - - call MAPL_GenericSetServices( GC, RC=STATUS ) - VERIFY_(STATUS) - - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - subroutine Initialize ( gc, import, export, clock, rc ) - -! !ARGUMENTS: - - use g3_dynamics_state_module - type ( dynamics_grid_type ) g3_grid - include 'mpif.h' - - type(ESMF_GridComp), intent(inout) :: gc ! composite gridded component - type(ESMF_State), intent(inout) :: import ! import state - type(ESMF_State), intent(inout) :: export ! export state - type(ESMF_Clock), intent(inout) :: clock ! the clock - - integer, intent(out), OPTIONAL :: rc ! Error code: - ! = 0 all is well - ! otherwise, error - integer :: I,J - type (ESMF_Grid) :: grid - type (ESMF_Config) :: cf - type (ESMF_Config), pointer :: config - - type (DYN_wrap) :: wrap - type (T_FVDYCORE_STATE), pointer :: STATE - type (T_FVDYCORE_GRID), pointer :: FVGRID - - type (MAPL_MetaComp), pointer :: mapl - - character (len=ESMF_MAXSTR) :: restart_file - - type (ESMF_Field) :: field - type (ESMF_Array) :: array - type (ESMF_VM) :: VM - real, pointer :: pref(:), ak4(:), bk4(:) - real(r8), pointer :: ak(:), bk(:) - real(r8), pointer :: pe(:,:,:) - real(r4), pointer :: ple(:,:,:) - real(r4), pointer :: temp2d(:,:) - character(len=ESMF_MAXSTR) :: ReplayMode - real :: DNS_INTERVAL - type (ESMF_TimeInterval) :: Intv - type (ESMF_Alarm) :: Alarm - - - integer :: status - character(len=ESMF_MAXSTR) :: IAm - character(len=ESMF_MAXSTR) :: COMP_NAME - - type (ESMF_State) :: INTERNAL - - real(r8), allocatable :: tmp2d(:,:) - integer :: ifirstxy, ilastxy, jfirstxy, jlastxy - integer :: im,jm - integer :: NX,NY - integer :: imglobal,jmglobal,lmglobal - - -! Begin -!------ - - Iam = "Initialize" - call ESMF_GridCompGet( GC, name=COMP_NAME, CONFIG=CF, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // Iam - -! Call Generic Initialize -!------------------------ - - call MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC=STATUS) - VERIFY_(STATUS) - -! Retrieve the pointer to the state -! --------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - -! Start the timers -!----------------- - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"INITIALIZE") - -! Get the private internal state -!------------------------------- - - call ESMF_UserCompGetInternalState(GC, 'FVstate', wrap, status) - VERIFY_(STATUS) - - state => wrap%dyn_state - fvgrid => state%grid ! direct handle to grid - -! Set Private Internal State from ESMF internal state in MAPL object -! ------------------------------------------------------------------ - - call MAPL_Get ( MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS ) - VERIFY_(STATUS) - - call FV_InitState ( STATE, CLOCK, INTERNAL, GC ) - -! Create PLE and PREF EXPORT Coupling (Needs to be done only once per run) -! ------------------------------------------------------------------------ - - call MAPL_GetPointer(EXPORT,PREF,'PREF',ALLOC=.true.,RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,AK4 ,'AK' ,ALLOC=.true.,RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,BK4 ,'BK' ,ALLOC=.true.,RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer(INTERNAL, AK, 'AK', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BK, 'BK', RC=STATUS) - VERIFY_(STATUS) - - AK4 = AK - BK4 = BK - PREF = AK + BK * P00 - - call MAPL_GetPointer(EXPORT,PLE,'PLE',ALLOC=.true.,RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL,PE,'PE',RC=STATUS) - VERIFY_(STATUS) - - PLE = PE - -! ********************************************************************** -! **** Create G3 Grid **** -! ********************************************************************** - - call MAPL_GetResource( MAPL, NX, 'NX:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, NY, 'NY:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, imglobal, 'AGCM_IM:', RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, jmglobal, 'AGCM_JM:', RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, lmglobal, 'AGCM_LM:', RC=STATUS ) - VERIFY_(STATUS) - - call create_dynamics_lattice ( g3_grid%lattice,nx,ny ) - call init_dynamics_lattice ( g3_grid%lattice,mpi_comm_world,imglobal,jmglobal,lmglobal ) - call create_dynamics_grid ( g3_grid,imglobal,jmglobal,lmglobal ) - call init_dynamics_grid ( g3_grid,imglobal,jmglobal,lmglobal,0,state%grid%ak,state%grid%bk ) - -! Compute Grid-Cell Area -! ---------------------- - call MAPL_GetPointer(export,temp2d,'AREA', ALLOC=.true., rc=status) - VERIFY_(STATUS) - - ifirstxy = fvgrid%ifirstxy - ilastxy = fvgrid%ilastxy - jfirstxy = fvgrid%jfirstxy - jlastxy = fvgrid%jlastxy - - ALLOCATE( tmp2d(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - do j=MAX(2,jfirstxy),MIN(jlastxy,jmglobal-1) - tmp2d(:,j) = fvgrid%dl*fvgrid%cosp(j)*RADIUS * fvgrid%dp*RADIUS - enddo - if ( jfirstxy == 1 ) then - j=1 - tmp2d(:,j) = fvgrid%acap*( fvgrid%dl*RADIUS * fvgrid%dp*RADIUS)/imglobal - endif - if ( jlastxy == jmglobal ) then - j=jmglobal - tmp2d(:,j) = fvgrid%acap*( fvgrid%dl*RADIUS * fvgrid%dp*RADIUS)/imglobal - endif - temp2d = tmp2d - - DEALLOCATE( tmp2d ) - -! ====================================================================== -!ALT: the next section addresses the problem when export variables have been -! assigned values during Initialize. To prevent "connected" exports -! being overwritten by DEFAULT in the Import spec in the other component -! we label them as being "initailized by restart". A better solution -! would be to move the computation to phase 2 of Initialize and -! eliminate this section alltogether -! ====================================================================== - call ESMF_StateGet(EXPORT, 'PREF', FIELD, RC=STATUS) - VERIFY_(STATUS) - call MAPL_AttributeSet(field, NAME="MAPL_InitStatus", & - VALUE=MAPL_InitialRestart, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_StateGet(EXPORT, 'PLE', FIELD, RC=STATUS) - VERIFY_(STATUS) - call MAPL_AttributeSet(field, NAME="MAPL_InitStatus", & - VALUE=MAPL_InitialRestart, RC=STATUS) - VERIFY_(STATUS) - -!=====Begin intemittent replay======================= - -! Set the intermittent replay alarm, if needed. -! Note that it is a non-sticky alarm -! and is set to ringing on first step. So it will -! work whether the clock is backed-up ans ticked -! or not. - - call MAPL_GetResource(MAPL, ReplayMode, 'REPLAY_MODE:', default="NoReplay", RC=STATUS ) - VERIFY_(STATUS) - - if(adjustl(ReplayMode)=="Intermittent") then - call MAPL_GetResource(MAPL, DNS_INTERVAL,'REPLAY_INTERVAL:', default=21600., RC=STATUS ) - VERIFY_(STATUS) - call ESMF_TimeIntervalSet(Intv, S=nint(DNS_INTERVAL), RC=STATUS) - VERIFY_(STATUS) - - ALARM = ESMF_AlarmCreate(name='INTERMITTENT', clock=CLOCK, & - ringInterval=Intv, sticky=.false., & - RC=STATUS ) - VERIFY_(STATUS) - call ESMF_AlarmRingerOn(ALARM, rc=status) - VERIFY_(STATUS) - end if - -!========End intermittent replay======================== - - call MAPL_TimerOff(MAPL,"INITIALIZE") - call MAPL_TimerOff(MAPL,"TOTAL") - - RETURN_(ESMF_SUCCESS) - end subroutine Initialize - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - subroutine FV_InitState (STATE, CLOCK, INTERNAL, GC) - - use dynamics_vars, only : dynamics_init - use parutilitiesmodule, only : gsize, gid, parinit - - type (T_FVDYCORE_STATE),pointer :: STATE - - type (ESMF_Clock), target, intent(INOUT) :: CLOCK - type (ESMF_GridComp) , intent(INout) :: GC - type (ESMF_State) , intent(INOUT) :: INTERNAL - -! Local variables - - type (ESMF_TimeInterval) :: Time2Run - type (ESMF_TimeInterval) :: CheckMaxMin - type (ESMF_VM) :: VM - type (T_FVDYCORE_GRID) , pointer :: GRID - integer :: rc - integer :: status - integer :: len - real(r8) :: REAL_PACK(6) - - integer :: NPRXY_X, NPRXY_Y, NPRYZ_Y, NPRYZ_Z, & - DT, IORD, JORD, KORD, TE_METHOD, NSPLIT - integer :: force_2d, geopktrans - integer, allocatable :: IMXY(:), JMXY(:), JMYZ(:), KMYZ(:) - - integer :: nx, ny - integer :: nstep, nymd, nhms - integer :: yr, mm, dd, h, m, s, itmp - integer :: INT_PACK(6) - - type(ESMF_DELayout) :: layoutYZ - integer :: I, nDEs - integer :: img - integer :: jmg - integer :: kmg - - integer :: im, jm, km ! Global dims - integer :: nq ! No. advected tracers - integer :: ntotq ! No. total tracers - integer :: ks ! True # press. levs - integer :: ifirstxy, ilastxy ! Interval - integer :: jfirstxy, jlastxy ! Interval - integer :: jfirst, jlast ! Interval - integer :: kfirst, klast ! Interval - integer :: k ! Vertical loop index - integer :: srcCellCountPerDim(3), srcStartPerDEPerDim(gsize,3) - - character(len=ESMF_MAXSTR) :: IAm='FV:Init_State' - - real(r8), pointer :: AK(:), BK(:) - real(r8), dimension(:,:,:), pointer :: U, V, PT, PE, PKZ - type (MAPL_MetaComp), pointer :: mapl - integer :: comm - - real ple,ples,plet,sig,dpl - -! Retrieve the pointer to the state -! --------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - -! Save the mapl state for FVperf_module -! ------------------------------------- - - STATE%GRID%FVgenstate => MAPL - GRID => STATE%GRID ! For convenience - -! Initialize Layout based on 2-D decomposition -! -------------------------------------------- - - call MAPL_GetResource( MAPL, NX, 'NX:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, NY, 'NY:', default=0, RC=STATUS ) - VERIFY_(STATUS) - - NPRXY_X = NX - NPRXY_Y = NY - NPRYZ_Y = NY - NPRYZ_Z = NX - - _ASSERT( NPRXY_X>0 .AND. NPRXY_Y>0 ,'needs informative message') - _ASSERT( NPRYZ_Y>0 .AND. NPRYZ_Z>0 ,'needs informative message') - _ASSERT( NPRXY_X*NPRXY_Y == NPRYZ_Y*NPRYZ_Z ,'needs informative message') - - call MAPL_GetResource( MAPL, force_2d, 'force_2d:', default=0, RC=STATUS ) - VERIFY_(STATUS) - -! Get the layout and store directly in the GRID data structure -! ------------------------------------------------------------ - - grid%twod_decomp = 1 - - if (npryz_z .eq. 1 .and. nprxy_x .eq. 1 .and. force_2d .eq. 0) then - grid%twod_decomp = 0 - call WRITE_PARALLEL('Code operating with 1D decomposition') - endif - -! Pilgrim initialization: pass the 2D decomposition and other parameters for FV optimization -! ------------------------------------------------------------------------------------------ - - call ESMF_VMGetCurrent(vm, rc=rc) - call ESMF_VMGet(vm, mpiCommunicator=comm, rc=rc) - call parinit( comm=comm, npryzxy = (/ npryz_y, npryz_z, nprxy_x, nprxy_y/), & - mod_method = grid%mod_method, & - mod_geopk = grid%mod_geopk, & - mod_gatscat = grid%mod_gatscat ) - -! Get Global Dimensions -! --------------------- - call MAPL_GetResource( MAPL, IMG, 'AGCM_IM:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, JMG, 'AGCM_JM:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, KMG, 'AGCM_LM:', default=0, RC=STATUS ) - VERIFY_(STATUS) - -! Create IMXY, JMXY, JMYZ, KMYZ vectors -! ------------------------------------- - - allocate( imxy(0:nprxy_x-1) ) - allocate( jmxy(0:nprxy_y-1) ) - allocate( jmyz(0:npryz_y-1) ) - allocate( kmyz(0:npryz_z-1) ) - - call MAPL_DecomposeDim ( img,imxy,nprxy_x ) - call MAPL_DecomposeDim ( jmg,jmxy,nprxy_y ) - call MAPL_DecomposeDim ( jmg,jmyz,npryz_y ) - call MAPL_DecomposeDim ( kmg,kmyz,npryz_z ) - -! Get other scalars -! ----------------- - - call MAPL_GetResource( MAPL, dt, 'RUN_DT:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, iord, 'iord:', default=3, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, jord, 'jord:', default=3, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, kord, 'kord:', default=4, RC=STATUS ) - VERIFY_(STATUS) - -! Vertical Remapping Method for Total Energy (default=1 is cubic interpolation) -! ----------------------------------------------------------------------------- - - call MAPL_GetResource( MAPL, te_method, 'te_method:', default=1, RC=STATUS ) - VERIFY_(STATUS) - -! Ratio of Large/Small Timesteps (default=0 implies automatic calculation) -! ------------------------------------------------------------------------ - - call MAPL_GetResource( MAPL, nsplit, 'nsplit:', default=0, RC=STATUS ) - VERIFY_(STATUS) - -! Heritage Code for Tracers -! ------------------------- - ntotq = 1 ! Total Number of Tracers - nq = ntotq ! Total Number of Advected Tracers - -! Other assertions -! - _ASSERT(maxval(IMXY)>0 .AND. maxval(JMXY)>0,'needs informative message') - _ASSERT(maxval(JMYZ)>0 .AND. maxval(KMYZ)>0,'needs informative message') - _ASSERT(DT > 0.0 ,'needs informative message') - - call WRITE_PARALLEL('Dynamics PE Layout') - call WRITE_PARALLEL(IMG ,format='("IM_Global: ",( I4))') - call WRITE_PARALLEL(JMG ,format='("JM_Global: ",( I4))') - call WRITE_PARALLEL(KMG ,format='("LM_Global: ",( I4))') - call WRITE_PARALLEL(NPRXY_X ,format='("NPRXY_X : ",( I4))') - call WRITE_PARALLEL(NPRXY_Y ,format='("NPRXY_Y : ",( I4))') - call WRITE_PARALLEL(NPRYZ_Y ,format='("NPRYZ_Y : ",( I4))') - call WRITE_PARALLEL(NPRYZ_Z ,format='("NPRYZ_Z : ",( I4))') - call WRITE_PARALLEL(IMXY(0:NPRXY_X-1),format='("IMXY : ",(256I3))') - call WRITE_PARALLEL(JMXY(0:NPRXY_Y-1),format='("JMXY : ",(256I3))') - call WRITE_PARALLEL(JMYZ(0:NPRYZ_Y-1),format='("JMYZ : ",(256I3))') - call WRITE_PARALLEL(KMYZ(0:NPRYZ_Z-1),format='("KMYZ : ",(256I3))') - - call WRITE_PARALLEL(iord,format='(/,"IORD: ",(I2))') - call WRITE_PARALLEL(jord,format='( "JORD: ",(I2))') - call WRITE_PARALLEL(kord,format='( "KORD: ",(I2))') - call WRITE_PARALLEL(te_method,format='( "TE_METHOD: ",(I2),/)') - -! These are run-specific variables: -! DT Time step -! IORD Order (mode) of X interpolation (1,..,6) -! JORD Order (mode) of Y interpolation (1,..,6) -! NSPLIT Ratio of big to small timestep (set to zero if in doubt) -! - - STATE%DOTIME = .TRUE. - STATE%CHECK_DT = 21600. ! Check max and min of arrays every 6 hours. - STATE%DT = DT - STATE%IORD = IORD - STATE%JORD = JORD - STATE%KORD = KORD - STATE%TE_METHOD = TE_METHOD - -! Calculation of orders for the C grid is fixed by D-grid IORD, JORD -!------------------------------------------------------------------- - - if( iord <= 2 ) then - STATE%ICD = 1 - else - STATE%ICD = -2 - endif - - if( jord <= 2 ) then - STATE%JCD = 1 - else - STATE%JCD = -2 - endif - - call WRITE_PARALLEL(STATE%DT,format='("Dynamics time step: ",(F10.4))') - - -! Get the main GRIDXY grid from the application (no longer set in this module) -!----------------------------------------------------------------------------- - - call ESMF_GridCompGet(gc, grid=GRID%GRIDXY, vm=vm, rc=STATUS) - -! Get size, grid, and coordinate specifications -!---------------------------------------------- - -!MJS: we should get these from the MAPL object - - im = SUM(IMXY) - jm = SUM(JMXY) - km = SUM(KMYZ) - -! Calculate NSPLIT if it was specified as 0 -! ----------------------------------------- - if ( NSPLIT == 0 ) then - STATE%NSPLIT = INIT_NSPLIT(STATE%DT,IM,JM) - else - STATE%NSPLIT = NSPLIT - call WRITE_PARALLEL(STATE%NSPLIT,format='("Dynamics NSPLIT: ",(I3),/)') - endif - - call WRITE_PARALLEL((/im,jm,km/) , & - format='("Resolution of dynamics restart =",3I5)' ) - - ks = 0 ! ALT: this was the value when we read "old" style FV_internal restart - ! if needed, we could compute, ks by count(BK==0.0) - ! then FV will try to run slightly more efficient code - ! So far, GEOS-5 has used ks = 0 - _ASSERT(ks <= KM+1,'needs informative message') - call WRITE_PARALLEL(ks , & - format='("Number of true pressure levels =", I5)' ) - -! -! Make sure that IM, JM, KM are the sums of the (exclusive) dist. -! - _ASSERT(jm == SUM(JMYZ),'needs informative message') - -! -! -! Note: it is necessary to create GRIDXY and GRIDYZ now in -! order to access the first and last local indices. -! This makes it difficult to cleanly separate the -! grid initialization into init_fvdycore_grid. -! -! - -!ALT??? -! we need to check if the grid is OK - - GRID%GRIDYZ = ESMF_GridCreate( & - name="FVCORE_YZ_grid", & - countsPerDEDim1=JMYZ, & - countsPerDEDim2=KMYZ, & - indexFlag = ESMF_INDEX_GLOBAL, & - coordDep1 = (/1,2/), & - coordDep2 = (/1,2/), & - gridEdgeLWidth = (/0,0/), & - gridEdgeUWidth = (/0,0/), & - rc=status) - VERIFY_(STATUS) - - - call MAPL_GRID_INTERIOR(GRID%GRIDXY, ifirstxy, ilastxy, & - jfirstxy, jlastxy ) - - call MAPL_GRID_INTERIOR(GRID%GRIDYZ, jfirst, jlast, & - kfirst, klast ) - -! Get pointers to internal state vars -!------------------------------------ - - call MAPL_GetPointer(internal, ak, "AK", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, bk, "BK", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, u, "U", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, v, "V", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, pt, "PT", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, pe, "PE", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, pkz, "PKZ",rc=status) - VERIFY_(STATUS) - -! -! WS: CREATE_VARS moved here to define STATE%VARS soon enough -! - call CREATE_VARS ( ifirstxy, ilastxy, & - jfirstxy, jlastxy, & - 1, km, km+1, & - U, V, PT, PE, PKZ, & - STATE%VARS ) - - -! Report -!------- - - if( gid.eq.0 ) then - print * - write(6,100) -100 format(2x,' k ',' A(k) ',2x,' B(k) ',2x,' Pref ',2x,' DelP ',2x,' Sige ',/, & - 1x,'----',3x,'----------',2x,'----------',2x,'----------',2x,'---------',2x,'--------' ) - k=0 - plet = ak(k )*0.01 + 1000.0*bk(k) - ple = ak(k )*0.01 + 1000.0*bk(k) - ples = ak(km)*0.01 + 1000.0*bk(km) - write(6,101) k+1,ak(k)*0.01, bk(k), ple - do k=1,km - dpl = ple - ple = ak(k)*0.01 + 1000.0*bk(k) - dpl = ple-dpl - sig = (ple-plet)/(ples-plet) - write(6,102) k+1,ak(k)*0.01, bk(k), ple, dpl, sig - enddo - - print * -101 format(2x,i3,2x,f10.6,2x,f10.6,2x,f10.4) -102 format(2x,i3,2x,f10.6,2x,f10.6,2x,f10.4,3x,f8.4,2x,f10.6) - endif - -! Initialize the FVDYCORE static variables in the GRID -!----------------------------------------------------- - - call dynamics_init( state%dt, state%jord, im, jm, km, & - PI, RADIUS, OMEGA, nq, ntotq, ks, & - ifirstxy,ilastxy, jfirstxy,jlastxy, & - jfirst, jlast, kfirst, klast, & - nprxy_x, nprxy_y, npryz_y, npryz_z, & - imxy, jmxy, jmyz, kmyz, & - ak, bk, 0, grid ) - - STATE%CLOCK => CLOCK - - call ESMF_TimeIntervalSet(Time2Run, & - S=nint(STATE%DT), rc=status) - VERIFY_(status) - - STATE%ALARMS(TIME_TO_RUN) = ESMF_AlarmCreate(name="Time2Run", clock=clock, & - ringInterval=Time2Run, & - Enabled=.TRUE., rc=status) - VERIFY_(status) - - call ESMF_AlarmEnable (STATE%ALARMS(TIME_TO_RUN), rc=status); VERIFY_(status) - call ESMF_AlarmRingerOn(STATE%ALARMS(TIME_TO_RUN), rc=status); VERIFY_(status) - - call ESMF_TimeIntervalSet(CheckMaxMin, S=nint(STATE%CHECK_DT), rc=status) - VERIFY_(status) - - STATE%ALARMS(CHECK_MAXMIN) = ESMF_AlarmCreate(name="CheckMaxMin", clock=clock, & - RingInterval=CheckMaxMin, & - Enabled=.TRUE., rc=status) - VERIFY_(status) - - call WRITE_PARALLEL(' ') - - call WRITE_PARALLEL(STATE%DT, & - format='("INITIALIZED ALARM: DYN_TIME_TO_RUN EVERY ",F9.1," secs.")') - call WRITE_PARALLEL(STATE%CHECK_DT, & - format='("INITIALIZED ALARM: CHECK MAX AND MIN EVERY ",F9.1," secs.")') - - return - -contains - -!----------------------------------------------------------------------- -! BOP -! !IROUTINE: init_nsplit --- find proper value for nsplit if not specified -! -! !INTERFACE: - integer function INIT_NSPLIT(dtphy,im,jm) -! -! !USES: - implicit none - -! !INPUT PARAMETERS: - real (r8), intent(in) :: dtphy ! Physics Time Step - integer, intent(in) :: im, jm ! Global horizontal resolution - -! !DESCRIPTION: -! -! If nsplit=0 (module variable) then determine a good value -! for ns (used in dynpkg) based on resolution and the large-time-step -! (pdt). The user may have to set this manually if instability occurs. -! -! !REVISION HISTORY: -! 00.10.19 Lin Creation -! 01.03.26 Sawyer ProTeX documentation -! 01.06.10 Sawyer Modified for dynamics_init framework -! 03.12.04 Sawyer Moved here from dynamics_vars. Now a function -! -! EOP -!----------------------------------------------------------------------- -! !LOCAL VARIABLES: - - integer dtdyn - - dtdyn = nint(18*dtphy/im) - - do while ( mod(dtphy,real(dtdyn,kind=8)).ne.0 ) - dtdyn = dtdyn - 1 - if( dtdyn.lt.1 ) then - print * - print *, 'Cannot determine Dynamics Timestep' - print * - stop - endif - enddo - - init_nsplit = dtphy/dtdyn - - call WRITE_PARALLEL ( init_nsplit ,format='("Dynamics NSPLIT: ",(I3),/)' ) - - return - end function INIT_NSPLIT -!--------------------------------------------------------------------- - subroutine CREATE_VARS (I1, IN, J1, JN, K1, KN, KP, & - U, V, PT, PE, PKZ, VARS ) - - integer, intent(IN ) :: I1, IN, J1, JN, K1, KN, KP - real(r8), target :: U(I1:IN,J1:JN,K1:KN ) - real(r8), target :: V(I1:IN,J1:JN,K1:KN ) - real(r8), target :: PT(I1:IN,J1:JN,K1:KN ) - real(r8), target :: PE(I1:IN,J1:JN,K1:KP ) - real(r8), target :: PKZ(I1:IN,J1:JN,K1:KN ) - - type (T_FVDYCORE_VARS), intent(INOUT) :: VARS - - VARS%U => U - VARS%V => V - VARS%PT => PT - VARS%PE => PE - VARS%PKZ => PKZ - - return - end subroutine CREATE_VARS - - - -end subroutine FV_INITSTATE - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - - - - - subroutine Run1(gc, import, export, clock, rc) - use dynamics_vars, only : c2a3d - - use g3_dynamics_state_module - type ( dynamics_state_type ) dynamics - save dynamics - - type(ESMF_GridComp), intent(inout) :: gc - type (ESMF_State), intent(inout) :: import - type (ESMF_State), intent(inout) :: export - type (ESMF_Clock), intent(INout) :: clock - integer, intent(out), optional :: rc - - include 'mpif.h' - integer nx,ny,ierror - integer imglobal,jmglobal - real(r8) pi,dl,dp - real(r4) alpha - integer nsplit - character*4 scheme - -! !Local Variables: - - integer :: status - type (ESMF_FieldBundle) :: bundle - type (ESMF_FieldBundle) :: DNS_Bundle - type (ESMF_Field) :: field - type (ESMF_Field) :: dns_field - type (ESMF_Config) :: cf - type (ESMF_Alarm) :: Alarm - type (ESMF_Grid) :: ESMFGRID - type (ESMF_Time) :: currentTime - - type (MAPL_MetaComp), pointer :: mapl - - type (DYN_wrap) :: wrap - type (T_FVDYCORE_STATE), pointer :: STATE - type (T_FVDYCORE_GRID), pointer :: GRID - type (T_FVDYCORE_VARS), pointer :: VARS - - integer :: J1, JN, K1, KN, NQ, KQ - integer :: IM, JM, KM - integer :: NKE, NPHI - integer :: NUMVARS - integer :: ifirstxy, ilastxy, jfirstxy, jlastxy - integer :: I, J, K, L, n, pos - logical, parameter :: convt = .false. ! Until this is run with full physics - logical :: is_ringing - logical first - data first /.true./ - - real(r8), pointer :: phisxy(:,:) - real(kind=4), pointer :: phis(:,:) - - real(r8), allocatable :: pke(:,:,:) ! pe**kappa - real(r8), allocatable :: pk (:,:,:) ! mid-level pressure - - real(r8), allocatable :: pkxy(:,:,:) ! pe**kappa - real(r8), allocatable :: pl(:,:,:) ! mid-level pressure - real(r8), allocatable :: tempxy(:,:,:) ! mid-level temperature - real(r8), allocatable :: ua(:,:,:) ! temporary array - real(r8), allocatable :: va(:,:,:) ! temporary array - real(r8), allocatable :: qv(:,:,:) ! temporary array - real(r8), allocatable :: ql(:,:,:) ! temporary array - real(r8), allocatable :: qi(:,:,:) ! temporary array - real(r8), allocatable :: qdnew(:,:,:) ! temporary array - real(r8), allocatable :: qdold(:,:,:) ! temporary array - real(r8), allocatable :: qvold(:,:,:) ! temporary array - real(r8), allocatable :: qlold(:,:,:) ! temporary array - real(r8), allocatable :: qiold(:,:,:) ! temporary array - real(r8), allocatable :: ox(:,:,:) ! temporary array - real(r8), allocatable :: zl(:,:,:) ! temporary array - real(r8), allocatable :: zle(:,:,:) ! temporary array - real(r8), allocatable :: delp(:,:,:) ! temporary array - real(r8), allocatable :: dudt(:,:,:) ! temporary array - real(r8), allocatable :: dvdt(:,:,:) ! temporary array - real(r8), allocatable :: dtdt(:,:,:) ! temporary array - real(r8), allocatable :: dqdt(:,:,:) ! temporary array - real(r8), allocatable :: dthdt(:,:,:) ! temporary array - real(r8), allocatable :: ddpdt(:,:,:) ! temporary array - real(r8), allocatable :: dmdt(:,:) ! temporary array - real(r8), allocatable :: gze(:,:,:) ! temporary array - - real(r8), allocatable, target :: ke (:,:,:) ! Kinetic Energy - real(r8), allocatable, target :: cpt (:,:,:) ! Internal Energy - real(r8), allocatable, target :: phi (:,:,:) ! Potential Energy - real(r8), allocatable :: qsum1 (:,:) ! Vertically Integrated Kinetic Energy Tracer - real(r8), allocatable :: qsum2 (:,:) ! Vertically Integrated Internal Energy Tracer - - real(r8), allocatable :: phi00 (:,:) ! Vertically Integrated phi - real(r8), allocatable :: penrg (:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrg (:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrg (:,:) ! PHIS*(Psurf-Ptop) - real(r8), allocatable :: penrg0(:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrg0(:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrg0(:,:) ! PHIS*(Psurf-Ptop) - real(r8), allocatable :: penrga(:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrga(:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrga(:,:) ! PHIS*(Psurf-Ptop) - real(r8), allocatable :: penrgb(:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrgb(:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrgb(:,:) ! PHIS*(Psurf-Ptop) - real(r8), allocatable :: kehot (:,:) ! Vertically Integrated K due to higher-order-terms - real(r8), allocatable :: kedp (:,:) ! Vertically Integrated K due to pressure change - real(r8), allocatable :: keadv (:,:) ! Vertically Integrated K due to advection - real(r8), allocatable :: kepg (:,:) ! Vertically Integrated K due to pressure gradient - - real(r8), allocatable :: kegen (:,:) - real(r8), allocatable :: kedyn (:,:) - real(r8), allocatable :: pedyn (:,:) - real(r8), allocatable :: tedyn (:,:) - real(r8), allocatable :: kecdcor(:,:) - real(r8), allocatable :: pecdcor(:,:) - real(r8), allocatable :: tecdcor(:,:) - real(r8), allocatable :: keremap(:,:) - real(r8), allocatable :: peremap(:,:) - real(r8), allocatable :: teremap(:,:) - real(r8), allocatable :: convke (:,:) - real(r8), allocatable :: convcpt(:,:) - real(r8), allocatable :: convphi(:,:) - real(r8), allocatable :: convthv(:,:) - - real(r8), allocatable :: DNS_phis(:,:) - real(r8), allocatable :: DNS_thv (:,:,:) - - real(r8), allocatable :: dthdtremap (:,:) ! Vertically Integrated THV tendency due to vertical remapping - real(r8), allocatable :: dthdtconsv (:,:) ! Vertically Integrated THV tendency due to TE conservation - real(kind=4), allocatable :: dqvdtanaint1(:,:) - real(kind=4), allocatable :: dqvdtanaint2(:,:) - real(kind=4), allocatable :: dqldtanaint1(:,:) - real(kind=4), allocatable :: dqldtanaint2(:,:) - real(kind=4), allocatable :: dqidtanaint1(:,:) - real(kind=4), allocatable :: dqidtanaint2(:,:) - real(kind=4), allocatable :: doxdtanaint1(:,:) - real(kind=4), allocatable :: doxdtanaint2(:,:) - real(kind=4), allocatable :: dthdtanaint1(:,:) - real(kind=4), allocatable :: dthdtanaint2(:,:) - - real(kind=4), allocatable :: dummy (:,:,:) ! Dummy 3-D Variable - real(kind=4), allocatable :: tropp1(:,:) ! Tropopause Pressure - real(kind=4), allocatable :: tropp2(:,:) ! Tropopause Pressure - real(kind=4), allocatable :: tropp3(:,:) ! Tropopause Pressure - real(kind=4), allocatable :: tropt (:,:) ! Tropopause Temperature - real(kind=4), allocatable :: tropq (:,:) ! Tropopause Specific Humidity - - real(r8), allocatable :: pelnxz(:,:,:) ! log pressure (pe) at layer edges - real(r8), allocatable :: omaxyz(:,:,:) ! vertical pressure velocity (pa/sec) - real(r8), allocatable :: cptxyz(:,:,:) ! Cp*Tv - real(r8), allocatable :: thvxyz(:,:,:) ! Thetav - real(r8), allocatable :: epvxyz(:,:,:) ! ertel's potential vorticity - real(r8), allocatable :: cxxyz(:,:,:) ! Accumulated zonal winds - real(r8), allocatable :: cyxyz(:,:,:) ! Accumulated meridional winds - real(r8), allocatable :: ptfxxyz(:,:,:) ! zonal mass-weighted PT flux - real(r8), allocatable :: ptfyxyz(:,:,:) ! meridional mass-weighted PT flux - real(r8), allocatable :: mfxxyz_ur(:,:,:) ! zonal mass flux - real(r8), allocatable :: mfyxyz_ur(:,:,:) ! meridional mass flux - real(r8), allocatable :: mfxxyz(:,:,:) ! zonal mass flux - real(r8), allocatable :: mfyxyz(:,:,:) ! meridional mass flux - real(r8), allocatable :: mfzxyz(:,:,:) ! vertical mass flux - real(r8), allocatable :: mfxxyz_a(:,:,:) ! zonal mass flux A-Grid - real(r8), allocatable :: mfyxyz_a(:,:,:) ! meridional mass flux A-Grid - real(r8) :: dt ! Dynamics time step - real(r8) :: kinetic ! local kinetic energy - real(r8) :: potential ! local potential energy - real(r8) :: dtmp ! Temperature Change due to CONSV=TRUE - real(r8), allocatable :: tempr8(:,:,:) ! Cp*Tv - real(r8), allocatable :: trsum1(:) ! Global Sum of Tracers before Add_Incs - real(r8), allocatable :: trsum2(:) ! Global Sum of Tracers after Add_Incs - - real(kind=4), pointer :: dudtana(:,:,:) - real(kind=4), pointer :: dvdtana(:,:,:) - real(kind=4), pointer :: dtdtana(:,:,:) - real(kind=4), pointer :: ddpdtana(:,:,:) - real(kind=4), pointer :: dqldt (:,:,:) - real(kind=4), pointer :: dqidt (:,:,:) - real(kind=4), pointer :: doxdt (:,:,:) - real(kind=4), pointer :: dqvana (:,:,:) - real(kind=4), pointer :: dqlana (:,:,:) - real(kind=4), pointer :: dqiana (:,:,:) - real(kind=4), pointer :: doxana (:,:,:) - real(kind=4), pointer :: temp3d(:,:,:) - real(kind=4), pointer :: temp2d(:,:) - real(kind=4), pointer :: tempu (:,:) - real(kind=4), pointer :: tempv (:,:) - - character(len=ESMF_MAXSTR), ALLOCATABLE :: NAMES (:) - character(len=ESMF_MAXSTR), ALLOCATABLE, save :: NAMES0(:) - character(len=ESMF_MAXSTR) :: IAm - character(len=ESMF_MAXSTR) :: COMP_NAME - character(len=ESMF_MAXSTR) :: STRING - character(len=ESMF_MAXSTR) :: ReplayFile - character(len=ESMF_MAXSTR) :: ReplayMode - - type(T_TRACERS) :: qqq ! Specific Humidity - type(T_TRACERS) :: ooo ! OX - integer :: NXQ ! Number of Additional Budget Tracers - - type (MAPL_SunOrbit) :: ORBIT - real(kind=4), pointer :: LATS(:,:) - real(kind=4), pointer :: LONS(:,:) - real(kind=4), allocatable :: ZTH(:,:) - real(kind=4), allocatable :: SLR(:,:) - - logical LCONSV, LFILL - integer CONSV, FILL - - Iam = "Run1" - call ESMF_GridCompGet( GC, name=COMP_NAME, CONFIG=CF, Grid=ESMFGRID, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // trim(Iam) - -! Retrieve the pointer to the generic state -! ----------------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"RUN1") - -! Retrieve the pointer to the internal state -! ------------------------------------------ - - call ESMF_UserCompGetInternalState(gc, 'FVstate', wrap, status) - VERIFY_(STATUS) - state => wrap%dyn_state - - vars => state%vars ! direct handle to control variables - grid => state%grid ! direct handle to grid - dt = state%dt ! dynamics time step (large) - - ifirstxy = grid%ifirstxy - ilastxy = grid%ilastxy - jfirstxy = grid%jfirstxy - jlastxy = grid%jlastxy - -! im = grid%im -! jm = grid%jm - km = grid%km - - - is_ringing = ESMF_AlarmIsRinging( STATE%ALARMS(TIME_TO_RUN),rc=status); VERIFY_(status) - if (.not. is_ringing) return - -! Allocate Arrays -! --------------- - ALLOCATE( tempr8(ifirstxy:ilastxy,jfirstxy:jlastxy,2 ) ) - ALLOCATE( dummy(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( delp(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dudt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dvdt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dtdt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dqdt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dthdt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( ddpdt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( tempxy(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( pl(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( ua(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( va(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qv(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( ql(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qi(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qdnew(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qdold(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qvold(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qlold(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qiold(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( ox(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - - ALLOCATE( ke(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( cpt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( phi(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( gze(ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - - ALLOCATE( qsum1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( qsum2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( dmdt(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( phi00(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kenrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kenrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( kepg (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( keadv (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kedp (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kehot (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kenrga(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrga(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrga(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kenrgb(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrgb(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrgb(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( kegen (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kedyn (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( pedyn (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tedyn (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kecdcor(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( pecdcor(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tecdcor(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( keremap(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( peremap(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( teremap(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( convke (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( convcpt(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( convphi(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( convthv(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( tropp1 (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tropp2 (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tropp3 (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tropt (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tropq (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( dqvdtanaint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dqvdtanaint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dqldtanaint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dqldtanaint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dqidtanaint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dqidtanaint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( doxdtanaint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( doxdtanaint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dthdtanaint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dthdtanaint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dthdtremap (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dthdtconsv (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( pelnxz (ifirstxy:ilastxy,km+1,jfirstxy:jlastxy) ) - - ALLOCATE( phisxy (ifirstxy:ilastxy,jfirstxy:jlastxy ) ) - ALLOCATE( pkxy (ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - ALLOCATE( zl (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( zle (ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - ALLOCATE( omaxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( cptxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( thvxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( epvxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( cxxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( cyxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( ptfxxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( ptfyxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfxxyz_ur(ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfyxyz_ur(ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfxxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfyxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfzxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - ALLOCATE( mfxxyz_a (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfyxyz_a (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - - -! Report advected friendlies -!--------------------------- - - call ESMF_StateGet ( IMPORT, 'TRADV' , BUNDLE, RC=STATUS ) - VERIFY_(STATUS) - call ESMF_FieldBundleGet ( BUNDLE, fieldCount=NQ, RC=STATUS ) - VERIFY_(STATUS) - - allocate( NAMES(NQ),STAT=STATUS ) - VERIFY_(STATUS) - call ESMF_FieldBundleGet ( BUNDLE, itemorderflag=ESMF_ITEMORDER_ADDORDER, fieldNameList=NAMES, rc=STATUS ) - VERIFY_(STATUS) - - if( .not.allocated( names0 ) ) then - allocate( NAMES0(NQ),STAT=STATUS ) - VERIFY_(STATUS) - write(STRING,'(A,I5,A)') "Advecting the following ", nq, " tracers in FV:" - call WRITE_PARALLEL( trim(STRING) ) - do k=1,nq - call WRITE_PARALLEL( trim(NAMES(K)) ) - end do - NAMES0 = NAMES - endif - - !if( size(names0).ne.size(names) ) then - ! deallocate( NAMES0 ) - ! allocate( NAMES0(NQ),STAT=STATUS ) - ! VERIFY_(STATUS) - ! write(STRING,'(A,I5,A)') "Advecting the following ", nq, " tracers in FV:" - ! call WRITE_PARALLEL( trim(STRING) ) - ! do k=1,nq - ! call WRITE_PARALLEL( trim(NAMES(K)) ) - ! end do - ! NAMES0 = NAMES - !endif - -! Surface Geopotential from IMPORT state -!--------------------------------------- - - call MAPL_GetPointer ( IMPORT, PHIS, 'PHIS', RC=STATUS ) - VERIFY_(STATUS) - - phisxy = real(phis,kind=r8) - - -! Set Addition Tracers for Exact Budget Diagnostics -!-------------------------------------------------- - - call MAPL_GetPointer ( export,temp2D,'KEHOT',rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - NXQ = 2 - else - NXQ = 0 - endif - - -! Get tracers from IMPORT State (Note: Contains Updates from Analysis) -!--------------------------------------------------------------------- - - call PULL_Q ( STATE, IMPORT, qqq, NXQ, rc ) - - do k=1,size(names) - pos = index(names(k),'::') - if(pos > 0) then - if( (names(k)(pos+2:))=='OX' ) then - ooo = vars%tracer(k) - endif - endif - if( trim(names(k))=='Q' ) then - qqq = vars%tracer(k) - kq = k - endif - enddo - -! If requested, do Intermittent Replay -!------------------------------------- - - call MAPL_GetResource(MAPL, ReplayMode, 'REPLAY_MODE:', default="NoReplay", RC=STATUS ) - VERIFY_(STATUS) - - REPLAYING: if(adjustl(ReplayMode)=="Intermittent") then - -! It is an error not to specify a replay file at this point. -!----------------------------------------------------------- - - call MAPL_GetResource ( MAPL,ReplayFile,'REPLAY_FILE:', RC=STATUS ) - VERIFY_(status) - -! If replay alarm is ringing, we need to reset state -!--------------------------------------------------- - - call ESMF_ClockGetAlarm(Clock,'INTERMITTENT',Alarm,rc=Status) - VERIFY_(status) - - is_ringing = ESMF_AlarmIsRinging( Alarm,rc=status ) - VERIFY_(status) - - TIME_TO_REPLAY: if(is_ringing) then - - ALLOCATE( DNS_phis(ifirstxy:ilastxy,jfirstxy:jlastxy ) ) - ALLOCATE( DNS_thv (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - -! Read the fields to be reset into a bundle -!------------------------------------------ - - DNS_Bundle = ESMF_FieldBundleCreate( RC=STATUS) - VERIFY_(STATUS) - call ESMF_FieldBundleSet(DNS_bundle, grid=ESMFGRID, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_ClockGet(CLOCK, CurrTime=currentTIME, RC=STATUS) - VERIFY_(STATUS) - call MAPL_CFIORead(ReplayFile, currentTime, DNS_Bundle, & -! ONLY_VARS='uwnd,vwnd,delp,ozone,sphu,theta,phis', & - RC=STATUS) - VERIFY_(STATUS) - -! Fill the state variables from the bundle only if -! the corresponding fields are there. -!------------------------------------------------- - -! U - call ESMFL_BundleGetPointertoData(DNS_Bundle,'uwnd',TEMP3D, RC=STATUS) -! VERIFY_(STATUS) - if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Replaying uwnd' - vars%u = TEMP3D - endif -! V - call ESMFL_BundleGetPointertoData(DNS_Bundle,'vwnd',TEMP3D, RC=STATUS) -! VERIFY_(STATUS) - if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Replaying vwnd' - vars%v = TEMP3D - endif -! PE - call ESMFL_BundleGetPointertoData(DNS_Bundle,'delp',TEMP3D, RC=STATUS) -! VERIFY_(STATUS) - DNS_PRESSURE: if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Replaying ple' - vars%pe(:,:,1) = grid%ak(1) - do k=2,km+1 - vars%pe(:,:,k) = vars%pe(:,:,k-1) + temp3d(:,:,k-1) - enddo - end if DNS_PRESSURE -! O3 - call ESMFL_BundleGetPointertoData(DNS_Bundle,'ozone',TEMP3D, RC=STATUS) -! VERIFY_(STATUS) - DNS_OZONE: if(STATUS==ESMF_SUCCESS) then - -! Ozone needs to be adjusted to OX -!----------------------------------- - if(grid%iam==0) print *, 'Replaying ozone' - - call MAPL_Get(MAPL, LONS=LONS, LATS=LATS, ORBIT=ORBIT, RC=STATUS ) - VERIFY_(STATUS) - - allocate( ZTH( size(LONS,1),size(LONS,2) ) ) - allocate( SLR( size(LONS,1),size(LONS,2) ) ) - - call MAPL_SunGetInsolation( LONS,LATS,ORBIT,ZTH,SLR, CLOCK=CLOCK,RC=STATUS ) - VERIFY_(STATUS) - - pl = ( vars%pe(:,:,2:) + vars%pe(:,:,:km) ) * 0.5 - - do L=1,km - if( ooo%is_r4 ) then - where(PL(:,:,L) >= 100.0 .or. ZTH <= 0.0) & - ooo%content_r4(:,:,L) = TEMP3D(:,:,L)*1.0E-6 - else - where(PL(:,:,L) >= 100.0 .or. ZTH <= 0.0) & - ooo%content (:,:,L) = TEMP3D(:,:,L)*1.0E-6 - end if - enddo - - deallocate( ZTH, SLR ) - - end if DNS_OZONE -! QV - call ESMFL_BundleGetPointertoData(DNS_Bundle,'sphu',TEMP3D, RC=STATUS) -! VERIFY_(STATUS) - DSN_HUMIDITY: if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Replaying sphu' - if( qqq%is_r4 ) then - qqq%content_r4 = TEMP3D - else - qqq%content = TEMP3D - endif - end if DSN_HUMIDITY -! PT - call ESMFL_BundleGetPointertoData(DNS_Bundle,'theta',TEMP3D, RC=STATUS) -! VERIFY_(STATUS) - DSN_THETAV: if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Replaying thetav' - DNS_thv = TEMP3D - else - if( qqq%is_r4 ) then - DNS_thv = vars%pt*(1.0+eps*qqq%content_r4) - else - DNS_thv = vars%pt*(1.0+eps*qqq%content ) - endif - end if DSN_THETAV - -! If there is a topo in the file, remap fields -!--------------------------------------------- - - call ESMFL_BundleGetPointertoData(DNS_Bundle,'phis',TEMP2D, RC=STATUS) -! VERIFY_(STATUS) - if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Remapping ...' - DNS_phis = TEMP2D - call remap ( vars%pe, vars%u, vars%v, DNS_thv, vars%tracer, DNS_phis, phisxy, & - grid%ak, grid%bk, size(DNS_thv,1), size(DNS_thv,2), km, nq ) - end if - - if( qqq%is_r4 ) then - vars%pt = dns_thv/(1.0+eps*qqq%content_r4) - else - vars%pt = dns_thv/(1.0+eps*qqq%content ) - endif - - pkxy = vars%pe**kappa - do k=1,km - vars%pkz(:,:,k) = ( pkxy(:,:,k+1)-pkxy(:,:,k) ) & - / ( kappa*( log(vars%pe(:,:,k+1))-log(vars%pe(:,:,k)) ) ) - enddo - -! Done with replay; clean-up -!--------------------------- - - call ESMF_FieldBundleGet(DNS_Bundle , FieldCount=NUMVARS, RC=STATUS) - VERIFY_(STATUS) - - do k=1,NUMVARS - call ESMF_FieldBundleGet (DNS_Bundle, k, DNS_FIELD, RC=STATUS) - VERIFY_(STATUS) - call MAPL_FieldDestroy (DNS_Field, RC=STATUS) - VERIFY_(STATUS) - end do - - call ESMF_FieldBundleDestroy(DNS_Bundle, RC=STATUS) - VERIFY_(STATUS) - - DEALLOCATE( DNS_phis ) - DEALLOCATE( DNS_thv ) - - end if TIME_TO_REPLAY - end if REPLAYING - -! Create Local Copy of QV and OX (Contains Updates from Analysis) -!---------------------------------------------------------------- - - ox = 0.0d0 ! Initialize in case no OX advection - do k=1,size(names) - pos = index(names(k),'::') - if(pos > 0) then - if( (names(k)(pos+2:))=='OX' ) then - if ( ooo%is_r4 ) then - ox = ooo%content_r4 - else - ox = ooo%content - endif - endif - endif - if( trim(names(k))=='Q' ) then - if ( qqq%is_r4 ) then - qv = qqq%content_r4 - else - qv = qqq%content - endif - endif - enddo - -! G3 Initialization -! ----------------- - if( first ) then - - call MAPL_GetResource( MAPL, NX, 'NX:', RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource( MAPL, NY, 'NY:', RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource( MAPL, imglobal, 'AGCM_IM:', RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource( MAPL, jmglobal, 'AGCM_JM:', RC=STATUS ) ; VERIFY_(STATUS) - - call create_dynamics_lattice ( dynamics%grid%lattice,nx,ny ) - call init_dynamics_lattice ( dynamics%grid%lattice,mpi_comm_world,imglobal,jmglobal,km ) - - im = dynamics%grid%lattice%im( dynamics%grid%lattice%pei ) - jm = dynamics%grid%lattice%jm( dynamics%grid%lattice%pej ) - -! Create G3 Dynamics State -! ------------------------ - call create_dynamics ( dynamics,im,jm,km,nq ) - -! Initialize G3 Dynamics Grid -! --------------------------- - call init_dynamics_grid ( dynamics%grid,imglobal,jmglobal,km,nq,grid%ak,grid%bk ) - - first = .false. - endif - - im = dynamics%grid%im - jm = dynamics%grid%jm - -! Diagnostics Before Analysis Increments are Added -!------------------------------------------------- - - call MAPL_GetPointer ( IMPORT, dqvana, 'DQVANA', RC=STATUS ) ! Get QV Increment from Analysis - VERIFY_(STATUS) - call MAPL_GetPointer ( IMPORT, dqlana, 'DQLANA', RC=STATUS ) ! Get QL Increment from Analysis - VERIFY_(STATUS) - call MAPL_GetPointer ( IMPORT, dqiana, 'DQIANA', RC=STATUS ) ! Get QI Increment from Analysis - VERIFY_(STATUS) - call MAPL_GetPointer ( IMPORT, doxana, 'DOXANA', RC=STATUS ) ! Get OX Increment from Analysis - VERIFY_(STATUS) - - QL = 0.0 - QI = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - if( state%vars%tracer(N)%is_r4 ) then - QL = QL + state%vars%tracer(N)%content_r4 - else - QL = QL + state%vars%tracer(N)%content - endif - endif - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - if( state%vars%tracer(N)%is_r4 ) then - QI = QI + state%vars%tracer(N)%content_r4 - else - QI = QI + state%vars%tracer(N)%content - endif - endif - enddo - QVOLD = QV-DQVANA - QLOLD = QL-DQLANA - QIOLD = QI-DQIANA - - QDOLD = 1.0 - (QVOLD+QLOLD+QIOLD) - QDNEW = 1.0 - (QV +QL +QI ) - - call ctoa_winds ( vars%u,vars%v,ua,va, & - dynamics%grid%dlam,dynamics%grid%dphi,im,jm,km,dynamics%grid%lattice ) - - delp = vars%pe(:,:,2:) -vars%pe(:,:,:km) ! Pressure Thickness - dmdt = vars%pe(:,:,km+1)-vars%pe(:,:,1) ! Psurf-Ptop - tempxy = vars%pt * (1.0+eps*(qv-dqvana)) ! Compute THV Before Analysis Update - - call Energetics (state,vars%u,vars%v,tempxy,vars%pe,delp,vars%pkz,phisxy,kenrg,penrg,tenrg,dynamics%grid) - -! DUDTANA -! ------- - call MAPL_GetPointer ( export, dudtana, 'DUDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dudtana) ) dudtana = ua - -! DVDTANA -! ------- - call MAPL_GetPointer ( export, dvdtana, 'DVDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dvdtana) ) dvdtana = va - -! DTDTANA -! ------- - call MAPL_GetPointer ( export, dtdtana, 'DTDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dtdtana) ) dtdtana = vars%pt * vars%pkz - -! DDELPDTANA -! ---------- - call MAPL_GetPointer ( export, ddpdtana, 'DDELPDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(ddpdtana) ) ddpdtana = delp - -! DTHVDTANAINT -! ------------ - call MAPL_GetPointer ( export, temp2D, 'DTHVDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = vars%pt*(1+eps*(qv-dqvana)) ! Set tempxy = TH*QVold (Before Analysis Update) - dthdtanaint1 = 0.0 - do k=1,km - dthdtanaint1 = dthdtanaint1 + tempxy(:,:,k)*delp(:,:,k) - enddo - endif - -! DQVDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQVDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = qv-dqvana ! Set tempxy = QVold (Before Analysis Update) - dqvdtanaint1 = 0.0 - do k=1,km - dqvdtanaint1 = dqvdtanaint1 + tempxy(:,:,k)*delp(:,:,k) - enddo - endif - -! DQLDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQLDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dqldtanaint1 = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - do k=1,km - if( state%vars%tracer(N)%is_r4 ) then - dqldtanaint1 = dqldtanaint1 + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - else - dqldtanaint1 = dqldtanaint1 + state%vars%tracer(N)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - do k=1,km - dqldtanaint1 = dqldtanaint1 - dqlana(:,:,k)*delp(:,:,k) - enddo - endif - -! DQIDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQIDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dqidtanaint1 = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - do k=1,km - if( state%vars%tracer(N)%is_r4 ) then - dqidtanaint1 = dqidtanaint1 + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - else - dqidtanaint1 = dqidtanaint1 + state%vars%tracer(N)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - do k=1,km - dqidtanaint1 = dqidtanaint1 - dqiana(:,:,k)*delp(:,:,k) - enddo - endif - -! DOXDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DOXDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = ox-doxana ! Set tempxy = OXold (Before Analysis Update) - doxdtanaint1 = 0.0 - do k=1,km - doxdtanaint1 = doxdtanaint1 + tempxy(:,:,k)*delp(:,:,k) - enddo - endif - -! Add Diabatic Forcing from Analysis to State Variables -! ----------------------------------------------------- - - allocate( trsum1(nq) ) - allocate( trsum2(nq) ) - - ! Compute Global Mass of Aerosol Constituents Before ANA Updates - ! -------------------------------------------------------------- - call glosum ( STATE,NQ,TRSUM1 ) - - call ADD_INCS ( STATE,IMPORT,DT,dynamics%grid ) - -! Update Specific Mass of Aerosol Constituents Keeping Mixing_Ratio Constant WRT_Dry_Air After ANA Updates -! -------------------------------------------------------------------------------------------------------- - do n=1,NQ - if( (trim(names(n)).ne.'Q' ) .and. & - (trim(names(n)).ne.'QLLS') .and. & - (trim(names(n)).ne.'QLCN') .and. & - (trim(names(n)).ne.'QILS') .and. & - (trim(names(n)).ne.'QICN') .and. & - (trim(names(n)).ne.'CLLS') .and. & - (trim(names(n)).ne.'CLCN') ) then - if( STATE%VARS%TRACER(N)%IS_R4 ) then - state%vars%tracer(n)%content_r4 = state%vars%tracer(n)%content_r4 * ( QDNEW/QDOLD ) - else - state%vars%tracer(n)%content = state%vars%tracer(n)%content * ( QDNEW/QDOLD ) - endif - endif - enddo - - ! Compute Global Mass of Aerosol Constituents After ANA Updates - ! ------------------------------------------------------------- - call glosum ( STATE,NQ,TRSUM2 ) - - ! Ensure Conservation of Global Mass of Aerosol Constituents After ANA Updates - ! ---------------------------------------------------------------------------- - do n=1,NQ - if( (trim(names(n)).ne.'Q' ) .and. & - (trim(names(n)).ne.'QLLS') .and. & - (trim(names(n)).ne.'QLCN') .and. & - (trim(names(n)).ne.'QILS') .and. & - (trim(names(n)).ne.'QICN') .and. & - (trim(names(n)).ne.'CLLS') .and. & - (trim(names(n)).ne.'CLCN') ) then - - if( trsum2(n).ne.0.0d0 ) then - trsum2(n) = trsum1(n)/trsum2(n) - else - trsum2(n) = 1.0d0 - endif - !IF (MAPL_AM_I_ROOT()) print *, trim(names(n)),' ratio is: ',trsum2(n) - - if( STATE%VARS%TRACER(N)%IS_R4 ) then - state%vars%tracer(n)%content_r4 = state%vars%tracer(n)%content_r4 * trsum2(n) - else - state%vars%tracer(n)%content = state%vars%tracer(n)%content * trsum2(n) - endif - endif - enddo - - deallocate( trsum1 ) - deallocate( trsum2 ) - -! Update Local Copy of QV and OX to account for Global Sum Adjustment -!-------------------------------------------------------------------- - - do k=1,size(names) - pos = index(names(k),'::') - if(pos > 0) then - if( (names(k)(pos+2:))=='OX' ) then - if ( ooo%is_r4 ) then - ox = ooo%content_r4 - else - ox = ooo%content - endif - endif - endif - if( trim(names(k))=='Q' ) then - if ( qqq%is_r4 ) then - qv = qqq%content_r4 - else - qv = qqq%content - endif - endif - enddo - -! Diagnostics After Analysis Increments are Added -!------------------------------------------------ - - call MAPL_GetPointer ( export, temp2D, 'DMDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) temp2D = ( (vars%pe(:,:,km+1)-vars%pe(:,:,1)) - dmdt )/(grav*dt) - - call ctoa_winds ( vars%u,vars%v,ua,va, & - dynamics%grid%dlam,dynamics%grid%dphi,im,jm,km,dynamics%grid%lattice ) - - delp = vars%pe(:,:,2:) -vars%pe(:,:,:km) ! Pressure Thickness - dmdt = vars%pe(:,:,km+1)-vars%pe(:,:,1) ! Psurf-Ptop - -! DUDTANA -! ------- - call MAPL_GetPointer ( export, dudtana, 'DUDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dudtana) ) then - dummy = ua - dudtana = (dummy-dudtana)/dt - endif - -! DVDTANA -! ------- - call MAPL_GetPointer ( export, dvdtana, 'DVDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dvdtana) ) then - dummy = va - dvdtana = (dummy-dvdtana)/dt - endif - -! DTDTANA -! ------- - call MAPL_GetPointer ( export, dtdtana, 'DTDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dtdtana) ) then - dummy = vars%pt*vars%pkz - dtdtana = (dummy-dtdtana)/dt - endif - -! DDELPDTANA -! ---------- - call MAPL_GetPointer ( export, ddpdtana, 'DDELPDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(ddpdtana) ) then - dummy = delp - ddpdtana = (dummy-ddpdtana)/dt - endif - -! DTHVDTANAINT -! ------------ - call MAPL_GetPointer ( export, temp2D, 'DTHVDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = vars%pt*(1+eps*qv) ! Set tempxy = TH*QVnew (After Analysis Update) - dthdtanaint2 = 0.0 - do k=1,km - dthdtanaint2 = dthdtanaint2 + tempxy(:,:,k)*delp(:,:,k) - enddo - temp2D = (dthdtanaint2-dthdtanaint1) * MAPL_P00**MAPL_KAPPA / (MAPL_GRAV*DT) - endif - -! DQVDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQVDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = qv ! Set tempxy = QNEW (After Analysis Update) - dqvdtanaint2 = 0.0 - do k=1,km - dqvdtanaint2 = dqvdtanaint2 + tempxy(:,:,k)*delp(:,:,k) - enddo - temp2D = (dqvdtanaint2-dqvdtanaint1) / (MAPL_GRAV*DT) - endif - -! DQLDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQLDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dqldtanaint2 = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - do k=1,km - if( state%vars%tracer(N)%is_r4 ) then - dqldtanaint2 = dqldtanaint2 + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - else - dqldtanaint2 = dqldtanaint2 + state%vars%tracer(N)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2D = (dqldtanaint2-dqldtanaint1) / (MAPL_GRAV*DT) - endif - -! DQIDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQIDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dqidtanaint2 = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - do k=1,km - if( state%vars%tracer(N)%is_r4 ) then - dqidtanaint2 = dqidtanaint2 + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - else - dqidtanaint2 = dqidtanaint2 + state%vars%tracer(N)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2D = (dqidtanaint2-dqidtanaint1) / (MAPL_GRAV*DT) - endif - -! DOXDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DOXDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = ox ! Set tempxy = OXnew (After Analysis Update) - doxdtanaint2 = 0.0 - do k=1,km - doxdtanaint2 = doxdtanaint2 + tempxy(:,:,k)*delp(:,:,k) - enddo - temp2D = (doxdtanaint2-doxdtanaint1) * (MAPL_O3MW/MAPL_AIRMW) / (MAPL_GRAV*DT) - endif - -! Create FV Thermodynamic Variables -!---------------------------------- - - tempxy = vars%pt * vars%pkz ! Compute Dry Temperature - vars%pt = vars%pt * (1.0+eps*qv) ! Compute Virtual Potential Temperature - -! Initialize Diagnostic Dynamics Tendencies -! ----------------------------------------- - - ddpdt = delp ! Pressure Thickness Tendency - dudt = ua ! U-Wind on A-Grid Tendency - dvdt = va ! V-Wind on A-Grid Tendency - dtdt = tempxy ! Dry Temperature Tendency - dqdt = qv ! Specific Humidity Tendency - -! Initialize 3-D Tracer Dynamics Tendencies -! ----------------------------------------- - - call MAPL_GetPointer( export,dqldt,'DQLDTDYN', rc=status ) - VERIFY_(STATUS) - if( associated(dqldt) ) then - dqldt = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - if( state%vars%tracer(N)%is_r4 ) then - dqldt = dqldt - state%vars%tracer(N)%content_r4 - else - dqldt = dqldt - state%vars%tracer(N)%content - endif - endif - enddo - endif - - call MAPL_GetPointer( export,dqidt,'DQIDTDYN', rc=status ) - VERIFY_(STATUS) - if( associated(dqidt) ) then - dqidt = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - if( state%vars%tracer(N)%is_r4 ) then - dqidt = dqidt - state%vars%tracer(N)%content_r4 - else - dqidt = dqidt - state%vars%tracer(N)%content - endif - endif - enddo - endif - - call MAPL_GetPointer( export,doxdt,'DOXDTDYN', rc=status ) - VERIFY_(STATUS) - if( associated(doxdt) ) then - doxdt = 0.0 - do N = 1,size(names) - pos = index(names(N),'::') - if(pos > 0) then - if( (names(N)(pos+2:))=='OX' ) then - if( state%vars%tracer(N)%is_r4 ) then - doxdt = doxdt - state%vars%tracer(N)%content_r4 - else - doxdt = doxdt - state%vars%tracer(N)%content - endif - endif - endif - enddo - endif - -! Initialize 2-D Vertically Integrated Tracer Dynamics Tendencies -! --------------------------------------------------------------- - - call MAPL_GetPointer ( export, temp2D, 'DQVDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempr8(:,:,1) = 0.0 - do k=1,km - tempr8(:,:,1) = tempr8(:,:,1) + qv(:,:,k)*delp(:,:,k) - enddo - endif - - call MAPL_GetPointer ( export, temp2D, 'DQLDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - enddo - endif - - call MAPL_GetPointer ( export, temp2D, 'DQIDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - enddo - endif - - call MAPL_GetPointer ( export, temp2D, 'DOXDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - temp2d = 0.0 - do N = 1,size(names) - pos = index(names(N),'::') - if(pos > 0) then - if( (names(N)(pos+2:))=='OX' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - endif - enddo - endif - - -! Compute Energetics After Analysis (and Before Dycore) -! ----------------------------------------------------- - - call Energetics (state,vars%u,vars%v,vars%pt,vars%pe,delp,vars%pkz,phisxy, & - kenrg0,penrg0,tenrg0,dynamics%grid,ke=ke,cpt=cpt,gze=gze) - - kenrg = (kenrg0-kenrg)/DT - penrg = (penrg0-penrg)/DT - tenrg = (tenrg0-tenrg)/DT - - call FILLOUT2 (export, 'KEANA', kenrg, rc=status); VERIFY_(STATUS) - call FILLOUT2 (export, 'PEANA', penrg, rc=status); VERIFY_(STATUS) - call FILLOUT2 (export, 'TEANA', tenrg, rc=status); VERIFY_(STATUS) - -! Add Passive Tracers for KE and PHI+CpT -! -------------------------------------- - - nq = STATE%GRID%NQ - - phi00 = 0.0 - do k=1,km - phi(:,:,k) = ( gze(:,:,k+1)*vars%pe(:,:,k+1)-gze(:,:,k)*vars%pe(:,:,k) )/delp(:,:,k) + (1+kappa)*cpt(:,:,k) - phi00 = phi00 + phi(:,:,k)*delp(:,:,k) - enddo - phi00 = phi00 / grav - - if( NXQ.eq.2 ) then - NKE = nq-1 - NPHI = nq - state%vars%tracer(NKE )%content => KE - state%vars%tracer(NPHI)%content => PHI - state%vars%tracer(NKE )%is_r4 = .false. - state%vars%tracer(NPHI)%is_r4 = .false. - else - NKE = -999 - NPHI = -999 - endif - - dthdt = vars%pt*delp - -! Clear mass fluxes -!------------------ - - ptfxxyz (:,:,:) = 0. - ptfyxyz (:,:,:) = 0. - mfxxyz_ur(:,:,:) = 0. - mfyxyz_ur(:,:,:) = 0. - mfxxyz (:,:,:) = 0. - mfyxyz (:,:,:) = 0. - mfzxyz (:,:,:) = 0. - mfxxyz_a (:,:,:) = 0. - mfyxyz_a (:,:,:) = 0. - -! Call Wrapper for FVDycore -! ------------------------- - call MAPL_GetResource( MAPL, CONSV, 'CONSV:', default=1, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, FILL, 'FILL:', default=0, RC=STATUS ) - VERIFY_(STATUS) - - LCONSV = CONSV.eq.1 - LFILL = FILL.eq.1 - -! Load FV Variables into G3 Dynamics State -! ---------------------------------------- - dynamics%vars(1)%p(:,:) = ( state%vars%pe(:,:,km+1) - dynamics%grid%ptop ) ! Convert to PI=(PS-PTOP) in Pa - dynamics%vars(1)%u(:,:,:) = state%vars%u (:,:,:) - dynamics%vars(1)%v(:,:,:) = state%vars%v (:,:,:) - - allocate( pke(im,jm,km+1) ) - allocate( pk (im,jm,km ) ) - - call getpke( dynamics%vars(1)%p,pke ,dynamics%grid,im,jm ) - call getpk ( dynamics%vars(1)%p,pke,pk,dynamics%grid,im,jm ) - - dynamics%vars(1)%t(:,:,:) = tempxy(:,:,:) / pk(:,:,:) - - do n=1,dynamics%grid%ntracer - if( state%vars%tracer(n)%is_r4 ) then - dynamics%vars(1)%q(:,:,:,n) = state%vars%tracer(n)%content_r4(:,:,:) - else - dynamics%vars(1)%q(:,:,:,n) = state%vars%tracer(n)%content (:,:,:) - endif - enddo - -! Initialize TRSUMs for Conservation of Tracers -! --------------------------------------------- - - allocate( trsum1(nq) ) - allocate( trsum2(nq) ) - - call glosum ( STATE,NQ,TRSUM1 ) - -! Call Dynamics Wrapper -! --------------------- - call MAPL_TimerOn (MAPL,"-WRAPPER") - - call MAPL_GetResource( MAPL, scheme, 'TSCHEME:', DEFAULT='LEAP',RC=STATUS ) ; VERIFY_(STATUS) - call MAPL_GetResource( MAPL, alpha, 'ALPHA:', DEFAULT=0.05, RC=STATUS ) ; VERIFY_(STATUS) - - nsplit = state%nsplit - dynamics%vars(1)%t(:,:,:) = dynamics%vars(1)%t(:,:,:)*(1.0+eps*dynamics%vars(1)%q(:,:,:,kq)) - call g3_wrapper (dynamics,phisxy,scheme,dt,nsplit,alpha,omaxyz) - dynamics%vars(1)%t(:,:,:) = dynamics%vars(1)%t(:,:,:)/(1.0+eps*dynamics%vars(1)%q(:,:,:,kq)) - - vars%pe(:,:,km+1) = ( dynamics%vars(1)%p(:,:) + dynamics%grid%ptop ) ! Construct PS = PI+PTOP in Pa - - pelnxz = 0 - cptxyz = 0 - thvxyz = 0 - epvxyz = 0 - cxxyz = 0 - cyxyz = 0 - ptfxxyz = 0 - ptfyxyz = 0 - mfxxyz_ur = 0 - mfyxyz_ur = 0 - mfxxyz = 0 - mfyxyz = 0 - mfzxyz = 0 - kenrga = 0 - penrga = 0 - tenrga = 0 - kenrgb = 0 - penrgb = 0 - tenrgb = 0 - keadv = 0 - kepg = 0 - kedp = 0 - kehot = 0 - dthdtremap = 0 - dthdtconsv = 0 - dtmp = 0 - - call MAPL_TimerOff(MAPL,"-WRAPPER") - -! Copy G3 Dynamics State back to FV State -! --------------------------------------- - do k=1,km - vars%pe(:,:,k) = dynamics%grid%sige(k)*( vars%pe(:,:,km+1)-dynamics%grid%ptop ) + dynamics%grid%ptop - enddo - - pkxy = vars%pe**kappa - do k=1,km - vars%pkz(:,:,k) = ( pkxy(:,:,k+1)-pkxy(:,:,k) ) & - / ( kappa*( log(vars%pe(:,:,k+1))-log(vars%pe(:,:,k)) ) ) -! vars%pkz(:,:,k) = ( pkxy(:,:,k+1)*vars%pe(:,:,k+1)-pkxy(:,:,k)*vars%pe(:,:,k) ) & -! / ( vars%pe(:,:,k+1)- vars%pe(:,:,k) ) / (1+kappa) - enddo - - vars%u(:,:,:) = dynamics%vars(1)%u(:,:,:) - vars%v(:,:,:) = dynamics%vars(1)%v(:,:,:) - - call getpke( dynamics%vars(1)%p,pke ,dynamics%grid,im,jm ) - call getpk ( dynamics%vars(1)%p,pke,pk,dynamics%grid,im,jm ) - tempxy(:,:,:) = dynamics%vars(1)%t(:,:,:)*pk(:,:,:)*(1+eps*dynamics%vars(1)%q(:,:,:,kq)) ! Virtual Temperature - - vars%pt(:,:,:) = tempxy/vars%pkz ! Virtual Potential Temperature - - do n=1,dynamics%grid%ntracer - if( state%vars%tracer(n)%is_r4 ) then - state%vars%tracer(n)%content_r4(:,:,:) = dynamics%vars(1)%q(:,:,:,n) - else - state%vars%tracer(n)%content (:,:,:) = dynamics%vars(1)%q(:,:,:,n) - endif - enddo - - deallocate (pke) - deallocate (pk ) - -! Adjust Tracers for Conservation (due to Shapiro Filter) -! ------------------------------------------------------- - - call glosum ( STATE,NQ,TRSUM2 ) - - do n=1,NQ - if( (trim(names(n)).ne.'CLLS') .and. & - (trim(names(n)).ne.'CLCN') ) then - if( trsum2(n).ne.0.0d0 ) then - trsum2(n) = trsum1(n)/trsum2(n) - else - trsum2(n) = 1.0d0 - endif - if( STATE%VARS%TRACER(N)%IS_R4 ) then - state%vars%tracer(n)%content_r4 = state%vars%tracer(n)%content_r4 * trsum2(n) - else - state%vars%tracer(n)%content = state%vars%tracer(n)%content * trsum2(n) - endif - endif - enddo - - deallocate( trsum1 ) - deallocate( trsum2 ) - -! Vertically Integrated THV Tendency Diagnostic -! --------------------------------------------- - delp = ( vars%pe(:,:,2:) - vars%pe(:,:,:km) ) - dthdt = ( vars%pt*delp-dthdt )/dt - - call MAPL_GetPointer(export,temp2d,'DTHVDTDYNINT', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - qsum1 = 0.0 - do k=1,km - qsum1 = qsum1 + dthdt(:,:,k) - enddo - temp2d = qsum1 * (MAPL_P00**MAPL_KAPPA) / grav - end if - - call MAPL_GetPointer(export,temp2d,'DTHVDTREMAP', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = dthdtremap - - call MAPL_GetPointer(export,temp2d,'DTHVDTCONSV', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = dthdtconsv - -! Unify Poles for Tracers -! ----------------------- - - call PUSH_Q ( STATE ) - -! Load Local Variable with Vapor Specific Humidity -! ------------------------------------------------ - - if ( qqq%is_r4 ) then - qv = qqq%content_r4 - else - qv = qqq%content - endif - -! Compute Dry Theta and T with Unified Poles -! ------------------------------------------ - - vars%pt = vars%pt / (1.0+eps*qv ) - tempxy = vars%pt * vars%pkz - -! Compute Mid-Layer Pressure and Pressure Thickness -! ------------------------------------------------- - - delp = ( vars%pe(:,:,2:) - vars%pe(:,:,:km) ) - pl = ( vars%pe(:,:,2:) + vars%pe(:,:,:km) ) * 0.5 - -! Compute Tropopause Pressure, Temperature, and Moisture -! ------------------------------------------------------ - - call tropovars ( ilastxy-ifirstxy+1,jlastxy-jfirstxy+1,km, & - real(vars%pe ,kind=4), & - real(pl ,kind=4), & - real(tempxy ,kind=4), & - real(qv ,kind=4), & - real(epvxyz*(p00**kappa),kind=4), & - tropp1,tropp2,tropp3,tropt,tropq ) - - call MAPL_GetPointer(export,temp2D,'TROPP_THERMAL',rc=status) - VERIFY_(STATUS) - if(associated(temp2D)) temp2D = tropp1 - - call MAPL_GetPointer(export,temp2D,'TROPP_EPV',rc=status) - VERIFY_(STATUS) - if(associated(temp2D)) temp2D = tropp2 - - call MAPL_GetPointer(export,temp2D,'TROPP_BLENDED',rc=status) - VERIFY_(STATUS) - if(associated(temp2D)) temp2D = tropp3 - - call MAPL_GetPointer(export,temp2D,'TROPT',rc=status) - VERIFY_(STATUS) - if(associated(temp2D)) temp2D = tropt - - call MAPL_GetPointer(export,temp2D,'TROPQ',rc=status) - VERIFY_(STATUS) - if(associated(temp2D)) temp2D = tropq - -! Compute A-Grid Winds -! -------------------- - call ctoa_winds ( dynamics%vars(1)%u,dynamics%vars(1)%v,ua,va, & - dynamics%grid%dlam,dynamics%grid%dphi,im,jm,km,dynamics%grid%lattice ) - -! Compute A-Grid Mass Fluxes -! -------------------------- - call c2a3d( grid, mfxxyz, mfyxyz, mfxxyz_a, mfyxyz_a ) - -! Compute Diagnostic Dynamics Tendencies -! (Note: initial values of d(m,u,v,T,q)/dt are progs m,u,v,T,q) -! -------------------------------------------------------------- - - dmdt = ( vars%pe(:,:,km+1)-vars%pe(:,:,1) - dmdt )/(grav*dt) - - dudt = ( ua-dudt )/dt - dvdt = ( va-dvdt )/dt - dtdt = (tempxy-dtdt )/dt - dqdt = ( qv-dqdt )/dt - - ddpdt = ( delp - ddpdt )/dt ! Pressure Thickness Tendency - - call FILLOUT3 (export, 'DELP' ,delp , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'DUDTDYN' ,dudt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'DVDTDYN' ,dvdt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'DTDTDYN' ,dtdt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'DQVDTDYN' ,dqdt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'DDELPDTDYN',ddpdt, rc=status); VERIFY_(STATUS) - - call FILLOUT3 (export, 'U_CGRID' ,cxxyz, rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'V_CGRID' ,cyxyz, rc=status); VERIFY_(STATUS) - - call FILLOUT3 (export, 'PTFX' , ptfxxyz , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PTFY' , ptfyxyz , rc=status); VERIFY_(STATUS) - - call FILLOUT3 (export, 'MFX_UR' , mfxxyz_ur , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFY_UR' , mfyxyz_ur , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFX' , mfxxyz , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFY' , mfyxyz , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFZ' , mfzxyz , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFX_A' , mfxxyz_a, rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFY_A' , mfyxyz_a, rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'U' , ua , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'V' , va , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'T' , tempxy , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'Q' , qv , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PL' , pl , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PLE' , vars%pe , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PLK' , vars%pkz, rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'U_DGRID', vars%u , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'V_DGRID', vars%v , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PT' , vars%pt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PE' , vars%pe , rc=status); VERIFY_(STATUS) - - call MAPL_GetPointer(export, temp3D, 'EPV', rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = epvxyz*(p00**kappa) - - call MAPL_GetPointer(export, temp3D, 'PV', rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = epvxyz/vars%pt - - call MAPL_GetPointer(export, temp3D, 'S', rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = tempxy*cp - - call MAPL_GetPointer(export, temp3d, 'TH',rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = vars%pt*(p00**kappa) - - call MAPL_GetPointer(export, temp2d, 'DMDTDYN',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = dmdt - - -! Compute 3-D Tracer Dynamics Tendencies -! -------------------------------------- - - if( associated(dqldt) ) then - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - if( state%vars%tracer(N)%is_r4 ) then - dqldt = dqldt + state%vars%tracer(N)%content_r4 - else - dqldt = dqldt + state%vars%tracer(N)%content - endif - endif - enddo - dqldt = dqldt/dt - endif - - if( associated(dqidt) ) then - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - if( state%vars%tracer(N)%is_r4 ) then - dqidt = dqidt + state%vars%tracer(N)%content_r4 - else - dqidt = dqidt + state%vars%tracer(N)%content - endif - endif - enddo - dqidt = dqidt/dt - endif - - if( associated(doxdt) ) then - do N = 1,size(names) - pos = index(names(N),'::') - if(pos > 0) then - if( (names(N)(pos+2:))=='OX' ) then - if( state%vars%tracer(N)%is_r4 ) then - doxdt = doxdt + state%vars%tracer(N)%content_r4 - else - doxdt = doxdt + state%vars%tracer(N)%content - endif - endif - endif - enddo - doxdt = doxdt/dt - endif - -! Compute 2-D Vertically Integrated Tracer Dynamics Tendencies -! ------------------------------------------------------------ - - call MAPL_GetPointer ( export, temp2D, 'DQVDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempr8(:,:,2) = 0.0 - do k=1,km - tempr8(:,:,2) = tempr8(:,:,2) + qv(:,:,k)*delp(:,:,k) - enddo - tempr8(:,:,2) = ( tempr8(:,:,2)-tempr8(:,:,1) )/(grav*dt) - temp2d = tempr8(:,:,2) - endif - - call MAPL_GetPointer ( export, temp2D, 'DQLDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - enddo - temp2d = temp2d/(grav*dt) - endif - - call MAPL_GetPointer ( export, temp2D, 'DQIDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - enddo - temp2d = temp2d/(grav*dt) - endif - - call MAPL_GetPointer ( export, temp2D, 'DOXDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - do N = 1,size(names) - pos = index(names(N),'::') - if(pos > 0) then - if( (names(N)(pos+2:))=='OX' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - endif - enddo - temp2d = temp2d * (MAPL_O3MW/MAPL_AIRMW) / (MAPL_GRAV*DT) - endif - -! Fill Surface and Near-Surface Variables -! --------------------------------------- - - call MAPL_GetPointer(export,temp2d,'PS', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = vars%pe(:,:,km+1) - - call MAPL_GetPointer(export,temp2d,'US', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = ua(:,:,km) - - call MAPL_GetPointer(export,temp2d,'VS' ,rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = va(:,:,km) - - call MAPL_GetPointer(export,temp2d,'TA' ,rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = tempxy(:,:,km) - - call MAPL_GetPointer(export,temp2d,'QA' ,rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = qv(:,:,km) - - call MAPL_GetPointer(export,temp2d,'SPEED',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = sqrt( ua(:,:,km)**2 + va(:,:,km)**2 ) - - -! Virtual temperature -! ------------------- - - tempxy = tempxy*(1.0+eps*qv) - - call MAPL_GetPointer(export,temp3D,'TV' ,rc=status) - VERIFY_(STATUS) - if(associated(temp3D)) temp3D = tempxy - - -! Fluxes: UCPT & VCPT -!-------------------- - call MAPL_GetPointer(export,temp2d,'UCPT',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + ua(:,:,k)*tempxy(:,:,k)*delp(:,:,k) - enddo - temp2d = temp2d*(cp/grav) - end if - - call MAPL_GetPointer(export,temp2d,'VCPT',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + va(:,:,k)*tempxy(:,:,k)*delp(:,:,k) - enddo - temp2d = temp2d*(cp/grav) - end if - - -! Compute Energetics After Dycore -! ------------------------------- - - tempxy = vars%pt*(1.0+eps*qv) ! Convert TH to THV - - call MAPL_GetPointer(export,temp3d,'THV',rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = tempxy - - call Energetics (state,vars%u,vars%v,tempxy,vars%pe,delp,vars%pkz,phisxy,kenrg,penrg,tenrg,dynamics%grid) - - kedyn = (kenrg -kenrg0)/DT - pedyn = (penrg -penrg0)/DT - tedyn = (tenrg -tenrg0)/DT - - kecdcor = (kenrga-kenrg0)/DT - pecdcor = (penrga-penrg0)/DT - tecdcor = (tenrga-tenrg0)/DT - - keremap = (kenrgb-kenrga)/DT - peremap = (penrgb-penrga)/DT - teremap = (tenrgb-tenrga)/DT - - call MAPL_GetPointer(export,temp2d,'KEDYN',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kedyn - - call MAPL_GetPointer(export,temp2d,'PEDYN',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = pedyn - - call MAPL_GetPointer(export,temp2d,'TEDYN',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = tedyn - - call MAPL_GetPointer(export,temp2d,'KECDCOR',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kecdcor - - call MAPL_GetPointer(export,temp2d,'PECDCOR',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = pecdcor - - call MAPL_GetPointer(export,temp2d,'TECDCOR',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = tecdcor - - call MAPL_GetPointer(export,temp2d,'KEREMAP',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = keremap - - call MAPL_GetPointer(export,temp2d,'PEREMAP',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = peremap - - call MAPL_GetPointer(export,temp2d,'TEREMAP',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = teremap - - -! Fluxes: UKE & VKE -! ----------------- - call MAPL_GetPointer(export,tempu,'UKE',rc=status); VERIFY_(STATUS) - call MAPL_GetPointer(export,tempv,'VKE',rc=status); VERIFY_(STATUS) - - if(associated(tempu) .or. associated(tempv)) then - ke = 0.5*(ua**2 + va**2) - end if - - if(associated(tempu)) then - tempu = 0.0 - do k=1,km - tempu = tempu + ua(:,:,k)*ke(:,:,k)*delp(:,:,k) - enddo - tempu = tempu / grav - end if - - if(associated(tempv)) then - tempv = 0.0 - do k=1,km - tempv = tempv + va(:,:,k)*ke(:,:,k)*delp(:,:,k) - enddo - tempv = tempv / grav - end if - -! Fluxes: UQV & VQV -! ----------------- - call MAPL_GetPointer(export,temp2d,'UQV',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + ua(:,:,k)*QV(:,:,k)*delp(:,:,k) - enddo - temp2d = temp2d / grav - end if - - call MAPL_GetPointer(export,temp2d,'VQV',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + va(:,:,k)*QV(:,:,k)*delp(:,:,k) - enddo - temp2d = temp2d / grav - end if - -! Fluxes: UQL & VQL -! ----------------- - call MAPL_GetPointer(export,temp2d,'UQL',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(n)).eq.'QLCN' .or. & - trim(names(n)).eq.'QLLS' ) then - do k=1,km - if( state%vars%tracer(n)%is_r4 ) then - temp2d = temp2d + ua(:,:,k)*state%vars%tracer(n)%content_r4(:,:,k)*delp(:,:,k) - else - temp2d = temp2d + ua(:,:,k)*state%vars%tracer(n)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2d = temp2d / grav - end if - - call MAPL_GetPointer(export,temp2d,'VQL',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(n)).eq.'QLCN' .or. & - trim(names(n)).eq.'QLLS' ) then - do k=1,km - if( state%vars%tracer(n)%is_r4 ) then - temp2d = temp2d + va(:,:,k)*state%vars%tracer(n)%content_r4(:,:,k)*delp(:,:,k) - else - temp2d = temp2d + va(:,:,k)*state%vars%tracer(n)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2d = temp2d / grav - end if - -! Fluxes: UQI & VQI -! ----------------- - call MAPL_GetPointer(export,temp2d,'UQI',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(n)).eq.'QICN' .or. & - trim(names(n)).eq.'QILS' ) then - do k=1,km - if( state%vars%tracer(n)%is_r4 ) then - temp2d = temp2d + ua(:,:,k)*state%vars%tracer(n)%content_r4(:,:,k)*delp(:,:,k) - else - temp2d = temp2d + ua(:,:,k)*state%vars%tracer(n)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2d = temp2d / grav - end if - - call MAPL_GetPointer(export,temp2d,'VQI',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(n)).eq.'QICN' .or. & - trim(names(n)).eq.'QILS' ) then - do k=1,km - if( state%vars%tracer(n)%is_r4 ) then - temp2d = temp2d + va(:,:,k)*state%vars%tracer(n)%content_r4(:,:,k)*delp(:,:,k) - else - temp2d = temp2d + va(:,:,k)*state%vars%tracer(n)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2d = temp2d / grav - end if - -! Height related diagnostics -! -------------------------- - zle(:,:,km+1) = phisxy(:,:) - do k=km,1,-1 - zle(:,:,k) = zle(:,:,k+1) + cp*tempxy(:,:,k)*( pkxy(:,:,k+1)-pkxy(:,:,k) ) - enddo - zle = zle/grav - - call MAPL_GetPointer(export,temp3d,'ZLE',rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = zle - - call MAPL_GetPointer(export,temp2d,'DZ', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = 0.5*( zle(:,:,km)-zle(:,:,km+1) ) - - call MAPL_GetPointer(export,temp3d,'ZL' ,rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = 0.5*( zle(:,:,:km)+zle(:,:,2:) ) - - call MAPL_GetPointer(export,temp3d,'S' ,rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = temp3d + grav*(0.5*( zle(:,:,:km)+zle(:,:,2:) )) - -! Energy Budget Calculations -! -------------------------- - convke = 0.0 - convthv = 0.0 - convcpt = 0.0 - convphi = 0.0 - kegen = 0.0 - do k=1,km - kegen = kegen + omaxyz(:,:,k)*grav*( zle(:,:,k+1)-zle(:,:,k) ) - convke = convke + ke(:,:,k)*delp(:,:,k) - convphi = convphi + phi(:,:,k)*delp(:,:,k) - convthv = convthv + thvxyz(:,:,k) - convcpt = convcpt + cptxyz(:,:,k) - enddo - kegen = kegen /grav - convthv = convthv/grav * (MAPL_P00**MAPL_KAPPA) - convcpt = convcpt/grav - convke = (convke /grav-kenrg0)/dt - convphi = (convphi/grav- phi00)/dt - convcpt - - call MAPL_GetPointer(export,temp2d,'KEHOT',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kehot - - call MAPL_GetPointer(export,temp2d,'KEDP',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kedp - - call MAPL_GetPointer(export,temp2d,'KEADV',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = keadv - - call MAPL_GetPointer(export,temp2d,'KEPG',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kepg - - call MAPL_GetPointer(export,temp2d,'KEGEN', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kegen - - call MAPL_GetPointer(export,temp2d,'CONVKE',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = convke - - call MAPL_GetPointer(export,temp2d,'CONVTHV', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = convthv - - call MAPL_GetPointer(export,temp2d,'CONVCPT', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = convcpt - - call MAPL_GetPointer(export,temp2d,'CONVPHI',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = convphi - - call MAPL_GetPointer(export,temp2d,'DKERESIN',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = keadv + kedp + kehot - convke - - call MAPL_GetPointer(export,temp2d,'DKERESPG',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kepg - ( convphi + kegen - tedyn ) - - call MAPL_GetPointer(export,temp2d,'QFIXER',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = pedyn - convcpt + kegen - -! Fluxes: UPHI & VPHI -! ------------------- - call MAPL_GetPointer(export,tempu,'UPHI',rc=status); VERIFY_(STATUS) - call MAPL_GetPointer(export,tempv,'VPHI',rc=status); VERIFY_(STATUS) - - if( associated(tempu).or.associated(tempv) ) zl = 0.5*( zle(:,:,:km)+zle(:,:,2:) ) - - if(associated(tempu)) then - tempu = 0.0 - do k=1,km - tempu = tempu + ua(:,:,k)*zl(:,:,k)*delp(:,:,k) - enddo - end if - - if(associated(tempv)) then - tempv = 0.0 - do k=1,km - tempv = tempv + va(:,:,k)*zl(:,:,k)*delp(:,:,k) - enddo - end if - - -! Compute Omega -! ------------- - call FILLOUT3 (export,'OMEGA',omaxyz,rc=status) - VERIFY_(STATUS) - - call MAPL_GetPointer(export,temp2d,'OMEGA500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,omaxyz,log(pl),log(50000.),log(vars%pe(:,:,km+1)),status) - VERIFY_(STATUS) - end if - -! De-Allocate Arrays -! ------------------ - - DEALLOCATE( tempr8 ) - DEALLOCATE( dummy ) - DEALLOCATE( dqvdtanaint1 ) - DEALLOCATE( dqvdtanaint2 ) - DEALLOCATE( dqldtanaint1 ) - DEALLOCATE( dqldtanaint2 ) - DEALLOCATE( dqidtanaint1 ) - DEALLOCATE( dqidtanaint2 ) - DEALLOCATE( doxdtanaint1 ) - DEALLOCATE( doxdtanaint2 ) - DEALLOCATE( dthdtanaint1 ) - DEALLOCATE( dthdtanaint2 ) - DEALLOCATE( dthdtremap ) - DEALLOCATE( dthdtconsv ) - - DEALLOCATE( TROPP1 ) - DEALLOCATE( TROPP2 ) - DEALLOCATE( TROPP3 ) - DEALLOCATE( TROPT ) - DEALLOCATE( TROPQ ) - - DEALLOCATE( KEPG ) - DEALLOCATE( KEADV ) - DEALLOCATE( KEDP ) - DEALLOCATE( KEHOT ) - DEALLOCATE( KENRG ) - DEALLOCATE( PENRG ) - DEALLOCATE( TENRG ) - DEALLOCATE( KENRG0 ) - DEALLOCATE( PENRG0 ) - DEALLOCATE( TENRG0 ) - - DEALLOCATE( KEGEN ) - DEALLOCATE( KEDYN ) - DEALLOCATE( PEDYN ) - DEALLOCATE( TEDYN ) - DEALLOCATE( KECDCOR) - DEALLOCATE( PECDCOR) - DEALLOCATE( TECDCOR) - DEALLOCATE( KEREMAP) - DEALLOCATE( PEREMAP) - DEALLOCATE( TEREMAP) - - DEALLOCATE( CONVKE ) - DEALLOCATE( CONVCPT) - DEALLOCATE( CONVPHI) - DEALLOCATE( CONVTHV) - - DEALLOCATE( KENRGA ) - DEALLOCATE( PENRGA ) - DEALLOCATE( TENRGA ) - DEALLOCATE( KENRGB ) - DEALLOCATE( PENRGB ) - DEALLOCATE( TENRGB ) - - DEALLOCATE( ke ) - DEALLOCATE( cpt ) - DEALLOCATE( phi ) - DEALLOCATE( gze ) - DEALLOCATE( qsum1 ) - DEALLOCATE( qsum2 ) - - DEALLOCATE( ZL ) - DEALLOCATE( ZLE ) - DEALLOCATE( PKXY ) - DEALLOCATE( pelnxz ) - DEALLOCATE( omaxyz ) - DEALLOCATE( cptxyz ) - DEALLOCATE( thvxyz ) - DEALLOCATE( epvxyz ) - DEALLOCATE( cxxyz ) - DEALLOCATE( cyxyz ) - DEALLOCATE( ptfxxyz ) - DEALLOCATE( ptfyxyz ) - DEALLOCATE( mfxxyz_ur ) - DEALLOCATE( mfyxyz_ur ) - DEALLOCATE( mfxxyz ) - DEALLOCATE( mfyxyz ) - DEALLOCATE( mfzxyz ) - DEALLOCATE( mfxxyz_a ) - DEALLOCATE( mfyxyz_a ) - DEALLOCATE( tempxy ) - DEALLOCATE( pl ) - DEALLOCATE( va ) - DEALLOCATE( ua ) - DEALLOCATE( qv ) - DEALLOCATE( ql ) - DEALLOCATE( qi ) - DEALLOCATE( qdnew ) - DEALLOCATE( qdold ) - DEALLOCATE( qvold ) - DEALLOCATE( qlold ) - DEALLOCATE( qiold ) - DEALLOCATE( ox ) - DEALLOCATE( delp ) - DEALLOCATE( dmdt ) - DEALLOCATE( dudt ) - DEALLOCATE( dvdt ) - DEALLOCATE( dtdt ) - DEALLOCATE( dqdt ) - DEALLOCATE( dthdt ) - DEALLOCATE( ddpdt ) - DEALLOCATE( phisxy ) - DEALLOCATE( names ) - DEALLOCATE( phi00 ) - - do i=1,size(STATE%VARS%tracer)-NXQ - if ( .not. STATE%VARS%TRACER(I)%IS_R4 ) then - DEALLOCATE(STATE%VARS%tracer(i)%content, STAT=STATUS) ! TEMPORARY, till pointers are passed - end if - enddo - - DEALLOCATE( STATE%VARS%tracer, STAT=STATUS ) ! Comment out to output tracer to checkpoint file - - call MAPL_TimerOff(MAPL,"RUN1") - call MAPL_TimerOff(MAPL,"TOTAL") - - RETURN_(ESMF_SUCCESS) - -end subroutine RUN1 - -!----------------------------------------------------------------------- - - subroutine PULL_Q(STATE, IMPORT, QQQ, NXQ, RC) - - type (T_FVDYCORE_STATE) :: STATE - type (ESMF_State) :: IMPORT - type (T_TRACERS) :: QQQ ! Specific Humidity - integer, intent(IN) :: NXQ - integer, optional, intent(OUT) :: RC - - integer :: STATUS - character(len=ESMF_MAXSTR) :: IAm="Pull_Q" - character(len=ESMF_MAXSTR) :: FIELDNAME - type (ESMF_FieldBundle) :: BUNDLE - type (ESMF_Field) :: field - type (ESMF_Array) :: array - type (ESMF_TypeKind_Flag) :: kind - real(r4), pointer :: ptr_r4(:,:,:), humidity(:,:,:) - real(r8), pointer :: ptr(:,:,:) - integer :: I,K,N,NQ - logical :: EMPTY - integer :: i1,in,j1,jn,im,jm,km - real(r8) :: sumout - - i1 = state%grid%ifirstxy - in = state%grid%ilastxy - j1 = state%grid%jfirstxy - jn = state%grid%jlastxy - im = state%grid%im - jm = state%grid%jm - km = state%grid%km - - call ESMF_StateGet(IMPORT, 'TRADV' , BUNDLE, RC=STATUS) - VERIFY_(STATUS) - -! Count the friendlies -!--------------------- - - call ESMF_FieldBundleGet(BUNDLE, fieldCount=NQ, RC=STATUS) - VERIFY_(STATUS) - - NQ = NQ + NXQ - STATE%GRID%NQ = NQ ! GRID%NQ is now the "official" NQ - -! -! Tracer pointer array -! - ALLOCATE(STATE%VARS%tracer(nq), STAT=STATUS) - VERIFY_(STATUS) - - DO n = 1, NQ-NXQ - call ESMF_FieldBundleGet(bundle, fieldIndex=n, field=field, rc=status) - VERIFY_(STATUS) - call ESMF_FieldGet(field, name=fieldname, rc=status) - VERIFY_(STATUS) - call ESMF_FieldGet(field, Array=array, rc=status) - VERIFY_(STATUS) - - call ESMF_ArrayGet(array,typekind=kind,rc=status) - VERIFY_(STATUS) - - STATE%VARS%TRACER(N)%IS_R4 = (kind == ESMF_TYPEKIND_R4) ! Is real*4? - - if ( STATE%VARS%TRACER(N)%IS_R4 ) then - call ESMF_ArrayGet(array, localDE=0, farrayptr=ptr_r4, rc=status) - VERIFY_(STATUS) - state%vars%tracer(n)%content_r4 => MAPL_RemapBounds(PTR_R4, i1,in,j1,jn, & - 1, STATE%GRID%KM) - if (fieldname == "Q") then - qqq%is_r4 = .true. - qqq%content_r4 => state%vars%tracer(n)%content_r4 - end if - -! Constrain Poles -! ---------------- - if ( j1 == 1 ) then - do k=1,km - call par_xsum_r4 ( state%grid, state%vars%tracer(n)%content_r4(i1:in,1,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content_r4(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jm ) then - do k=1,km - call par_xsum_r4 ( state%grid, state%vars%tracer(n)%content_r4(i1:in,jm,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content_r4(i,jm,k) = sumout - enddo - enddo - endif - - else ! Tracer is R8 - - call ESMF_ArrayGet(array, localDE=0, farrayptr=ptr, rc=status) - VERIFY_(STATUS) - - state%vars%tracer(n)%content => PTR - if (fieldname == "Q") then - qqq%is_r4 = .false. - qqq%content => state%vars%tracer(n)%content - end if - -! Constrain Poles -! ---------------- - if ( j1 == 1 ) then - do k=1,km - call par_xsum ( state%grid, state%vars%tracer(n)%content(i1:in,1,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jm ) then - do k=1,km - call par_xsum ( state%grid, state%vars%tracer(n)%content(i1:in,jm,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content(i,jm,k) = sumout - enddo - enddo - endif - endif - END DO - - end subroutine PULL_Q - -!----------------------------------------------------------------------- - - subroutine PUSH_Q (STATE) - - type (T_FVDYCORE_STATE) :: STATE - - - integer :: STATUS - integer :: I,K,N - integer :: i1,in,j1,jn,im,jm,km - real(r8) :: sumout - - i1 = state%grid%ifirstxy - in = state%grid%ilastxy - j1 = state%grid%jfirstxy - jn = state%grid%jlastxy - im = state%grid%im - jm = state%grid%jm - km = state%grid%km - -! Count the friendlies -!--------------------- - - DO N = 1, state%grid%NQ - -! Constrain Poles -! --------------- - if ( state%vars%tracer(n)%is_r4 ) then - if ( j1 == 1 ) then - do k=1,km - call par_xsum_r4 ( state%grid, state%vars%tracer(n)%content_r4(i1:in,1,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content_r4(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jm ) then - do k=1,km - call par_xsum_r4 ( state%grid, state%vars%tracer(n)%content_r4(i1:in,jm,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content_r4(i,jm,k) = sumout - enddo - enddo - endif - - else ! Content is R8 - - if ( j1 == 1 ) then - do k=1,km - call par_xsum ( state%grid, state%vars%tracer(n)%content(i1:in,1,k), 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jm ) then - do k=1,km - call par_xsum ( state%grid, state%vars%tracer(n)%content(i1:in,jm,k), 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content(i,jm,k) = sumout - enddo - enddo - endif - - endif - END DO - - end subroutine PUSH_Q -!----------------------------------------------------------------------- - - subroutine FILLOUT3(export, name, V, RC) - type (ESMF_State), intent(inout) :: export - character(len=*), intent(IN ) :: name - real(r8), intent(IN ) :: V(:,:,:) - integer, optional, intent( out) :: rc - - real(r4), pointer :: CPL(:,:,:) - integer :: status - character(len=ESMF_MAXSTR) :: IAm="Fillout3" - - call MAPL_GetPointer(export, cpl, name, RC=STATUS) - VERIFY_(STATUS) - if(associated(cpl)) cpl=v - - end subroutine FILLOUT3 - -!----------------------------------------------------------------------- - - subroutine FILLOUT2(export, name, V, rc) - type (ESMF_State), intent(inout) :: export - character(len=*), intent(IN ) :: name - real(r8), intent(IN ) :: V(:,:) - integer, optional, intent( out) :: rc - - real(kind=4), pointer :: CPL(:,:) - integer :: status - character(len=ESMF_MAXSTR) :: IAm="Fillout2" - - call MAPL_GetPointer(export, cpl, name, RC=STATUS) - VERIFY_(STATUS) - if(associated(cpl)) cpl=v - - return - end subroutine FILLOUT2 - -!----------------------------------------------------------------------- - - subroutine Energetics (state,ud,vd,thv,ple,delp,pk,phiS,keint,peint,teint,grid,ke,cpt,gze) - use g3_dynamics_state_module - implicit none - type ( dynamics_grid_type ) grid - - type (T_FVDYCORE_STATE) :: STATE - real(8), optional, intent(out) :: ke(:,:,:) - real(8), optional, intent(out) :: cpt(:,:,:) - real(8), optional, intent(out) :: gze(:,:,:) - real(8) ud(:,:,:) - real(8) vd(:,:,:) - real(8) thv(:,:,:) - real(8) ple(:,:,:) - real(8) delp(:,:,:) - real(8) pk(:,:,:) - real(8) keint(:,:) - real(8) peint(:,:) - real(8) teint(:,:) - real(8) phiS(:,:) - - real(8) kinetic, potential, sump - integer i,ifirst,ilast - integer j,jfirst,jlast - integer im,jm,km,k - - real(8), allocatable :: ud2(:,:,:) - real(8), allocatable :: vd2(:,:,:) - real(8), allocatable :: ua2(:,:,:) - real(8), allocatable :: va2(:,:,:) - real(8), allocatable :: pke(:,:,:) - real(8), allocatable :: phiT(:,:) - - ifirst = lbound( ud,1 ) - ilast = ubound( ud,1 ) - jfirst = lbound( ud,2 ) - jlast = ubound( ud,2 ) - km = ubound( ud,3 ) - im = state%grid%im - jm = state%grid%jm - - allocate( ua2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( va2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( ud2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( vd2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( pke ( ifirst:ilast, jfirst:jlast , 1:km+1 ) ) - allocate( phiT ( ifirst:ilast, jfirst:jlast ) ) - -! Compute Model Edge Heights -! -------------------------- - pke = ple**kappa - phiT = phiS - if( present(gze) ) gze(:,:,km+1) = phiS - do k=km,1,-1 - phiT = phiT + cp*thv(:,:,k)*( pke(:,:,k+1)-pke(:,:,k) ) - if( present(gze) ) gze(:,:,k) = phiT - enddo - -! Compute C-Grid Kinetic Energy (using FV D-Grid Variable Names) -! -------------------------------------------------------------- - ud2 = ud*ud - vd2 = vd*vd - call ctoa_winds ( ud2,vd2,ua2,va2, & - grid%dlam,grid%dphi,grid%im,grid%jm,km,grid%lattice ) - - if( state%grid%jfirstxy.eq.1 ) then - ua2(:,1,:) = ud2(:,2,:) - va2(:,1,:) = vd2(:,2,:) - endif - if( state%grid%jlastxy.eq.jm ) then - ua2(:,jlast,:) = ud2(:,jlast-1,:) - va2(:,jlast,:) = vd2(:,jlast-1,:) - endif - -! Compute Energetics: Cp*Tv + K + PHI -! ------------------------------------ - keint = 0.0 - peint = 0.0 - do k=1,km - do j=jfirst,jlast - do i=ifirst,ilast - kinetic = 0.5_r8*( ua2(i,j,k) + va2(i,j,k) ) - potential = cp*thv(i,j,k)*pk(i,j,k) - keint(i,j) = keint(i,j) + kinetic *delp(i,j,k) - peint(i,j) = peint(i,j) + potential*delp(i,j,k) - if( present(ke) ) ke(i,j,k) = kinetic - if( present(cpt) ) cpt(i,j,k) = potential - enddo - enddo - enddo - keint(:,:) = keint(:,:)/grav - peint(:,:) = peint(:,:)/grav - teint(:,:) = (phiS(:,:)*ple(:,:,km+1)-phiT(:,:)*ple(:,:,1))/grav - - if( state%grid%jfirstxy.eq.1 ) then - call par_xsum ( state%grid, keint(ifirst:ilast,1), 1, sump ) ! Unify Pole Estimate -! call par_xsum ( state%grid, keint(ifirst:ilast,2), 1, sump ) ! Average Surrounding Points to Pole Location - sump = sump/im - do i=ifirst,ilast - keint(i,1) = sump - enddo - endif - if( state%grid%jlastxy.eq.jm ) then - call par_xsum ( state%grid, keint(ifirst:ilast,jlast ), 1, sump ) ! Unify Pole Estimate -! call par_xsum ( state%grid, keint(ifirst:ilast,jlast-1), 1, sump ) ! Average Surrounding Points to Pole Location - sump = sump/im - do i=ifirst,ilast - keint(i,jlast) = sump - enddo - endif - - deallocate ( ua2 ) - deallocate ( va2 ) - deallocate ( ud2 ) - deallocate ( vd2 ) - deallocate ( pke ) - deallocate ( phiT ) - - return - end subroutine Energetics - -!----------------------------------------------------------------------- - - subroutine Run2(gc, import, export, clock, rc) - use mod_comm, only: commglobal, mp_swapirr - - use g3_dynamics_state_module - type ( dynamics_grid_type ) g3_grid - save g3_grid - - include 'mpif.h' - integer imglobal, jmglobal, nx, ny - character*2 cnx,cny - logical first - data first /.true./ - - type(ESMF_GridComp), intent(inout) :: gc - type (ESMF_State), intent(inout) :: import - type (ESMF_State), intent(inout) :: export - type (ESMF_Clock), intent(in) :: clock - integer, intent(out), optional :: rc - -! !Local Variables: - - integer :: status - character(len=ESMF_MAXSTR) :: IAm - - type (MAPL_MetaComp), pointer :: MAPL - - type (DYN_wrap) :: wrap - type (T_FVDYCORE_STATE), pointer :: STATE - type (T_FVDYCORE_GRID), pointer :: GRID - type (T_FVDYCORE_VARS), pointer :: VARS - type (T_TRACERS) :: qqq ! Specific Humidity - - real(r8), allocatable :: penrg (:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrg (:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrg (:,:) ! PHIS*(Psurf-Ptop) - real(r8), allocatable :: penrg0(:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrg0(:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrg0(:,:) ! PHIS*(Psurf-Ptop) - - real(r8), pointer :: phisxy(:,:) - real(r4), pointer :: phis(:,:) - real(r8), allocatable :: slp(:,:) - real(r8), allocatable :: H1000(:,:) - real(r8), allocatable :: H850 (:,:) - real(r8), allocatable :: H500 (:,:) - real(r8), allocatable :: pke(:,:,:) - real(r8), allocatable :: pl(:,:,:) - real(r8), allocatable :: ua(:,:,:) - real(r8), allocatable :: va(:,:,:) - real(r8), allocatable :: va_yz(:,:,:) - real(r8), allocatable :: vd_yz(:,:,:) - real(r8), allocatable :: qv(:,:,:) - real(r8), allocatable :: dp(:,:,:) - real(r8), allocatable :: thv(:,:,:) - real(r8), allocatable :: zle(:,:,:) - real(r8), allocatable :: tempxy(:,:,:) - - real(r8), allocatable :: logpl(:,:,:) - real(r8), allocatable :: logpe(:,:,:) - real(r8), allocatable :: logps(:,:) - - real(r8) :: dt - real(r8) :: delp ! delta pressure thickness - real(r8) :: kinetic ! local kinetic energy - real(r8) :: potential ! local potential energy - - - real(r4), pointer :: QOLD(:,:,:) - real(r4), pointer :: temp3d(:,:,:) - real(r4), pointer :: temp2d(:,: ) - real(r4), pointer :: ztemp1(:,: ) - real(r4), pointer :: ztemp2(:,: ) - real(r4), pointer :: ztemp3(:,: ) - - real(kind=4), allocatable :: dthdtphyint1(:,:) - real(kind=4), allocatable :: dthdtphyint2(:,:) - - integer ifirstxy, ilastxy, ifirst, ilast - integer jfirstxy, jlastxy, jfirst, jlast - integer kfirst, klast - integer im,jm,km, nxq, im1, ng_s, ng_c, ng_d - integer i,j,k - - character(len=ESMF_MAXSTR) :: COMP_NAME - - Iam = "Run2" - call ESMF_GridCompGet( GC, name=COMP_NAME, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // trim(Iam) - -! Retrieve the pointer to the generic state -! ----------------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"RUN2") - -! Retrieve the pointer to the internal state -! ------------------------------------------ - - call ESMF_UserCompGetInternalState(gc, 'FVstate', wrap, status) - VERIFY_(STATUS) - state => wrap%dyn_state - - vars => state%vars ! direct handle to control variables - grid => state%grid ! direct handle to grid - dt = state%dt ! dynamics time step (large) - - ifirstxy = grid%ifirstxy - ilastxy = grid%ilastxy - jfirstxy = grid%jfirstxy - jlastxy = grid%jlastxy - jfirst = GRID%jfirst - jlast = GRID%jlast - kfirst = GRID%kfirst - klast = GRID%klast - ng_s = GRID%ng_s - ng_c = GRID%ng_c - ng_d = GRID%ng_d - - imglobal = grid%im - jmglobal = grid%jm - km = grid%km - nxq = 0 - -! ********************************************************************** -! **** Create G3 Grid **** -! ********************************************************************** - - if( first ) then - call MAPL_GetResource( MAPL, NX, 'NX:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, NY, 'NY:', default=0, RC=STATUS ) - VERIFY_(STATUS) - - call create_dynamics_lattice ( g3_grid%lattice,nx,ny ) - call init_dynamics_lattice ( g3_grid%lattice,mpi_comm_world,imglobal,jmglobal,km ) - call create_dynamics_grid ( g3_grid,imglobal,jmglobal,km ) - call init_dynamics_grid ( g3_grid,imglobal,jmglobal,km,0,state%grid%ak,state%grid%bk ) - - first = .false. - endif - - im = g3_grid%im - jm = g3_grid%jm - - ALLOCATE( dthdtphyint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dthdtphyint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( kenrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kenrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( phisxy(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( logps(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( ua(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( va(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qv(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( pl(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( logpl(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dp(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( thv(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( tempxy(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - - ALLOCATE( pke(ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - ALLOCATE( logpe(ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - ALLOCATE( zle(ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - - call MAPL_GetPointer ( IMPORT, PHIS, 'PHIS', RC=STATUS ) - VERIFY_(STATUS) - - phisxy = real(phis,kind=r8) - -! Compute Pressure Thickness -! -------------------------- - - dp = ( vars%pe(:,:,2:) - vars%pe (:,:,:km) ) - -! Create A-Grid Winds -! ------------------- - call ctoa_winds ( vars%u,vars%v,ua,va, & - g3_grid%dlam,g3_grid%dphi,im,jm,km,g3_grid%lattice ) - -! Specific humidity before and after physics updates -! -------------------------------------------------- - - call MAPL_GetPointer(export,QOLD,'Q', rc=status) - - call PULL_Q ( STATE, IMPORT, qqq, NXQ, rc ) - - if ( qqq%is_r4 ) then - qv = qqq%content_r4 - else - qv = qqq%content - endif - -! Compute Energetics Before Diabatic Forcing -! ------------------------------------------ - - thv = vars%pt*(1.0+eps*QOLD) - - call Energetics (state,vars%u,vars%v,thv,vars%pe,dp,vars%pkz,phisxy,kenrg0,penrg0,tenrg0,g3_grid) - -! DTHVDTPHYINT -! ------------ - call MAPL_GetPointer ( export, temp2D, 'DTHVDTPHYINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dthdtphyint1 = 0.0 - do k=1,km - dthdtphyint1 = dthdtphyint1 + thv(:,:,k)*dp(:,:,k) - enddo - endif - -! Add Diabatic Forcing to State Variables -! --------------------------------------- - - call ADD_INCS ( STATE,IMPORT,DT,g3_grid ) - -! Update Mid-Layer Pressure and Pressure Thickness -! ------------------------------------------------ - - dp = ( vars%pe(:,:,2:) - vars%pe (:,:,:km) ) - pl = ( vars%pe(:,:,2:) + vars%pe (:,:,:km) )*0.5 - - logpl = log(pl) - logpe = log(vars%pe) - logps = log(vars%pe(:,:,km+1)) - -! Create A-Grid Winds -! ------------------- - call ctoa_winds ( vars%u,vars%v,ua,va, & - g3_grid%dlam,g3_grid%dphi,im,jm,km,g3_grid%lattice ) - -! Compute Energetics After Diabatic Forcing -! ----------------------------------------- - - thv = vars%pt*(1.0+eps*qv) - - call Energetics (state,vars%u,vars%v,thv,vars%pe,dp,vars%pkz,phisxy,kenrg,penrg,tenrg,g3_grid) - - call MAPL_GetPointer(export,temp2d,'KE', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kenrg - - kenrg = (kenrg-kenrg0)/DT - penrg = (penrg-penrg0)/DT - tenrg = (tenrg-tenrg0)/DT - - call FILLOUT2 (export, 'KEPHY', kenrg, rc=status); VERIFY_(STATUS) - call FILLOUT2 (export, 'PEPHY', penrg, rc=status); VERIFY_(STATUS) - call FILLOUT2 (export, 'TEPHY', tenrg, rc=status); VERIFY_(STATUS) - -! DTHVDTPHYINT -! ------------ - call MAPL_GetPointer ( export, temp2D, 'DTHVDTPHYINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dthdtphyint2 = 0.0 - do k=1,km - dthdtphyint2 = dthdtphyint2 + thv(:,:,k)*dp(:,:,k) - enddo - temp2D = (dthdtphyint2-dthdtphyint1) * MAPL_P00**MAPL_KAPPA / (MAPL_GRAV*DT) - endif - -! Fill V_DGRID with Reasonable Pole Values Averaged from V_AGRID (For use by utilities outside Model) -! --------------------------------------------------------------------------------------------------- - - allocate( va_yz(imglobal,jfirst:jlast,kfirst:klast) ) - allocate( vd_yz(imglobal,jfirst:jlast,kfirst:klast) ) - - if( grid%twod_decomp /= 0 ) then - call mp_swapirr( commglobal, grid%ijk_xy_to_yz%SendDesc, & - grid%ijk_xy_to_yz%RecvDesc, va, va_yz, & - a2in=vars%v, a2out=vd_yz ) - -! Question: why should this be grid%ijk_xy_to_yz and not grid%vxy_to_v ?? Ghosting?? -!!! call mp_sendirr( vars%v, grid%ijk_xy_to_yz%SendDesc, grid%ijk_xy_to_yz%RecvDesc, vd_yz ) -!!! call mp_recvirr( vd_yz, grid%ijk_xy_to_yz%RecvDesc ) - else - do k=1,km - do j=jfirst,jlast - do i=1,imglobal - va_yz(i,j,k) = va(i,j,k) - vd_yz(i,j,k) = vars%v(i,j,k) - enddo - enddo - enddo - endif - - if ( jfirst == 1 ) then - do k=kfirst,klast - im1 = imglobal - do i=1,imglobal - vd_yz(i,jfirst,k) = 0.5_r8*( va_yz(i,jfirst,k)+va_yz(im1,jfirst,k) ) - im1 = i - enddo - enddo - endif - if ( jlast == jmglobal ) then - do k=kfirst,klast - im1 = imglobal - do i=1,imglobal - vd_yz(i,jlast,k) = 0.5_r8*( va_yz(i,jlast,k)+va_yz(im1,jlast,k) ) - im1 = i - enddo - enddo - endif - - if( grid%twod_decomp /= 0 ) then - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, vd_yz, vars%v ) - else - do k=1,km - do j=jfirst,jlast - do i=1,imglobal - vars%v(i,j,k) = vd_yz(i,j,k) - enddo - enddo - enddo - endif - - deallocate( va_yz ) - deallocate( vd_yz ) - -! Fill Diagnostics -! ---------------- - - tempxy = vars%pt * vars%pkz ! Dry Temperature - - call FILLOUT3 (export, 'DELP' , dp , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'U' , ua , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'V' , va , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'T' , tempxy , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'Q' , qv , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PL' , pl , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PLE' , vars%pe , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PLK' , vars%pkz, rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'THV' , thv , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'U_DGRID', vars%u , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'V_DGRID', vars%v , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PT' , vars%pt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PE' , vars%pe , rc=status); VERIFY_(STATUS) - - call MAPL_GetPointer(export,temp3d,'TH',rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = vars%pt*(p00**kappa) - -! Compute Edge Heights -! -------------------- - - pke = vars%pe**kappa - zle(:,:,km+1) = phisxy(:,:) - do k=km,1,-1 - zle(:,:,k) = zle(:,:,k+1) + cp*thv(:,:,k)*( pke(:,:,k+1)-pke(:,:,k) ) - enddo - zle(:,:,:) = zle(:,:,:)/grav - - call FILLOUT3 (export, 'ZLE', zle, rc=status); VERIFY_(STATUS) - -! Compute Mid-Layer Heights -! ------------------------- - - call MAPL_GetPointer(export,temp3d,'ZL', rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = 0.5*( zle(:,:,2:) + zle(:,:,:km) ) - -! Fill Single Level Variables -! --------------------------- - - call MAPL_GetPointer(export,temp2d,'U250', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,ua,logpl,log(25000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'U500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,ua,logpl,log(50000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'U850', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,ua,logpl,log(85000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'V250', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,va,logpl,log(25000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'V500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,va,logpl,log(50000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'V850', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,va,logpl,log(85000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'T250', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,tempxy,logpl,log(25000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'T500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,tempxy,logpl,log(50000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'T850', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,tempxy,logpl,log(85000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'Q250', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,qv,logpl,log(25000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'Q500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,qv,logpl,log(50000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'Q850', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,qv,logpl,log(85000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'H250', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,zle,logpe,log(25000.),rc=status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'H500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,zle,logpe,log(50000.),rc=status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'H850', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,zle,logpe,log(85000.),rc=status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'H1000', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,zle,logpe,log(100000.),rc=status) - VERIFY_(STATUS) - end if - -! Compute Mid-Level Heights Above Surface -! --------------------------------------- - do k=1,km - zle(:,:,k) = 0.5*( zle(:,:,k)+zle(:,:,k+1) ) - zle(:,:,km+1) - enddo - zle(:,:,km+1) = 0.0 - - call MAPL_GetPointer(export,temp2d,'U50M', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,ua,zle(:,:,1:km),50.,zle(:,:,km+1),status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'V50M', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,va,zle(:,:,1:km),50.,zle(:,:,km+1),status) - VERIFY_(STATUS) - end if - -! Compute Surface Pressure -! ------------------------ - - call MAPL_GetPointer(export,temp2d,'PS', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d=vars%pe(:,:,km+1) - -! Compute Vertically Averaged T,U -! ------------------------------- - call MAPL_GetPointer(export,temp2d,'TAVE', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + tempxy(:,:,k)*dp(:,:,k) - enddo - temp2d = temp2d / (vars%pe(:,:,km+1)-vars%pe(:,:,1)) - endif - - call MAPL_GetPointer(export,temp2d,'UAVE', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + ua(:,:,k)*dp(:,:,k) - enddo - temp2d = temp2d / (vars%pe(:,:,km+1)-vars%pe(:,:,1)) - endif - -! Convert T to Tv -! --------------- - - tempxy = tempxy*(1.0+eps*qv) - - call MAPL_GetPointer(export,temp3d,'TV', rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d=tempxy - -! Compute Sea-Level Pressure -! -------------------------- - - call MAPL_GetPointer(export,temp2d,'SLP' ,rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(export,Ztemp1,'H1000',rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(export,Ztemp2,'H850' ,rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(export,Ztemp3,'H500' ,rc=status) - VERIFY_(STATUS) - - if(associated(temp2d) .or. associated(ztemp1) & - .or. associated(ztemp2) & - .or. associated(ztemp3) ) then - ALLOCATE( slp(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE(H1000(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE(H850 (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE(H500 (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - call get_slp ( km,vars%pe (i,j, km+1),phisxy(i,j), slp(i,j), & - vars%pe (i,j,1:km+1), & - vars%pkz(i,j,1:km ), & - tempxy(i,j,1:km ), & - H1000(i,j), H850(i,j), H500(i,j) ) - enddo - enddo - if(associated(temp2d)) temp2d = slp - if(associated(ztemp1)) where( ztemp1.eq.MAPL_UNDEF ) ztemp1 = H1000 - if(associated(ztemp2)) where( ztemp2.eq.MAPL_UNDEF ) ztemp2 = H850 - if(associated(ztemp3)) where( ztemp3.eq.MAPL_UNDEF ) ztemp3 = H500 - DEALLOCATE(slp,H1000,H850,H500) - end if - -! Deallocate Memory -! ----------------- - - DEALLOCATE( kenrg ) - DEALLOCATE( penrg ) - DEALLOCATE( tenrg ) - DEALLOCATE( kenrg0 ) - DEALLOCATE( penrg0 ) - DEALLOCATE( tenrg0 ) - - DEALLOCATE( phisxy ) - - DEALLOCATE( ua ) - DEALLOCATE( va ) - DEALLOCATE( qv ) - DEALLOCATE( pl ) - DEALLOCATE( dp ) - DEALLOCATE( tempxy ) - - DEALLOCATE( thv ) - DEALLOCATE( pke ) - DEALLOCATE( logpl ) - DEALLOCATE( logpe ) - DEALLOCATE( logps ) - DEALLOCATE( zle ) - DEALLOCATE( dthdtphyint1 ) - DEALLOCATE( dthdtphyint2 ) - - DEALLOCATE( STATE%VARS%tracer, STAT=STATUS ) ! Allocated by call to PULL_Q - - call MAPL_TimerOff(MAPL,"RUN2") - call MAPL_TimerOff(MAPL,"TOTAL") - - RETURN_(ESMF_SUCCESS) -end subroutine Run2 - -!----------------------------------------------------------------------- - subroutine ADD_INCS ( STATE,IMPORT,DT,g3_grid,RC ) - - use g3_dynamics_state_module - - include 'mpif.h' - integer imglobal, jmglobal -! -! !INPUT PARAMETERS: - - type(T_FVDYCORE_STATE), intent(INOUT) :: STATE - type(ESMF_State), intent(INOUT) :: IMPORT - real(r8), intent(IN ) :: DT - type ( dynamics_grid_type ) :: g3_grid - integer, optional, intent(OUT ) :: RC - -! -! !DESCRIPTION: This routine adds the tendencies to the state, -! weighted appropriately by the time step. Temperature -! tendencies are pressure weighted (ie., DELP*DT/Dt). -! All tendencies are on the A-grid, and have an XY decomposition. -! - - integer :: status - - integer :: I1, IN, J1, JN, K, im, jm, km - integer :: KL, KU, NX, NY - real(r8) :: SUMOUT - real(r8), allocatable :: dum(:,:,:), pkzold(:,:,:) - real(r8), allocatable :: pke(:,:,:), dpinv(:,:,:) - real(r8), allocatable :: tend_u(:,:,:), tend_v(:,:,:) - real(kind=4), pointer :: tend(:,:,:) - - character(len=ESMF_MAXSTR) :: IAm="ADD_INCS" - character*2 cnx,cny - - i1 = state%grid%ifirstxy - in = state%grid%ilastxy - j1 = state%grid%jfirstxy - jn = state%grid%jlastxy - - imglobal = state%grid%im - jmglobal = state%grid%jm - km = state%grid%km - - im = g3_grid%im - jm = g3_grid%jm - -! ********************************************************************** -! **** Update Winds **** -! ********************************************************************** - - ALLOCATE( tend_u(i1:in,j1:jn,km) ) - ALLOCATE( tend_v(i1:in,j1:jn,km) ) - - call ESMFL_StateGetPointerToData ( IMPORT,TEND,'DUDT',RC=STATUS ) - VERIFY_(STATUS) - tend_u = tend - - call ESMFL_StateGetPointerToData ( IMPORT,TEND,'DVDT',RC=STATUS ) - VERIFY_(STATUS) - tend_v = tend - - _ASSERT( im == in-i1+1 ,'needs informative message') - _ASSERT( jm == jn-j1+1 ,'needs informative message') - -! Put the wind tendencies on the C-grid -! ------------------------------------- - call atoc ( tend_u,tend_u,g3_grid%dlam,g3_grid%dphi,im,jm,km,1,g3_grid%lattice ) - call atoc ( tend_v,tend_v,g3_grid%dlam,g3_grid%dphi,im,jm,km,2,g3_grid%lattice ) - -! Add the wind tendencies to the control variables -! ------------------------------------------------ - STATE%VARS%U = STATE%VARS%U + DT*TEND_U - STATE%VARS%V = STATE%VARS%V + DT*TEND_V - -! Set D-GRID U at the South Pole to UNDEF -! --------------------------------------- -! if ( j1 == 1 ) STATE%VARS%U(:,1,:) = MAPL_UNDEF - -! Set D-GRID V at Both Poles to UNDEF -! ----------------------------------- -! if ( j1 == 1 ) STATE%VARS%V(:, 1,:) = MAPL_UNDEF -! if ( jn == jm ) STATE%VARS%V(:,jm,:) = MAPL_UNDEF - - DEALLOCATE( tend_u ) - DEALLOCATE( tend_v ) - -! ********************************************************************** -! **** Compute Pressure Thickness Using Old Pressures **** -! ********************************************************************** - - ALLOCATE( dpinv(i1:in,j1:jn,km) ) - do k=1,km - dpinv(:,:,k) = 1.0/( state%vars%pe(:,:,k+1)-state%vars%pe(:,:,k) ) - enddo - -! ********************************************************************** -! **** Update Edge Pressures **** -! ********************************************************************** - - call ESMFL_StateGetPointerToData ( IMPORT,TEND,'DPEDT',RC=STATUS ) - VERIFY_(STATUS) - - KL = lbound( tend,3 ) - KU = ubound( tend,3 ) - - allocate( dum(i1:in,j1:jn,KL:KU) ) - - DUM = DT*TEND - -! Constrain Poles -! --------------- - if ( j1 == 1 ) then - do k=KL,KU - call par_xsum ( state%grid, DUM(i1:in,1,k), 1, sumout ) - sumout = sumout/imglobal - do i=i1,in - DUM(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jmglobal ) then - do k=KL,KU - call par_xsum ( state%grid, DUM(i1:in,jn,k), 1, sumout ) - sumout = sumout/imglobal - do i=i1,in - DUM(i,jn,k) = sumout - enddo - enddo - endif - - STATE%VARS%PE = STATE%VARS%PE + DUM - DEALLOCATE (DUM) - -! ********************************************************************** -! **** Update P*Kappa at Mid-Levels **** -! ********************************************************************** - - ALLOCATE( pke (i1:in,j1:jn,km+1) ) - ALLOCATE( pkzold(i1:in,j1:jn,1:km) ) - - pke = STATE%VARS%PE**kappa - pkzold = STATE%VARS%PKZ - - do k=1,km - STATE%VARS%PKZ(:,:,k) = ( pke(:,:,k+1)-pke(:,:,k) ) & - / ( kappa*( log(STATE%VARS%PE(:,:,k+1))-log(STATE%VARS%PE(:,:,k)) ) ) - enddo - -! ********************************************************************* -! **** Update Dry Potential Temperature **** -! **** -------------------------------- **** -! **** Note: State Variable is Potential Temperature T/P**kappa **** -! **** while IMPORT Coupling is (Delta_P)*DTDt **** -! ********************************************************************* - - call ESMFL_StateGetPointerToData ( IMPORT,TEND,'DTDT',RC=STATUS ) - VERIFY_(STATUS) - - KL = lbound( tend,3 ) - KU = ubound( tend,3 ) - - allocate( dum(i1:in,j1:jn,KL:KU) ) - - DUM = DT*TEND*DPINV/STATE%VARS%PKZ & - + STATE%VARS%PT*( PKZOLD/STATE%VARS%PKZ - 1.0 ) - -! Constrain Poles -! --------------- - if ( j1 == 1 ) then - do k=KL,KU - call par_xsum ( state%grid, DUM(i1:in,1,k), 1, sumout ) - sumout = sumout/imglobal - do i=i1,in - DUM(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jmglobal ) then - do k=KL,KU - call par_xsum ( state%grid, DUM(i1:in,jn,k), 1, sumout ) - sumout = sumout/imglobal - do i=i1,in - DUM(i,jn,k) = sumout - enddo - enddo - endif - - STATE%VARS%PT = STATE%VARS%PT + DUM -! STATE%VARS%PT = (STATE%VARS%PT*(1+EPS*QOLD) + DUM)/(1+EPS*QNEW) - DEALLOCATE (DUM) - - DEALLOCATE( PKE ) - DEALLOCATE( PKZOLD ) - DEALLOCATE( DPINV ) - - return - - end subroutine ADD_INCS - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!BOP - -! !IROUTINE: Finalize - -! !DESCRIPTION: Writes restarts and cleans-up through MAPL\_GenericFinalize and -! deallocates memory from the Private Internal state. -! -! !INTERFACE: - -subroutine Finalize(gc, import, export, clock, rc) - use dynamics_vars, only : dynamics_clean - -! !ARGUMENTS: - - type (ESMF_GridComp), intent(inout) :: gc - type (ESMF_State), intent(inout) :: import - type (ESMF_State), intent(inout) :: export - type (ESMF_Clock), intent(inout) :: clock - integer, optional, intent( out) :: rc - -!EOP - -! Local variables - type (DYN_wrap) :: wrap - type (T_FVDYCORE_STATE), pointer :: STATE - character (len=ESMF_MAXSTR) :: restart_file - - character(len=ESMF_MAXSTR) :: IAm - character(len=ESMF_MAXSTR) :: COMP_NAME - integer :: status - - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_Config) :: cf - - -! BEGIN - - Iam = "Finalize" - call ESMF_GridCompGet( GC, name=COMP_NAME, config=cf, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // Iam - -! Retrieve the pointer to the state -! --------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"FINALIZE") - -! Retrieve the pointer to the state -!---------------------------------- - - call ESMF_UserCompGetInternalState(gc, 'FVstate', wrap, status) - VERIFY_(STATUS) - - state => wrap%dyn_state - - call dynamics_clean (STATE%GRID) - -! Call Generic Finalize -!---------------------- - - call MAPL_TimerOff(MAPL,"FINALIZE") - call MAPL_TimerOff(MAPL,"TOTAL") - - call MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC=STATUS) - VERIFY_(STATUS) - - RETURN_(ESMF_SUCCESS) - - end subroutine FINALIZE - - -!======================================================================= - - subroutine get_slp ( km,ps,phis,slp,pe,pk,tv,H1000,H850,H500) - implicit none - integer km - real(r8) pk(km) ! layer-mean P**kappa - real(r8) tv(km) ! layer-mean virtual Temperature - real(r8) pe(km+1) ! press at layer edges (Pa) - real(r8) ps ! surface pressure (Pa) - real(r8) phis ! surface geopotential - real(r8) slp ! sea-level pressure (hPa) - real(r8) H1000 ! 1000mb height - real(r8) H850 ! 850mb height - real(r8) H500 ! 500mb height - real(r8) tstar ! extrapolated temperature (K) - real(r8) p_bot - real(r8) tref ! Reference virtual temperature (K) - real(r8) pref ! Reference pressure level (Pa) - real(r8) pkref ! Reference pressure level (Pa) ** kappa - real(r8) dp1, dp2 - - real(r8), parameter :: gamma = 6.5e-3 - real(r8), parameter :: p_offset = 15000. - real(r8), parameter :: gg = gamma/MAPL_GRAV - - real(r8), parameter :: factor = MAPL_grav / ( MAPL_Rgas * gamma ) - real(r8), parameter :: yfactor = MAPL_Rgas * gg - - integer k_bot, k, k1, k2 - - p_bot = ps - p_offset - k_bot = -1 - - do k = km, 2, -1 - if ( pe(k+1) .lt. p_bot ) then - k_bot = k - exit - endif - enddo - - k1 = k_bot - 1 - k2 = k_bot - dp1 = pe(k_bot) - pe(k_bot-1) - dp2 = pe(k_bot+1) - pe(k_bot) - pkref = ( pk(k1)*dp1 + pk(k2)*dp2 ) / (dp1+dp2) - tref = ( tv(k1)*dp1 + tv(k2)*dp2 ) / (dp1+dp2) - pref = 0.5 * ( pe(k_bot+1) + pe(k_bot-1) ) - tstar = tref*( ps/pref )**yfactor - - slp = ps*( 1.0+gg*phis/tstar )**factor - H1000 = (phis/MAPL_grav) - (tstar/gamma)*((100000.0/ps)**(1./factor)-1.0) - H850 = (phis/MAPL_grav) - (tstar/gamma)*(( 85000.0/ps)**(1./factor)-1.0) - H500 = (phis/MAPL_grav) - (tstar/gamma)*(( 50000.0/ps)**(1./factor)-1.0) - return - end subroutine get_slp - -!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - subroutine VertInterp(v2,v3,pl,pp,ps,rc) - - real(r4), intent(OUT) :: v2(:,:) - real(r8), intent(IN ) :: v3(:,:,:) - real(r8), target, intent(IN ) :: pl(:,:,:) - real, intent(IN ) :: pp - real(r8), optional, intent(IN ) :: ps(:,:) - integer, optional, intent(OUT) :: rc - - real, dimension(size(v2,1),size(v2,2)) :: al,PT,PB - integer km, K, msn - logical flip - real ppx - real(r8), pointer :: plx(:,:,:) - - integer :: status - character*(10) :: Iam='VertInterp' - - km = size(pl,3) - - flip = pl(1,1,km) < pl(1,1,km-1) - - if(flip) then - allocate(plx(size(pl,1),size(pl,2),size(pl,3)),stat=status) - VERIFY_(STATUS) - plx = -pl - ppx = -pp - msn = -1 - else - plx => pl - ppx = pp - msn = 1 - end if - - v2 = MAPL_UNDEF - - pb = plx(:,:,km) - do k=km-1,1,-1 - pt = plx(:,:,k) - if(all(pb=ppx) - al = (pb-ppx)/(pb-pt) - v2 = v3(:,:,k)*al + v3(:,:,k+1)*(1.0-al) - end where - pb = pt - end do - -! Extend Lowest Level Value to the Surface -! ---------------------------------------- - if( present(ps) ) then - where( (plx(:,:,km)=ppx) ) - v2 = v3(:,:,km) - end where - end if - - if(flip) then - deallocate(plx,stat=status) - VERIFY_(STATUS) - end if - - RETURN_(ESMF_SUCCESS) - end subroutine VertInterp - -!BOP - -! !IROUTINE: Coldstart - -! !DESCRIPTION: -! Routine to coldstart from an isothermal state of rest. -! The temperature can be specified in the config, otherwise -! it is 300K. The surface pressure is assumed to be 1000 hPa. -! -! !INTERFACE: - -subroutine Coldstart(gc, import, export, clock, rc) - -! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc - type(ESMF_State), intent(inout) :: import - type(ESMF_State), intent(inout) :: export - type (ESMF_Clock), intent(in) :: clock - integer, intent(out), optional :: rc - -!EOP - - character(len=ESMF_MAXSTR) :: IAm - character(len=ESMF_MAXSTR) :: COMP_NAME - integer :: status - - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_State) :: INTERNAL - - real(r8), pointer :: AK(:), BK(:) - real(r8), pointer :: Ptr3(:,:,:) - real(r8), pointer :: PKL (:,:,:) - real, pointer :: LATS (:,:) - real :: T0 - integer :: L - type(ESMF_Config) :: CF - -! Begin - - Iam = "Coldstart" - call ESMF_GridCompGet( GC, name=COMP_NAME, CONFIG=CF, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // trim(Iam) - -! Retrieve the pointer to the state -! --------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - -!BOR -! !RESOURCE_ITEM: K :: Value of isothermal temperature on coldstart - call MAPL_GetResource ( MAPL, T0, 'T0:', default=300., RC=STATUS ) - VERIFY_(STATUS) -!EOR - - call MAPL_Get ( MAPL, & - INTERNAL_ESMF_STATE=INTERNAL, & - lats = LATS, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_GetPointer(Internal,Ptr3,'U' ,rc=STATUS) - VERIFY_(STATUS) - Ptr3 = 0.0 - - Ptr3(1,:,ubound(Ptr3,3)) = .001*abs(lats(1,:)) - - call MAPL_GetPointer(Internal,Ptr3,'V' ,rc=STATUS) - VERIFY_(STATUS) - Ptr3 = 0.0 - - call MAPL_GetPointer(Internal,Ptr3,'PE',rc=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(Internal,PKL ,'PKZ',rc=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer(Internal,ak ,'AK' ,rc=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(Internal,bk ,'BK' ,rc=STATUS) - VERIFY_(STATUS) - - call ESMF_ConfigFindLabel( cf, 'AK:', rc = status ) - VERIFY_(STATUS) - do L = 0, SIZE(AK)-1 - call ESMF_ConfigNextLine ( CF, rc=STATUS ) - call ESMF_ConfigGetAttribute( cf, AK(L), rc = status ) - VERIFY_(STATUS) - enddo - - call ESMF_ConfigFindLabel( cf, 'BK:', rc = status ) - VERIFY_(STATUS) - do L = 0, SIZE(bk)-1 - call ESMF_ConfigNextLine ( CF, rc=STATUS ) - call ESMF_ConfigGetAttribute( cf, BK(L), rc = status ) - VERIFY_(STATUS) - enddo - - _ASSERT(ANY(AK /= 0.0) .or. ANY(BK /= 0.0),'needs informative message') - do L=lbound(Ptr3,3),ubound(Ptr3,3) - Ptr3(:,:,L) = AK(L) + BK(L)*MAPL_P00 - enddo - - PKL = 0.5*(Ptr3(:,:,lbound(Ptr3,3) :ubound(Ptr3,3)-1) + & - Ptr3(:,:,lbound(Ptr3,3)+1:ubound(Ptr3,3) ) ) - PKL = PKL**MAPL_KAPPA - - call MAPL_GetPointer(Internal,Ptr3,'PT',rc=STATUS) - VERIFY_(STATUS) - - Ptr3 = T0/PKL - - call MAPL_TimerOff(MAPL,"TOTAL") - - - RETURN_(ESMF_SUCCESS) - end subroutine COLDSTART - -end module ARIESg3_GridCompMod diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/CMakeLists.txt deleted file mode 100644 index ae1642534..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/CMakeLists.txt +++ /dev/null @@ -1,37 +0,0 @@ -esma_set_this () - -set (srcs - g3_dynamics_lattice_module.F g3_dynamics_state_module.F - g3_mpi_util.F - g3_mymalloc.F g3_fft.F - g3_wrapper.F g3_dycore.F g3_gcmutil.F g3_grids.F - shr_kind_mod.F90 dynamics_vars.F90 - pft_module.F90 par_xsum.F90 fft99.F90 remap.F90 gmap.F90 - ${this}Mod.F90 - ) - -set (files_that_need_extended_source - g3_dycore.F g3_dynamics_lattice_module.F - g3_dynamics_state_module.F g3_gcmutil.F - g3_grids.F - g3_mpi_util.F - g3_mymalloc.F g3_fft.F - g3_wrapper.F - ) -if (EXTENDED_SOURCE) - foreach (file ${files_that_need_extended_source}) - set_source_files_properties(${file} APPEND_STRING PROPERTIES COMPILE_FLAGS ${EXTENDED_SOURCE}) - set_source_files_properties(${file} APPEND_STRING PROPERTIES COMPILE_FLAGS ${EXTENDED_SOURCE}) - endforeach () -endif () - -add_definitions(-DSPMD -DMAPL_MODE -DTWOD_YZ -DrFV=r4) - - -esma_add_library (${this} SRCS ${srcs} - DEPENDENCIES GEOS_Shared GMAO_pilgrim MAPL GMAO_transf) -target_include_directories (${this} PUBLIC ${INC_ESMF} ${INC_NETCDF}) -if (CRAY_POINTER) - set_target_properties (${this} PROPERTIES COMPILE_FLAGS ${CRAY_POINTER}) -endif() - diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/FVdycore_arch.mk b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/FVdycore_arch.mk deleted file mode 100644 index 251238767..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/FVdycore_arch.mk +++ /dev/null @@ -1,39 +0,0 @@ -# -# System dependent FLAGS for FVdycore. -# - - -ifeq ($(ARCH),Linux) - -# Intel Fortran Compiler (ifort or mpiifort) -# ------------------------------------------ - ifeq ($(subst mpi,,$(FC)), ifort) - - ifeq ($(IFORT_MAJOR), 8) - USER_FFLAGS = -mp -stack_temps -fno-alias -ftz -auto - else - ifeq ($(IFORT_MAJOR), 9) - USER_FFLAGS = -fp-model precise - else - ifeq ($(IFORT_MAJOR),10) - USER_FFLAGS = -fno-inline-functions -assume protect_parens,minus0 -prec-div -prec-sqrt -no-ftz - endif - endif - endif - - endif - - ifeq ($(ESMA_FC), gfortran) - - USER_FFLAGS = -DNO_R16 -fcray-pointer - - endif - - ifeq ($(ESMA_FC), ftn) - USER_FFLAGS = -DNO_R16 - endif - - ifeq ($(ESMA_FC), pgfortran) - USER_FFLAGS = -DNO_R16 - endif -endif diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/dynamics_vars.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/dynamics_vars.F90 deleted file mode 100644 index 960a8d855..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/dynamics_vars.F90 +++ /dev/null @@ -1,2289 +0,0 @@ -module dynamics_vars -!BOP -! -! !MODULE: dynamics_vars --- GEOS5/CAM fvcore internal variables -! -! !USES: - use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 -#if defined( MAPL_MODE ) - use ESMF - use MAPL - use G3_MPI_Util_Mod -#endif - -! - use decompmodule, only: decomptype - use ghostmodule, only: ghosttype -#if defined(SPMD) - use parutilitiesmodule, only: parpatterntype, REAL4, INT4 -#endif - -! !PUBLIC MEMBER FUNCTIONS: - public dynamics_init, dynamics_clean - public a2d3d, d2a3d, b2d3d, d2b3d, c2a3d - -! !PUBLIC DATA MEMBERS: - - public T_TRACERS, T_FVDYCORE_VARS, T_FVDYCORE_GRID, T_FVDYCORE_STATE - - type T_TRACERS - logical :: is_r4 - real(r8), dimension(:,:,: ), pointer :: content - real(r4), dimension(:,:,: ), pointer :: content_r4 - end type T_TRACERS - -! T_FVDYCORE_VARS contains the prognostic variables for FVdycore - type T_FVDYCORE_VARS - real(r8), dimension(:,:,: ), pointer :: U ! U winds (D-grid) - real(r8), dimension(:,:,: ), pointer :: V ! V winds (D-grid) - real(r8), dimension(:,:,: ), pointer :: PT ! scaled virtual pot. temp. - real(r8), dimension(:,:,: ), pointer :: PE ! Pressure at layer edges - real(r8), dimension(:,:,: ), pointer :: PKZ ! P^kappa mean - type(T_TRACERS), dimension(:), pointer :: tracer ! Tracers - end type T_FVDYCORE_VARS - -! T_FVDYCORE_GRID contains information about the horizontal and vertical -! discretization, unlike in ARIES where these data are split into HORZ_GRID -! and VERT_GRID. The reason for this: currently all of this information is -! initialized in one call to FVCAM dynamics_init. - - type T_FVDYCORE_GRID -! -#if defined( MAPL_MODE ) - type (MAPL_MetaComp), pointer :: FVgenstate - type (ESMF_Grid) :: GRIDXY ! The 'horizontal' grid (2D decomp only) - type (ESMF_Grid) :: GRIDYZ ! The latitude-level grid - type (dynamics_lattice_type) :: lattice -#endif - -! -! PILGRIM communication information (was in spmd_dyn) -! - integer :: twod_decomp = 0 ! 1 for multi-2D decompositions, 0 otherwise - - integer :: myid_y = 0 ! subdomain index (0-based) in latitude (y) - integer :: myid_z = 0 ! subdomain index (0 based) in level (z) - integer :: npr_y = 1 ! number of subdomains in y - integer :: npr_z = 1 ! number of subdomains in z - - integer :: myidxy_x = 0 ! subdomain index (0-based) in longitude (x) (second. decomp.) - integer :: myidxy_y = 0 ! subdomain index (0 based) in latitude (y) (second. decomp.) - integer :: nprxy_x = 1 ! number of subdomains in x (second. decomp.) - integer :: nprxy_y = 1 ! number of subdomains in y (second. decomp.) - integer :: iam = 0 ! - - integer :: mod_method = 0 ! 1 for mpi derived types with transposes, 0 for contiguous buffers - integer :: mod_geopk = 0 ! 1 for mpi derived types with transposes, 0 for contiguous buffers - integer :: mod_gatscat = 0 ! 1 for mpi derived types with transposes, 0 for contiguous buffers - - type(decomptype) :: strip2d, strip2dx, strip3dxyz, strip3dxzy, & - strip3dxyzp, strip3zaty, strip3dxzyp, & - strip3yatz, strip3yatzp, strip3zatypt, & - strip3kxyz, strip3kxzy, strip3kxyzp, strip3kxzyp, & - strip3dyz, checker3kxy - - integer :: comm_y ! communicator in latitude - integer :: comm_z ! communicator in vertical - integer :: commxy_x ! communicator in longitude (xy second. decomp.) - integer :: commxy_y ! communicator in latitude (xy second. decomp.) - logical :: geopk16byte ! method for geopotential calculation with 2D decomp. - -#if defined(SPMD) - type (ghosttype) :: ghostu_yz, ghostv_yz, ghostpt_yz, & - ghostpe_yz, ghostpkc_yz - type (parpatterntype) :: u_to_uxy, uxy_to_u, v_to_vxy, vxy_to_v, & - ikj_yz_to_xy, ikj_xy_to_yz, ijk_yz_to_xy, & - ijk_xy_to_yz, pe_to_pexy, pexy_to_pe, & - pt_to_ptxy, ptxy_to_pt, pkxy_to_pkc, & - r4_xy_to_yz, r4_yz_to_xy, q3_to_qxy3, qxy3_to_q3, & - xy2d_to_yz2d, yz2d_to_xy2d, scatter_3d, gather_3d, & - g_2dxy_r8, g_2dxy_r4, g_2dxy_i4, & - s_2dxy_r8, s_2dxy_r4, s_2dxy_i4, & - g_3dxyz_r8, g_3dxyz_r4, g_3dxyzp_r8, g_3dxyzp_r4, & - s_3dxyz_r8, s_3dxyz_r4, s_3dxyzp_r8, s_3dxyzp_r4 -#endif - -! -! END PILGRIM communication information -! - - integer :: JFIRST ! Start latitude (exclusive) - integer :: JLAST ! End latitude (exclusive) - -! - integer :: NG_C ! Ccore ghosting - integer :: NG_D ! Dcore ghosting - integer :: NG_S ! Staggered grid ghosting for - ! certain arrays, max(ng_c+1,ng_d) -! -! For 2D decomposition (currently not used) -! - integer :: IFIRSTXY ! Start longitude (exclusive) - integer :: ILASTXY ! End longitude (exclusive) - integer :: JFIRSTXY ! Start latitude (exclusive) - integer :: JLASTXY ! End latitude (exclusive) -! - integer :: IM ! Full longitude dim - integer :: JM ! Full latitude dim (including poles) -! - real(r8) :: DL - real(r8) :: DP - real(r8) :: ACAP - real(r8) :: RCAP -! - real(r8), dimension(:), pointer :: COSP ! Cosine of lat angle -- volume mean - real(r8), dimension(:), pointer :: SINP ! Sine of lat angle -- volume mean - real(r8), dimension(:), pointer :: COSE ! Cosine at finite volume edge - real(r8), dimension(:), pointer :: SINE ! Sine at finite volume edge - real(r8), dimension(:), pointer :: ACOSP ! Reciprocal of cosine of lat angle -! - real(r8), dimension(:), pointer :: ACOSU ! Reciprocal of cosine of lat angle (staggered) -! - real(r8), dimension(:), pointer :: COSLON ! Cosine of longitudes - volume center - real(r8), dimension(:), pointer :: SINLON ! Sine of longitudes - volume center - real(r8), dimension(:), pointer :: COSL5 ! Cosine of longitudes - volume center - real(r8), dimension(:), pointer :: SINL5 ! Sine of longitudes - volume center - -! -! Variables which are used repeatedly in CD_CORE -! - - integer :: js2g0 - integer :: jn2g0 - integer :: jn1g1 - - real(r8), pointer :: trigs(:) - real(r8), pointer :: fc(:), f0(:) - real(r8), pointer :: dc(:,:), de(:,:), sc(:), se(:) - real(r8), pointer :: cdx(:,:), cdy(:,:) - real(r8), pointer :: dtdx(:), dtdxe(:), txe5(:), dtxe5(:) - real(r8), pointer :: dyce(:), dx(:) , rdx(:), cy(:) - real(r8), pointer :: dtdx2(:), dtdx4(:), dxdt(:), dxe(:) - real(r8), pointer :: cye(:), dycp(:), rdxe(:) - - real(r8) :: rdy, dtdy, dydt, dtdy5, tdy5 - real(r8) :: dt0 = 0 - - integer :: ifax(13) - - real(r8) :: zt_c - real(r8) :: zt_d - -! -! This part refers to the vertical grid -! - integer :: KM ! Numer of levels - integer :: KMAX ! KM+1 (?) -! -! For 2D decomposition (currently not used) -! - integer :: KFIRST ! Start level (exclusive) - integer :: KLAST ! End level (exclusive) - integer :: KLASTP ! klast+1, except km+1 when klastp=km+1 -! -! - integer :: KORD ! monotonicity order for mapping (te_map) - integer :: KS ! Number of true pressure levels (out of KM+1) - real(r8) :: PTOP ! pressure at top (ak(1)) - real(r8) :: PINT ! initial pressure (ak(km+1)) - real(r8), dimension(:), pointer :: AK ! Sigma mapping - real(r8), dimension(:), pointer :: BK ! Sigma mapping - -! -! Tracers -! - integer :: NQ ! Number of advected tracers - integer :: NTOTQ ! Total number of tracers (NQ <= NC) - end type T_FVDYCORE_GRID - -! Constants used by fvcore - type T_FVDYCORE_CONSTANTS - real(r8) :: pi - real(r8) :: omega ! angular velocity of earth's rotation - real(r8) :: cp ! heat capacity of air at constant pressure - real(r8) :: ae ! radius of the earth (m) - real(r8) :: rair ! Gas constant of the air - real(r8) :: cappa ! Cappa? - real(r8) :: zvir ! RWV/RAIR-1 - end type T_FVDYCORE_CONSTANTS - - integer, parameter :: NUM_FVDYCORE_ALARMS = 3 - integer, parameter :: NUM_TIMES = 8 - - type T_FVDYCORE_STATE -!!! private - type (T_FVDYCORE_VARS) :: VARS - type (T_FVDYCORE_GRID ) :: GRID - type (T_FVDYCORE_CONSTANTS) :: CONSTANTS -#if defined( MAPL_MODE ) - type (ESMF_Clock), pointer :: CLOCK - type (ESMF_Alarm) :: ALARMS(NUM_FVDYCORE_ALARMS) -#endif - integer(kind=8) :: RUN_TIMES(4,NUM_TIMES) - logical :: DOTIME, DODYN - real(r8) :: DT ! Large time step - real(r8) :: CHECK_DT ! Time step to check maxmin - integer :: ICD, JCD ! Algorithm orders (C Grid) - integer :: IORD, JORD ! Algorithm orders (D Grid) - integer :: KORD ! Vertical order - integer :: TE_METHOD ! method for total energy mapping (te_map) - logical :: CONSV ! dycore conserves tot. en. - integer :: NSPLIT - integer :: NUM_CALLS - end type T_FVDYCORE_STATE - -! -! !DESCRIPTION: -! -! This module provides variables which are specific to the Lin-Rood -! dynamical core. Most of them were previously SAVE variables in -! different routines and were set with an "if (first)" statement. -! -! \begin{tabular}{|l|l|} \hline \hline -! lr\_init & Initialize the Lin-Rood variables \\ \hline -! lr\_clean & Deallocate all internal data structures \\ \hline -! \hline -! \end{tabular} -! -! !REVISION HISTORY: -! 01.06.06 Sawyer Consolidated from various code snippets -! 01.07.12 Sawyer Removed CCM common blocks comtim.h and commap.h -! 03.06.25 Sawyer Cleaned up, used ParPatternCopy (Create) -! 03.07.23 Sawyer Removed dependencies on params.h, constituents -! 03.08.05 Sawyer Removed rayf_init and hswf_init, related vars -! 03.09.17 Sawyer Removed unneeded ghost definitions -! 03.10.22 Sawyer pmgrid removed (now spmd_dyn) -! 03.11.18 Sawyer Removed set_eta (ak, bk, now read from restart) -! 03.12.04 Sawyer Moved T_FVDYCORE_GRID here (removed some vars) -! 04.08.25 Sawyer Removed all module data members, now GRID only -! 04.10.06 Sawyer Added spmd_dyn vars here; ESMF transpose vars -! 05.04.12 Sawyer Added support for r4/r8 tracers -! 05.05.24 Sawyer CAM/GEOS5 merge (removed GEOS_mod dependencies) -! 05.06.10 Sawyer Scaled down version for CAM (no ESMF) -! 05.11.10 Sawyer Removed dyn_interface (now in dyn_comp) -! 06.03.01 Sawyer Removed m_ttrans, q_to_qxy, qxy_to_q, etc. -! 06.05.09 Sawyer Added CONSV to dyn_state (conserve energy) -! 06.08.27 Sawyer Removed unused ESMF code for RouteHandle -! -!EOP -!----------------------------------------------------------------------- - real(r8), parameter :: D0_0 = 0.0_r8 - real(r8), parameter :: D0_5 = 0.5_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D2_0 = 2.0_r8 - real(r8), parameter :: D4_0 = 4.0_r8 - real(r8), parameter :: D180_0 = 180.0_r8 - real(r8), parameter :: ratmax = 0.81_r8 - - -contains - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: dynamics_init --- initialize the lin-rood dynamical core -! -! !INTERFACE: - subroutine dynamics_init( dt_in, jord_in, im_in, jm_in, km_in, & - pi_in, ae_in, om_in, nq_in, ntotq_in, & - ks_in, ifirstxy_in, ilastxy_in, & - jfirstxy_in, jlastxy_in, & - jfirst_in, jlast_in, & - kfirst_in, klast_in, & - nprxy_x_in, nprxy_y_in, & - npryz_y_in, npryz_z_in, & - imxy_in, jmxy_in, jmyz_in, kmyz_in, & - ak_in, bk_in, unit, & - grid ) -! !USES: - implicit none - -! !INPUT PARAMETERS: - real(r8), intent(in) :: dt_in ! Initial time step - integer, intent(in) :: jord_in ! Horz. scheme # - integer, intent(in) :: im_in, jm_in, km_in ! Global dims - real(r8), intent(in) :: pi_in ! Pi - real(r8), intent(in) :: ae_in ! Earth radius - real(r8), intent(in) :: om_in ! Earth angular velocity - integer, intent(in) :: nq_in ! No. adv. tracers - integer, intent(in) :: ntotq_in ! No. total tracers - integer, intent(in) :: ks_in ! True # pressure levels - integer, intent(in) :: ifirstxy_in, ilastxy_in ! Interval - integer, intent(in) :: jfirstxy_in, jlastxy_in ! Interval - integer, intent(in) :: jfirst_in, jlast_in ! Interval - integer, intent(in) :: kfirst_in, klast_in ! Interval - integer, intent(in) :: nprxy_x_in ! XY decomp - Nr in X - integer, intent(in) :: nprxy_y_in ! XY decomp - Nr in Y - integer, intent(in) :: npryz_y_in ! YZ decomp - Nr in Y - integer, intent(in) :: npryz_z_in ! YZ decomp - Nr in Z - - integer, dimension(:), intent(in) :: imxy_in - integer, dimension(:), intent(in) :: jmxy_in - integer, dimension(:), intent(in) :: jmyz_in - integer, dimension(:), intent(in) :: kmyz_in - - real(r8), dimension(:), intent(in) :: ak_in - real(r8), dimension(:), intent(in) :: bk_in - - integer, intent(in) :: unit - -! !INPUT/OUTPUT PARAMETERS: - type(T_FVDYCORE_GRID), intent(inout) :: grid ! Resulting grid - include 'mpif.h' - -! !DESCRIPTION: -! -! Initialize Lin-Rood specific variables -! -! !REVISION HISTORY: -! -! 01.06.06 Sawyer Create -! 03.07.31 Sawyer Added the 'layout' arguments -! 03.08.05 Sawyer Removed hswf_init and rayf_init -! 04.08.25 Sawyer Added GRID, contains all information -! 04.10.04 Sawyer Added init_spmd here -! 06.03.01 Sawyer Removed argument m_ttrans_in -! 06.11.27 Sawyer Removed argument layout (no longer used) -! 06.11.29 Sawyer Constant PI now passed as argument -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -!!! real(r8) :: pi !WS 29.11.2006 -- uncomment this for zero diffs - integer :: rc - integer :: n1,n2 - -! Set the basic grid variables - - grid%im = im_in - grid%jm = jm_in - grid%km = km_in - grid%kmax = km_in + 1 - grid%nq = nq_in - grid%ntotq = ntotq_in - grid%ks = ks_in - grid%ifirstxy = ifirstxy_in - grid%ilastxy = ilastxy_in - grid%jfirstxy = jfirstxy_in - grid%jlastxy = jlastxy_in - grid%jfirst = jfirst_in - grid%jlast = jlast_in - grid%kfirst = kfirst_in - grid%klast = klast_in - if ( klast_in == km_in ) then - grid%klastp = km_in+1 - else - grid%klastp = klast_in - endif - -!WS 29.11.2006 -- uncomment this for zero diffs -!!! pi = D4_0 * atan(D1_0) -!!! call dynpkg_init( pi, ae_in, om_in, dt_in, im_in, & - call dynpkg_init( pi_in, ae_in, om_in, dt_in, im_in, & - jm_in, jord_in, grid ) - -! -! Level-dependent variables (was in vert_init, now removed) -! - ALLOCATE(GRID%AK(km_in+1)) - ALLOCATE(GRID%BK(km_in+1)) - - GRID%AK = AK_IN - GRID%BK = BK_IN - GRID%PTOP = GRID%AK(1) - GRID%PINT = GRID%AK(ks_in+1) - -#if defined( SPMD ) - call spmd_vars_init( nprxy_x_in, nprxy_y_in, & - npryz_y_in, npryz_z_in, & - imxy_in, jmxy_in, jmyz_in, kmyz_in, nq_in, & - grid ) -#endif - - call create_dynamics_lattice ( grid%lattice,mpi_comm_world,im_in,jm_in,km_in,nprxy_x_in,nprxy_y_in ) - - n1 = grid%lattice%im(grid%lattice%pei) - n2 = ilastxy_in-ifirstxy_in+1 - if( n1.ne.n2 ) call my_exit (101) - n1 = grid%lattice%jm(grid%lattice%pej) - n2 = jlastxy_in-jfirstxy_in+1 - if( n1.ne.n2 ) call my_exit (102) - - return - -CONTAINS - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: dynpkg_init --- Initialization for dynamics package -! -! !INTERFACE: -subroutine dynpkg_init( pi, ae, om, dt, im, jm, jord, grid ) - -! !USES: - use pft_module_, only : pftinit, pft2d, pft_cf - implicit none - -! !INPUT PARAMETERS: - real(r8) , intent(in) :: pi - real(r8) , intent(in) :: ae - real(r8) , intent(in) :: om - real(r8) , intent(in) :: dt - integer, intent(in) :: im - integer, intent(in) :: jm - integer, intent(in) :: jord - -! !INPUT/OUTPUT PARAMETERS: - type( T_FVDYCORE_GRID ), intent(inout) :: grid - - -! !DESCRIPTION: -! -! {\bf Purpose:} Initialization of the FV specific GRID vars -! -! !REVISION HISTORY: -! 00.01.10 Grant Creation using code from SJ Lin -! 01.03.26 Sawyer Added ProTeX documentation -! 01.06.06 Sawyer Modified for dynamics_vars -! 04.08.25 Sawyer Now updates GRID -! 05.06.30 Sawyer Added initializations from cd_core -! 06.09.15 Sawyer PI now passed as argument -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer :: i, j, imh, js2g0, jn2g0, jn1g1, js2gc, jn1gc - real(r8) :: zam5, zamda - real(r8) :: ph5 ! This is to ensure 64-bit for any choice of r8 - - real(r8), pointer :: coslon(:), sinlon(:), cosl5(:), sinl5(:) - real(r8), pointer :: cosp(:), sinp(:), cose(:), sine(:), acosp(:), acosu(:) - -! -! Local variables from cd_core -! - - integer :: icffta - real(r8) :: rcffta - - real(r8) :: rat, ycrit, dt5 - -! -! Start initialization -! - grid%dl = (pi+pi)/im - grid%dp = pi/(jm-1) - - allocate(grid%cosp(jm)) - allocate(grid%sinp(jm)) - allocate(grid%cose(jm)) - allocate(grid%sine(jm)) - allocate(grid%acosp(jm)) - allocate(grid%acosu(jm)) - - allocate(grid%coslon(im)) - allocate(grid%sinlon(im)) - allocate(grid%cosl5(im)) - allocate(grid%sinl5(im)) - - cosp => grid%cosp - sinp => grid%sinp - cose => grid%cose - sine => grid%sine - acosp => grid%acosp - acosu => grid%acosu - - coslon => grid%coslon - sinlon => grid%sinlon - cosl5 => grid%cosl5 - sinl5 => grid%sinl5 - - do j=2,jm - ph5 = -D0_5*pi + ((j-1)-D0_5)*(pi/(jm-1)) - sine(j) = sin(ph5) - enddo - - cosp( 1) = D0_0 - cosp(jm) = D0_0 - - do j=2,jm-1 - cosp(j) = (sine(j+1)-sine(j)) / grid%dp - enddo - -! Define cosine at edges.. - - do j=2,jm - cose(j) = D0_5 * (cosp(j-1) + cosp(j)) - enddo - cose(1) = cose(2) - - do j=2,jm-1 - acosu(j) = D2_0 / (cose(j) + cose(j+1)) - enddo - - sinp( 1) = -D1_0 - sinp(jm) = D1_0 - - do j=2,jm-1 - sinp(j) = D0_5 * (sine(j) + sine(j+1)) - enddo - - -! -! Pole cap area and inverse - grid%acap = im*(D1_0+sine(2)) / grid%dp - grid%rcap = D1_0 / grid%acap - - imh = im/2 - if(im .ne. 2*imh) then - write(6,*) 'im must be an even integer' - stop - endif - -! Define logitude at the center of the volume -! i=1, Zamda = -pi - - do i=1,imh - zam5 = ((i-1)-D0_5) * grid%dl - cosl5(i) = cos(zam5) - cosl5(i+imh) = -cosl5(i) - sinl5(i) = sin(zam5) - sinl5(i+imh) = -sinl5(i) - zamda = (i-1)*grid%dl - coslon(i) = cos(zamda) - coslon(i+imh) = -coslon(i) - sinlon(i) = sin(zamda) - sinlon(i+imh) = -sinlon(i) - enddo - - do j=2,jm-1 - acosp(j) = D1_0 / cosp(j) - enddo - acosp( 1) = grid%rcap * im - acosp(jm) = grid%rcap * im - -#if defined( SPMD ) -! -! Calculate the ghost region sizes for the SPMD version (tricky stuff) -! - grid%ng_c = 2 ! Avoid the case where ng_c = 1 - grid%ng_d = min( abs(jord), 3) ! SJL: number of max ghost latitudes - grid%ng_d = max( grid%ng_d, 2) - grid%ng_s = max( grid%ng_c+1, grid%ng_d ) -#else - grid%ng_c = 0 - grid%ng_d = 0 ! No ghosting necessary for pure SMP runs - grid%ng_s = 0 -#endif - -! -! cd_core initializations -! - - allocate(grid%dtdx(jm)) ; grid%dtdx(:) = 1 ! To prevent divide by zero at poles - allocate(grid%dtdx2(jm)) - allocate(grid%dtdx4(jm)) - allocate(grid%dtdxe(jm)) - allocate(grid%dxdt(jm)) - allocate(grid%dxe(jm)) - allocate(grid%cye(jm)) - allocate(grid%dycp(jm)) - allocate(grid%rdxe(jm)) - allocate(grid%txe5(jm)) - allocate(grid%dtxe5(jm)) - allocate(grid%dyce(jm)) - allocate(grid%dx(jm)) - allocate(grid%rdx(jm)) - allocate(grid%cy(jm)) - - js2g0 = max(2,grid%jfirst) - jn2g0 = min(jm-1,grid%jlast) - jn1g1 = min(jm,grid%jlast+1) - js2gc = max(2,grid%jfirst-grid%ng_c) ! NG lats on S (starting at 2) - jn1gc = min(jm,grid%jlast+grid%ng_c) ! ng_c lats on N (ending at jm) - - grid%js2g0 = js2g0 - grid%jn2g0 = jn2g0 - grid%jn1g1 = jn1g1 - - allocate(grid%sc(js2g0:jn2g0)) - allocate(grid%se(js2g0:jn1g1)) - allocate(grid%dc(im,js2g0:jn2g0)) - allocate(grid%de(im,js2g0:jn1g1)) - - call pftinit(im) - -! Determine ycrit such that effective DX >= DY - rat = real(im,r8)/real(2*(jm-1),r8) - ycrit = acos( min(ratmax, rat) ) * (D180_0/pi) - - call pft_cf(im, jm, js2g0, jn2g0, jn1g1, & - grid%sc, grid%se, grid%dc, grid%de, & - grid%cosp, grid%cose, ycrit) - - allocate( grid%cdx(js2g0:jn1g1,grid%kfirst:grid%klast) ) - allocate( grid%cdy(js2g0:jn1g1,grid%kfirst:grid%klast) ) - -! 000304 bug fix: ng_s not ng_d - allocate( grid%f0(grid%jfirst-grid%ng_s-1:grid%jlast+grid%ng_d) ) - allocate( grid%fc(js2gc:jn1gc) ) - -! 000304 bug fix - do j=max(1,grid%jfirst-grid%ng_s-1),min(jm,grid%jlast+grid%ng_d) - grid%f0(j) = (om+om)*grid%sinp(j) - enddo - -! Compute coriolis parameter at cell corners. - do j=js2gc, jn1gc ! Not the issue with ng_c = ng_d - grid%fc(j) = D0_5*(grid%f0(j) + grid%f0(j-1)) - enddo - -!!! grid%dt0 = dt - grid%dt0 = D0_0 - dt5 = D0_5*dt - - grid%rdy = D1_0/(ae*grid%dp) - grid%dtdy = dt *grid%rdy - grid%dtdy5 = dt5*grid%rdy - grid%dydt = (ae*grid%dp) / dt - grid%tdy5 = D0_5/grid%dtdy - - return -!EOC -end subroutine dynpkg_init -!----------------------------------------------------------------------- - -#if defined(SPMD) -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: spmd_vars_init --- Initialization of SPMD-related variables -! -! !INTERFACE: -subroutine spmd_vars_init( nprxy_x_in, nprxy_y_in, & - npryz_y_in, npryz_z_in, & - imxy_in, jmxy_in, jmyz_in, kmyz_in, nq_in, & - grid ) - -! !USES: - use decompmodule, only: decompcreate, decompfree - use ghostmodule, only : ghostcreate - use parutilitiesmodule, only : gid, gsize, commglobal, & - parpatterncreate, parsplit - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: nprxy_x_in ! XY decomp - Nr in X - integer, intent(in) :: nprxy_y_in ! XY decomp - Nr in Y - integer, intent(in) :: npryz_y_in ! YZ decomp - Nr in Y - integer, intent(in) :: npryz_z_in ! YZ decomp - Nr in Z - - integer, dimension(:), intent(in) :: imxy_in - integer, dimension(:), intent(in) :: jmxy_in - integer, dimension(:), intent(in) :: jmyz_in - integer, dimension(:), intent(in) :: kmyz_in - integer, intent(in) :: nq_in - -! !INPUT/OUTPUT PARAMETERS: - type( T_FVDYCORE_GRID ), intent(inout) :: grid - -! !DESCRIPTION: -! -! {\bf Purpose:} Initialization of the SPMD related variables. -! This has to be done in this module since certain variables -! (in particular the ghost sizes {\tt ng\_d, ng\_s} are first -! defined here. -! -! !REVISION HISTORY: -! 02.11.08 Sawyer Creation -! 03.05.07 Sawyer Use ParPatternCopy for q_to_qxy, etc. -! 03.07.23 Sawyer Removed dependency on constituents module -! 03.09.10 Sawyer Reactivated u_to_uxy, etc, redefined pe2pexy -! 03.11.19 Sawyer Merged in CAM code with mod_method -! 04.08.25 Sawyer Added GRID as argument -! 04.09.30 Sawyer Initial ESMF routehandlers -! 04.10.04 Sawyer Added INIT_SPMD functionality -! 06.08.27 Sawyer Removed ESMF routehandles -- non-current -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -#if defined( MAPL_MODE ) - character(len=ESMF_MAXSTR), parameter :: IAm='spmd_vars_init' -#endif - -! !LOCAL VARIABLES: - type(decomptype) :: global2d, local2d - - integer :: im, jm, km ! Global dims - integer :: ifirstxy, ilastxy ! Interval - integer :: jfirstxy, jlastxy ! Interval - integer :: jfirst, jlast ! Interval - integer :: kfirst, klast ! Interval - integer :: ng_s, ng_c, ng_d ! Ghost widths - integer :: rc ! return code - integer :: rank_y, rank_z, rankxy_x, rankxy_y ! Currently not used - integer :: size_y, size_z, sizexy_x, sizexy_y ! Currently not used - - integer :: xdist(1), ydistk(1), zdist1(1), zdistxy(1) ! non-distributed dims - integer, allocatable :: xdist_global(:), ydist_global(:) - integer, allocatable :: zdist(:) ! number of levels per subdomain - integer :: ier ! error flag - -! -! Grab crucial variables from Grid -! - im = grid%im - jm = grid%jm - km = grid%km - - ifirstxy = grid%ifirstxy - ilastxy = grid%ilastxy - jfirstxy = grid%jfirstxy - jlastxy = grid%jlastxy - - jfirst = grid%jfirst - jlast = grid%jlast - kfirst = grid%kfirst - klast = grid%klast - - ng_s = grid%ng_s - ng_c = grid%ng_c - ng_d = grid%ng_d - - -! -! This section of code used to be in INIT_SPMD (FVdycore_GridCompMod) -! - grid%iam = gid - - grid%npr_y = npryz_y_in - grid%npr_z = npryz_z_in - grid%nprxy_x = nprxy_x_in - grid%nprxy_y = nprxy_y_in - - grid%myid_z = gid/grid%npr_y - grid%myid_y = gid - grid%myid_z*grid%npr_y - grid%myidxy_y = gid/grid%nprxy_x - grid%myidxy_x = gid - grid%myidxy_y*grid%nprxy_x - -! Split communicators - - call parsplit(commglobal, grid%myid_z, gid, grid%comm_y, rank_y, size_y) - call parsplit(commglobal, grid%myid_y, gid, grid%comm_z, rank_z, size_z) - call parsplit(commglobal, grid%myidxy_y, gid, grid%commxy_x, rankxy_x, sizexy_x) - call parsplit(commglobal, grid%myidxy_x, gid, grid%commxy_y, rankxy_y, sizexy_y) - -! -! WS: create decompositions for NCAR data structures -! - allocate (xdist_global(nprxy_x_in)) - allocate (ydist_global(nprxy_y_in)) - allocate (zdist (npryz_z_in)) - xdist(1) = im -! -! Create PILGRIM decompositions (see decompmodule) -! - xdist_global = 0 - ydist_global = 0 - xdist_global(1) = im - ydist_global(1) = jm - zdistxy(1) = km - call decompcreate( nprxy_x_in, nprxy_y_in, xdist_global, & - ydist_global, global2d ) - call decompcreate( nprxy_x_in, nprxy_y_in, imxy_in, jmxy_in, local2d ) - - call decompcreate( 1, npryz_y_in, xdist, jmyz_in, grid%strip2d ) - call decompcreate( 1, npryz_y_in, npryz_z_in, xdist, & - jmyz_in, kmyz_in, grid%strip3dxyz ) - call decompcreate( "xzy", 1, npryz_z_in, grid%npr_y, xdist, & - kmyz_in, jmyz_in, grid%strip3dxzy ) - -! For y communication within z subdomain (klast version) - zdist1(1) = kmyz_in(grid%myid_z+1) - call decompcreate( 1, npryz_y_in, 1, xdist, jmyz_in, zdist1, & - grid%strip3yatz ) - -! For z communication within y subdomain - - ydistk(1) = jmyz_in(grid%myid_y+1) - call decompcreate( 1, 1, npryz_z_in, xdist, ydistk, kmyz_in, & - grid%strip3zaty ) - -! Arrays dimensioned plev+1 - - zdist(:) = kmyz_in(:) - zdist(npryz_z_in) = kmyz_in(npryz_z_in) + 1 - call decompcreate( 1, npryz_y_in, npryz_z_in, xdist, jmyz_in, zdist,& - grid%strip3dxyzp ) - call decompcreate( "xzy", 1, npryz_z_in, npryz_y_in, & - xdist, zdist, jmyz_in, grid%strip3dxzyp ) - -! Arrays dimensioned plev+1, within y subdomain - - ydistk(1) = jmyz_in(grid%myid_y+1) - call decompcreate( "xzy", 1, npryz_z_in, 1, xdist, zdist, ydistk, & - grid%strip3zatypt ) - -! For y communication within z subdomain (klast+1 version) - zdist1(1) = kmyz_in(grid%myid_z+1)+1 - call decompcreate( 1, npryz_y_in, 1, xdist, jmyz_in, zdist1, & - grid%strip3yatzp ) - -! For the 2D XY-YZ data transfer, we need a short 3D array - zdist(:) = 1 ! One copy on each z PE set - call decompcreate( 1, npryz_y_in, npryz_z_in, & - xdist, jmyz_in, zdist, grid%strip3dyz ) - -! Secondary xy decomposition -! - if (grid%twod_decomp == 1) then - zdistxy(1) = npryz_z_in ! All npr_z copies on 1 PE - call decompcreate( nprxy_x_in, nprxy_y_in, 1, & - imxy_in, jmxy_in, zdistxy, grid%checker3kxy ) - zdistxy(1) = km - call decompcreate( nprxy_x_in, nprxy_y_in, 1, & - imxy_in, jmxy_in, zdistxy, grid%strip3kxyz ) - call decompcreate( "xzy", nprxy_x_in, 1, nprxy_y_in, & - imxy_in, zdistxy, jmxy_in, grid%strip3kxzy ) - - zdistxy(1) = zdistxy(1) + 1 - call decompcreate( nprxy_x_in, nprxy_y_in, 1, & - imxy_in, jmxy_in, zdistxy, grid%strip3kxyzp ) - call decompcreate( "xzy", nprxy_x_in, 1, nprxy_y_in, & - imxy_in, zdistxy, jmxy_in, grid%strip3kxzyp ) - zdistxy(1) = jlastxy - jfirstxy + 1 - call decompcreate( nprxy_x_in, 1, imxy_in, zdistxy, grid%strip2dx ) - endif - - deallocate(zdist) - deallocate(ydist_global) - deallocate(xdist_global) -! -! End of section imported from INIT_SPMD (FVdycore_GridCompMod) -! - - if ( grid%twod_decomp == 1 ) then -! Initialize ghost regions -! - !!! call t_startf('ghost_creation') - call ghostcreate( grid%strip3dxyz, gid, im, 1, im, .true., & - jm, jfirst-ng_d, jlast+ng_s, .false., & - km, kfirst, klast, .false., grid%ghostu_yz ) - call ghostcreate( grid%strip3dxyz, gid, im, 1, im, .true., & - jm, jfirst-ng_s, jlast+ng_d, .false., & - km, kfirst, klast, .false., grid%ghostv_yz ) - call ghostcreate( grid%strip3dxyz, gid, im, 1, im, .true., & - jm, jfirst-ng_d, jlast+ng_d, .false., & - km, kfirst, klast, .false., grid%ghostpt_yz ) - call ghostcreate( grid%strip3dxzyp, gid, im, 1, im, .true., & - km+1, kfirst, klast+1, .false., & - jm, jfirst, jlast, .false., grid%ghostpe_yz) - call ghostcreate( grid%strip3dxyzp, gid, im, 1, im, .true., & - jm, jfirst, jlast, .false., & - km+1, kfirst, klast+1, .false., grid%ghostpkc_yz) - !!! call t_stopf('ghost_creation') - -! Initialize transposes -! - !!! call t_startf('transpose_creation') - call parpatterncreate(commglobal, grid%ghostu_yz, grid%strip3kxyz, & - grid%u_to_uxy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxyz,grid%ghostu_yz, & - grid%uxy_to_u, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%ghostv_yz, grid%strip3kxyz, & - grid%v_to_vxy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxyz, grid%ghostv_yz, & - grid%vxy_to_v, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3dxyz, grid%strip3kxyz,& - grid%ijk_yz_to_xy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxyz, grid%strip3dxyz,& - grid%ijk_xy_to_yz, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3dxzy, grid%strip3kxzy,& - grid%ikj_yz_to_xy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxzy, grid%strip3dxzy,& - grid%ikj_xy_to_yz, mod_method=grid%mod_method) - - -! -! Note PE <-> PEXY has been redefined for PEXY ijk, but PE ikj -! - call parpatterncreate(commglobal, grid%ghostpe_yz, grid%strip3kxzyp, & - grid%pe_to_pexy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxzyp, grid%ghostpe_yz, & - grid%pexy_to_pe, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%ghostpt_yz, grid%strip3kxyz, & - grid%pt_to_ptxy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxyz, grid%ghostpt_yz, & - grid%ptxy_to_pt, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3dxyz, grid%strip3kxyz, & - grid%r4_yz_to_xy, mod_method=grid%mod_method, & - T = REAL4 ) - call parpatterncreate(commglobal, grid%strip3kxyz, grid%strip3dxyz, & - grid%r4_xy_to_yz, mod_method=grid%mod_method, & - T = REAL4 ) - call parpatterncreate(commglobal, grid%strip3kxyzp, grid%ghostpkc_yz, & - grid%pkxy_to_pkc, mod_method=grid%mod_method) -! -! These are for 'transposing' 2D arrays from XY YZ - call parpatterncreate(commglobal, grid%checker3kxy, grid%strip3dyz, & - grid%xy2d_to_yz2d, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3dyz, grid%checker3kxy, & - grid%yz2d_to_xy2d, mod_method=grid%mod_method) - !!! call t_stopf('transpose_creation') - - endif - -#if !defined( MAPL_MODE ) -! -! Define scatter and gather patterns for 2D and 3D unghosted arrays -! - - call parpatterncreate( commglobal, global2d, local2d, grid%s_2dxy_r8, & - mod_method=grid%mod_gatscat ) - call parpatterncreate( commglobal, local2d, global2d, grid%g_2dxy_r8, & - mod_method=grid%mod_gatscat ) - - call parpatterncreate( commglobal, global2d, local2d, grid%s_2dxy_r4, & - mod_method=grid%mod_gatscat, T = REAL4 ) - call parpatterncreate( commglobal, local2d, global2d, grid%g_2dxy_r4, & - mod_method=grid%mod_gatscat, T = REAL4 ) - - call parpatterncreate( commglobal, global2d, local2d, grid%s_2dxy_i4, & - mod_method=grid%mod_gatscat, T = INT4 ) - call parpatterncreate( commglobal, local2d, global2d, grid%g_2dxy_i4, & - mod_method=grid%mod_gatscat, T = INT4 ) - -! -! 3D XYZ patterns, will replace XZY patterns eventually -! - call parpatterncreate( grid%s_2dxy_r8, grid%s_3dxyz_r8, km ) - call parpatterncreate( grid%g_2dxy_r8, grid%g_3dxyz_r8, km ) - call parpatterncreate( grid%s_2dxy_r8, grid%s_3dxyzp_r8, km+1 ) - call parpatterncreate( grid%g_2dxy_r8, grid%g_3dxyzp_r8, km+1 ) - - call parpatterncreate( grid%s_2dxy_r4, grid%s_3dxyz_r4, km ) - call parpatterncreate( grid%g_2dxy_r4, grid%g_3dxyz_r4, km ) - call parpatterncreate( grid%s_2dxy_r4, grid%s_3dxyzp_r4, km+1 ) - call parpatterncreate( grid%g_2dxy_r4, grid%g_3dxyzp_r4, km+1 ) - -#endif - - call decompfree( global2d ) - call decompfree( local2d ) - - return -!EOC -end subroutine spmd_vars_init -!----------------------------------------------------------------------- -#endif - -!EOC - end subroutine dynamics_init -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: dynamics_clean -- clean up Lin-Rood-specific variables -! -! !INTERFACE: - subroutine dynamics_clean(grid) - -! !USES: - implicit none - -! !INPUT/OUTPUT PARAMETERS: - type(T_FVDYCORE_GRID), intent(inout) :: grid ! Resulting grid - - -! !DESCRIPTION: -! -! Clean up (deallocate) Lin-Rood-specific variables -! -! !REVISION HISTORY: -! -! 01.06.06 Sawyer Creation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! Temporary data structures - - if(associated(GRID%SINLON )) deallocate(GRID%SINLON) - if(associated(GRID%COSLON )) deallocate(GRID%COSLON) - if(associated(GRID%SINL5 )) deallocate(GRID%SINL5) - if(associated(GRID%COSL5 )) deallocate(GRID%COSL5) - - if(associated(GRID%ACOSP )) deallocate(GRID%ACOSP) - if(associated(GRID%ACOSU )) deallocate(GRID%ACOSU) - if(associated(GRID%SINP )) deallocate(GRID%SINP) - if(associated(GRID%COSP )) deallocate(GRID%COSP) - if(associated(GRID%SINE )) deallocate(GRID%SINE) - if(associated(GRID%COSE )) deallocate(GRID%COSE) - if(associated(GRID%AK )) deallocate(GRID%AK) - if(associated(GRID%BK )) deallocate(GRID%BK) - -! -! cd_core variables -! - if(associated( grid%dtdx )) deallocate(grid%dtdx) - if(associated( grid%dtdx2 )) deallocate(grid%dtdx2) - if(associated( grid%dtdx4 )) deallocate(grid%dtdx4) - if(associated( grid%dtdxe )) deallocate(grid%dtdxe) - if(associated( grid%dxdt )) deallocate(grid%dxdt) - if(associated( grid%dxe )) deallocate(grid%dxe) - if(associated( grid%cye )) deallocate(grid%cye) - if(associated( grid%dycp )) deallocate(grid%dycp) - if(associated( grid%rdxe )) deallocate(grid%rdxe) - if(associated( grid%txe5 )) deallocate(grid%txe5) - if(associated( grid%dtxe5 )) deallocate(grid%dtxe5) - if(associated( grid%dyce )) deallocate(grid%dyce) - if(associated( grid%dx )) deallocate(grid%dx) - if(associated( grid%rdx )) deallocate(grid%rdx) - if(associated( grid%cy )) deallocate(grid%cy) - - if(associated( grid%sc )) deallocate(grid%sc) - if(associated( grid%se )) deallocate(grid%se) - if(associated( grid%dc )) deallocate(grid%dc) - if(associated( grid%de )) deallocate(grid%de) - - if(associated( grid%cdx )) deallocate(grid%cdx) - if(associated( grid%cdy )) deallocate(grid%cdy) - - if(associated( grid%f0 )) deallocate(grid%f0) - if(associated( grid%fc )) deallocate(grid%fc) - -#if defined( MAPL_MODE ) - call ESMF_GridDestroy (GRID%GRIDYZ) -#endif - -#if defined(SPMD) - call spmd_vars_clean(grid) -#endif - return -!EOC - end subroutine dynamics_clean -!----------------------------------------------------------------------- - -#if defined(SPMD) -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: spmd_vars_clean --- Clean the SPMD-related variables -! -! !INTERFACE: -subroutine spmd_vars_clean(grid) - -! !USES: - use ghostmodule, only : ghostfree - use parutilitiesmodule, only : commglobal, parpatternfree - implicit none - -!------------------------------Commons---------------------------------- - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(inout) :: grid - -! -! !DESCRIPTION: -! -! {\bf Purpose:} Clean the SPMD related variables. -! -! !REVISION HISTORY: -! 02.11.08 Sawyer Creation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! - - if ( grid%twod_decomp == 1 ) then -! Clean the ghost regions -! - call ghostfree( grid%ghostu_yz ) - call ghostfree( grid%ghostv_yz ) - call ghostfree( grid%ghostpt_yz ) - call ghostfree( grid%ghostpe_yz ) - call ghostfree( grid%ghostpkc_yz ) -! Clean transposes -! - call parpatternfree(commglobal, grid%u_to_uxy) - call parpatternfree(commglobal, grid%uxy_to_u) - call parpatternfree(commglobal, grid%v_to_vxy) - call parpatternfree(commglobal, grid%vxy_to_v) - call parpatternfree(commglobal, grid%ijk_yz_to_xy) - call parpatternfree(commglobal, grid%ijk_xy_to_yz) - call parpatternfree(commglobal, grid%ikj_xy_to_yz) - call parpatternfree(commglobal, grid%ikj_yz_to_xy) - call parpatternfree(commglobal, grid%pe_to_pexy) - call parpatternfree(commglobal, grid%pexy_to_pe) - call parpatternfree(commglobal, grid%pt_to_ptxy) - call parpatternfree(commglobal, grid%ptxy_to_pt) - call parpatternfree(commglobal, grid%r4_xy_to_yz) - call parpatternfree(commglobal, grid%r4_yz_to_xy) - call parpatternfree(commglobal, grid%pkxy_to_pkc) - call parpatternfree(commglobal, grid%xy2d_to_yz2d) - call parpatternfree(commglobal, grid%yz2d_to_xy2d) - endif - return -!EOC -end subroutine spmd_vars_clean -#endif - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: a2d3d -- 2nd order A-to-D grid transform (3D) XY decomp -! INOUT array is i,j,k, and is modified in place -! -! !INTERFACE: - - subroutine a2d3d( grid, u, v ) - -! !USES: - -#if defined( SPMD ) - use parutilitiesmodule, only : parcollective3d, sumop, gid - use mod_comm, only: commglobal, commglobal, mp_send3d, mp_recv3d -#endif - - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(inout) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !DESCRIPTION: -! -! This routine performs a second order interpolation of -! three-dimensional wind fields on a A grid to an D grid. -! In place calculation! -! -! !REVISION HISTORY: -! WS 03.08.27 : Creation from d2a3d -! WS 03.10.22 : pmgrid removed (now spmd_dyn) -! WS 04.08.25 : simplified interfaces with grid (only for XY!!!) -! WS 04.10.06 : removed spmd_dyn, all those vars. now from grid -! -!EOP -!----------------------------------------------------------------------- -!BOC - - integer :: im ! Dimensions longitude (total) - integer :: jm ! Dimensions latitude (total) - integer :: km ! Dimensions vertical (total) - integer :: ifirst ! longitude strip start - integer :: ilast ! longitude strip finish - integer :: jfirst ! latitude strip start - integer :: jlast ! latitude strip finish - integer :: iam ! process identifier - integer :: myidxy_y, myidxy_x, nprxy_x - integer :: comm_y, commxy_y, commxy_x - - real(r8), parameter :: UNDEFINED = 1.0D15 - - integer :: i, j, k, itot, jtot - real(r8) :: vwest(grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) :: usouth(grid%ifirstxy:grid%ilastxy,grid%km) - -#if defined( SPMD ) - integer dest, src -#endif - - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - myidxy_x = grid%myidxy_x - myidxy_y = grid%myidxy_y - nprxy_x = grid%nprxy_x - - comm_y = grid%comm_y - commxy_x = grid%commxy_x - commxy_y = grid%commxy_y - - itot = ilast-ifirst+1 - jtot = jlast-jfirst+1 - -#if defined( SPMD ) -! Send one latitude to the north - call mp_send3d( commglobal, iam+nprxy_x, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jlast, jlast, 1, km, u ) - call mp_recv3d( commglobal, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jfirst-1, jfirst-1, 1, km, & - ifirst, ilast, jfirst-1, jfirst-1, 1, km, usouth ) -#endif - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jlast, jfirst+1, -1 - do i=ifirst,ilast - u(i,j,k) = D0_5*(u(i,j-1,k) + u(i,j,k)) - enddo - enddo - enddo - -#if defined( SPMD ) - if ( jfirst > 1 ) then -!$omp parallel do private(i, k) - do k=1,km - do i=ifirst,ilast - u(i,jfirst,k) = D0_5 * ( u(i,jfirst,k) + usouth(i,k) ) - enddo - enddo - endif -#endif - - if ( jfirst == 1 ) then -!$omp parallel do private(i,k) - do k=1,km - do i=ifirst,ilast - u(i,1,k) = UNDEFINED - enddo - enddo - endif - -! -! V-winds -! - -! Pack vwest with wrap-around condition - -!$omp parallel do private(j,k) - do k = 1,km - do j=jfirst,jlast - vwest(j,k) = v(ilast,j,k) - enddo - enddo - -#if defined( SPMD ) - if (itot /= im) then - dest = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ilast, ilast, jfirst, jlast, 1, km, v ) - call mp_recv3d( commglobal, src, im, jm, km, & - ifirst-1, ifirst-1, jfirst, jlast, 1, km, & - ifirst-1, ifirst-1, jfirst, jlast, 1, km, vwest ) - endif -#endif - -! -! Beware: ilast is en route, don't alter its value -! - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst, jlast - do i=ilast,ifirst+1,-1 - v(i,j,k) = D0_5*(v(i-1,j,k) + v(i,j,k)) - enddo - enddo - enddo -! -! Clean up shop -! - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst, jlast - v(ifirst,j,k)= D0_5*(vwest(j,k) + v(ifirst,j,k)) - enddo - enddo - - return -!EOC - end subroutine a2d3d -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: d2a3d -- 2nd order D-to-A grid transform (3D) XY decomp. -! Output array is i,j,k -! -! !INTERFACE: - - subroutine d2a3d( grid, u, v, ua, va ) - -! !USES: - -#if defined( SPMD ) - use parutilitiesmodule, only : parcollective3d, sumop - use mod_comm, only: commglobal, mp_send3d, mp_recv3d -#endif - - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - real(r8), intent(in) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(in) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: ua(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(inout) :: va(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - - -! !DESCRIPTION: -! -! This routine performs a second order -! interpolation of three-dimensional wind -! fields on a D grid to an A grid. Only for an XY decomposition! -! -! !REVISION HISTORY: -! WS 00.12.22 : Creation from d2a3d -! AAM 01.06.13 : Generalized to 2D decomposition -! WS 02.04.25 : Newest mod_comm interfaces -! WS 03.08.27 : Minimal alterations to interface, renamed d2a3d -! WS 03.10.22 : pmgrid removed (now spmd_dyn) -! WS 04.08.25 : simplified interfaces with grid (only for XY!!!) -! WS 04.10.06 : removed spmd_dyn, all those vars. now from grid -! -!EOP -!----------------------------------------------------------------------- -!BOC - integer :: im ! Dimensions longitude (total) - integer :: jm ! Dimensions latitude (total) - integer :: km ! Dimensions level (total) - integer :: ifirst ! longitude strip start - integer :: ilast ! longitude strip finish - integer :: jfirst ! latitude strip start - integer :: jlast ! latitude strip finish - integer :: iam, myidxy_y, nprxy_x, commxy_x - - real(r8), pointer :: coslon(:) ! Cosine in longitude - real(r8), pointer :: sinlon(:) ! Sine in longitude - - integer imh, i, j, k, itot, jtot, ltot, lbegin, lend, ik - - real(r8) :: un(grid%km), vn(grid%km), us(grid%km), vs(grid%km) - real(r8) :: veast(grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) :: unorth(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) :: uvaglob(grid%im,grid%km,4) - real(r8) :: uvaloc(grid%ifirstxy:grid%ilastxy,grid%km,4) - real(r8) :: uaglob(grid%im),vaglob(grid%im) - -#if defined( SPMD ) - integer dest, src, incount, outcount -#endif - -! -! Retrieve values from grid -! - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - nprxy_x = grid%nprxy_x - commxy_x = grid%commxy_x - myidxy_y = grid%myidxy_y - - coslon =>grid%coslon - sinlon =>grid%sinlon - - itot = ilast-ifirst+1 - jtot = jlast-jfirst+1 - - imh = im/2 - -#if defined( SPMD ) -! Set ua on A-grid - call mp_send3d( commglobal, iam-nprxy_x, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jfirst, jfirst, 1, km, u ) - call mp_recv3d( commglobal, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, unorth ) - - if ( jlast .lt. jm ) then -!$omp parallel do private(i, k) - - do k=1,km - do i=ifirst,ilast - ua(i,jlast,k) = D0_5 * ( u(i,jlast,k) + unorth(i,k) ) - enddo - enddo - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst, jlast-1 - do i=ifirst,ilast - ua(i,j,k) = D0_5*(u(i,j,k) + u(i,j+1,k)) - enddo - enddo - enddo - -! Set va on A-grid - -!$omp parallel do private(j,k) - - do k = 1,km - do j=jfirst,jlast - veast(j,k) = v(ifirst,j,k) - enddo - enddo - -#if defined( SPMD ) - if (itot .ne. im) then - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ifirst, jfirst, jlast, 1, km, v ) - call mp_recv3d( commglobal, src, im, jm, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, veast ) - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst, jlast - do i=ifirst,ilast-1 - va(i,j,k) = D0_5*(v(i,j,k) + v(i+1,j,k)) - enddo - va(ilast,j,k) = D0_5*(v(ilast,j,k) + veast(j,k)) - enddo - enddo - -!$omp parallel do private(i,ik,k) - - do ik=1,4 - do k=1,km - do i=1,im - uvaglob(i,k,ik) = D0_0 - enddo - enddo - enddo - - if (jfirst .eq. 1) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvaloc(i,k,1) = ua(i,2,k) - uvaloc(i,k,2) = va(i,2,k) - uvaglob(i,k,1) = ua(i,2,k) - uvaglob(i,k,2) = va(i,2,k) - enddo - enddo - lbegin = 1 - lend = 2 - endif - - if (jlast .eq. jm) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvaloc(i,k,3) = ua(i,jm-1,k) - uvaloc(i,k,4) = va(i,jm-1,k) - uvaglob(i,k,3) = ua(i,jm-1,k) - uvaglob(i,k,4) = va(i,jm-1,k) - enddo - enddo - lbegin = 3 - lend = 4 - endif - if (jtot .eq. jm) lbegin=1 - -#if defined( SPMD ) - if (itot .ne. im) then - if (jfirst .eq. 1 .or. jlast .eq. jm) then - ltot = lend-lbegin+1 - call parcollective3d(commxy_x, sumop, im, km, ltot, uvaglob(1,1,lbegin)) - endif - endif -#endif - - if ( jfirst .eq. 1 ) then -! Projection at SP -!$omp parallel do private(i,k,uaglob,vaglob) - do k=1,km - us(k) = D0_0 - vs(k) = D0_0 - do i=1,imh - us(k) = us(k) + (uvaglob(i+imh,k,1)-uvaglob(i,k,1))*sinlon(i) & - + (uvaglob(i,k,2)-uvaglob(i+imh,k,2))*coslon(i) - vs(k) = vs(k) + (uvaglob(i+imh,k,1)-uvaglob(i,k,1))*coslon(i) & - + (uvaglob(i+imh,k,2)-uvaglob(i,k,2))*sinlon(i) - enddo - - us(k) = us(k)/im - vs(k) = vs(k)/im - do i=1,imh - uaglob(i) = -us(k)*sinlon(i) - vs(k)*coslon(i) - vaglob(i) = us(k)*coslon(i) - vs(k)*sinlon(i) - uaglob(i+imh) = -uaglob(i) - vaglob(i+imh) = -vaglob(i) - enddo - do i=ifirst,ilast - ua(i,1,k) = uaglob(i) - va(i,1,k) = vaglob(i) - enddo - enddo - endif - - if ( jlast .eq. jm ) then -! Projection at NP -!$omp parallel do private(i,k,uaglob,vaglob) - do k=1,km - un(k) = D0_0 - vn(k) = D0_0 - do i=1,imh - un(k) = un(k) + (uvaglob(i+imh,k,3)-uvaglob(i,k,3))*sinlon(i) & - + (uvaglob(i+imh,k,4)-uvaglob(i,k,4))*coslon(i) - vn(k) = vn(k) + (uvaglob(i,k,3)-uvaglob(i+imh,k,3))*coslon(i) & - + (uvaglob(i+imh,k,4)-uvaglob(i,k,4))*sinlon(i) - enddo - - un(k) = un(k)/im - vn(k) = vn(k)/im - do i=1,imh - uaglob(i) = -un(k)*sinlon(i) + vn(k)*coslon(i) - vaglob(i) = -un(k)*coslon(i) - vn(k)*sinlon(i) - uaglob(i+imh) = -uaglob(i) - vaglob(i+imh) = -vaglob(i) - enddo - do i=ifirst,ilast - ua(i,jm,k) = uaglob(i) - va(i,jm,k) = vaglob(i) - enddo - enddo - endif - - return -!EOC - end subroutine d2a3d -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: d2b3d -- 2nd order D-to-B grid transform (3D) XY decomp. -! Output array is i,j,k -! -! !INTERFACE: - - subroutine d2b3d( grid, u, v, ub, vb ) - -! !USES: -#if defined( SPMD ) - use parutilitiesmodule, only : parcollective3d, sumop - use mod_comm, only: commglobal, mp_send3d, mp_recv3d -#endif - - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - real(r8), intent(in) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(in) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: ub(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(inout) :: vb(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - - -! !DESCRIPTION: -! -! This routine performs a second order -! interpolation of three-dimensional wind -! fields on a D grid to an B grid. Only for an XY decomposition! -! -! !REVISION HISTORY: -! BP 05.02.22 : Creation from d2a3d -! -!EOP -!----------------------------------------------------------------------- -!BOC - integer :: im ! Dimensions longitude (total) - integer :: jm ! Dimensions latitude (total) - integer :: km ! Dimensions level (total) - integer :: ifirst ! longitude strip start - integer :: ilast ! longitude strip finish - integer :: jfirst ! latitude strip start - integer :: jlast ! latitude strip finish - integer :: iam, myidxy_y, nprxy_x, commxy_x - - real(r8), parameter :: UNDEFINED = 1.0D15 - - - real(r8), pointer :: coslon(:) ! Cosine in longitude - real(r8), pointer :: sinlon(:) ! Sine in longitude - - integer imh, i, j, k, itot, jtot, ltot, lbegin, lend, ik - - real(r8) :: ueast(grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) :: vsouth(grid%ifirstxy:grid%ilastxy,grid%km) - -#if defined( SPMD ) - integer dest, src, incount, outcount -#endif - -! -! Retrieve values from grid -! - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - nprxy_x = grid%nprxy_x - commxy_x = grid%commxy_x - myidxy_y = grid%myidxy_y - - coslon =>grid%coslon - sinlon =>grid%sinlon - - itot = ilast-ifirst+1 - jtot = jlast-jfirst+1 - - imh = im/2 - -#if defined( SPMD ) -! Set vb on B-grid - call mp_send3d( commglobal, iam+nprxy_x, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jfirst, jfirst, 1, km, v ) - call mp_recv3d( commglobal, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, vsouth ) - - if ( jfirst .gt. 1 ) then -!$omp parallel do private(i, k) - - do k=1,km - do i=ifirst,ilast - vb(i,jfirst,k) = D0_5 * ( v(i,jfirst,k) + vsouth(i,k) ) - enddo - enddo - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst+1, jlast - do i=ifirst,ilast - vb(i,j,k) = D0_5*(v(i,j,k) + v(i,j-1,k)) - enddo - enddo - enddo - -! Set ub on B-grid - -!$omp parallel do private(j,k) - - do k = 1,km - do j=jfirst,jlast - ueast(j,k) = u(ifirst,j,k) - enddo - enddo - -#if defined( SPMD ) - if (itot .ne. im) then - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ifirst, jfirst, jlast, 1, km, u ) - call mp_recv3d( commglobal, src, im, jm, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, ueast ) - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst, jlast - do i=ifirst,ilast-1 - ub(i,j,k) = D0_5*(u(i,j,k) + u(i+1,j,k)) - enddo - ub(ilast,j,k) = D0_5*(u(ilast,j,k) + ueast(j,k)) - enddo - enddo - - if ( jfirst == 1 ) then -!$omp parallel do private(i,k) - do k=1,km - do i=ifirst,ilast - ub(i,1,k) = UNDEFINED - vb(i,1,k) = UNDEFINED - enddo - enddo - endif - - return -!EOC - end subroutine d2b3d -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: b2d3d -- 2nd order B-to-D grid transform (3D) XY decomp -! INOUT array is i,j,k, and is modified in place -! -! !INTERFACE: - - subroutine b2d3d( grid, u, v ) - -! !USES: -#if defined( SPMD ) - use parutilitiesmodule, only : parcollective3d, sumop, gid - use mod_comm, only: commglobal, mp_send3d, mp_recv3d -#endif - - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(inout) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !DESCRIPTION: -! -! This routine performs a second order interpolation of -! three-dimensional wind fields on a B grid to an D grid. -! In place calculation! -! -! !REVISION HISTORY: -! BP 05.02.22 : Creation from a2d3d -! -!EOP -!----------------------------------------------------------------------- -!BOC - - integer :: im ! Dimensions longitude (total) - integer :: jm ! Dimensions latitude (total) - integer :: km ! Dimensions vertical (total) - integer :: ifirst ! longitude strip start - integer :: ilast ! longitude strip finish - integer :: jfirst ! latitude strip start - integer :: jlast ! latitude strip finish - integer :: iam ! process identifier - integer :: myidxy_y, myidxy_x, nprxy_x - integer :: comm_y, commxy_y, commxy_x - - real(r8), parameter :: UNDEFINED = 1.0D15 - - real(r8) :: uwest(grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) :: vsouth(grid%ifirstxy:grid%ilastxy,grid%km) - - integer :: imh, i, j, k, itot, jtot, ltot, lbegin, lend, ik - real(r8) :: un(grid%km), vn(grid%km), us(grid%km), vs(grid%km) - real(r8) :: uvbglob(grid%im,grid%km,4) - real(r8) :: uvbloc(grid%ifirstxy:grid%ilastxy,grid%km,4) - real(r8) :: ubglob(grid%im),vbglob(grid%im) - - real(r8), pointer :: coslon(:) ! Cosine in longitude - real(r8), pointer :: sinlon(:) ! Sine in longitude - real(r8), pointer :: cosl5(:) ! Cosine in longitude - real(r8), pointer :: sinl5(:) ! Sine in longitude - -#if defined( SPMD ) - integer dest, src -#endif - - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - myidxy_x = grid%myidxy_x - myidxy_y = grid%myidxy_y - nprxy_x = grid%nprxy_x - - comm_y = grid%comm_y - commxy_x = grid%commxy_x - commxy_y = grid%commxy_y - - itot = ilast-ifirst+1 - jtot = jlast-jfirst+1 - - imh = im/2 - coslon => grid%coslon - sinlon => grid%sinlon - cosl5 => grid%cosl5 - sinl5 => grid%sinl5 - -! -! Initial Preparation for Projection at Poles -! -!$omp parallel do private(i,ik,k) - - do ik=1,4 - do k=1,km - do i=1,im - uvbglob(i,k,ik) = D0_0 - enddo - enddo - enddo - - if (jfirst .eq. 1) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvbloc(i,k,1) = u(i,2,k) - uvbloc(i,k,2) = v(i,2,k) - uvbglob(i,k,1) = u(i,2,k) - uvbglob(i,k,2) = v(i,2,k) - enddo - enddo - lbegin = 1 - lend = 2 - endif - - if (jlast .eq. jm) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvbloc(i,k,3) = u(i,jm,k) - uvbloc(i,k,4) = v(i,jm,k) - uvbglob(i,k,3) = u(i,jm,k) - uvbglob(i,k,4) = v(i,jm,k) - enddo - enddo - lbegin = 3 - lend = 4 - endif - if (jtot .eq. jm) lbegin=1 - -#if defined( SPMD ) - if (itot .ne. im) then - if (jfirst .eq. 1 .or. jlast .eq. jm) then - ltot = lend-lbegin+1 - call parcollective3d(commxy_x, sumop, im, km, ltot, uvbglob(1,1,lbegin)) - endif - endif -#endif - -! -! V-Winds -! - -#if defined( SPMD ) -! Send one latitude to the north - call mp_send3d( commglobal, iam+nprxy_x, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jlast, jlast, 1, km, v ) - call mp_recv3d( commglobal, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jfirst-1, jfirst-1, 1, km, & - ifirst, ilast, jfirst-1, jfirst-1, 1, km, vsouth ) -#endif - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jlast, jfirst+1, -1 - do i=ifirst,ilast - v(i,j,k) = D0_5*(v(i,j-1,k) + v(i,j,k)) - enddo - enddo - enddo - -#if defined( SPMD ) - if ( jfirst > 1 ) then -!$omp parallel do private(i, k) - do k=1,km - do i=ifirst,ilast - v(i,jfirst,k) = D0_5 * ( v(i,jfirst,k) + vsouth(i,k) ) - enddo - enddo - endif -#endif - -! -! U-winds -! - -! Pack uwest with wrap-around condition - -!$omp parallel do private(j,k) - do k = 1,km - do j=jfirst,jlast - uwest(j,k) = v(ilast,j,k) - enddo - enddo - -#if defined( SPMD ) - if (itot /= im) then - dest = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ilast, ilast, jfirst, jlast, 1, km, u ) - call mp_recv3d( commglobal, src, im, jm, km, & - ifirst-1, ifirst-1, jfirst, jlast, 1, km, & - ifirst-1, ifirst-1, jfirst, jlast, 1, km, uwest ) - endif -#endif - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst, jlast - do i=ilast,ifirst+1,-1 - u(i,j,k) = D0_5*(u(i-1,j,k) + u(i,j,k)) - enddo - enddo - enddo - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst, jlast - u(ifirst,j,k)= D0_5*(uwest(j,k) + u(ifirst,j,k)) - enddo - enddo - - if ( jfirst == 1 ) then -!$omp parallel do private(i,k) - do k=1,km - do i=ifirst,ilast - u(i,1,k) = UNDEFINED - enddo - enddo - endif - -! -! Project V-Winds to the Poles -! - if ( jfirst == 1 ) then -! Projection at SP -!$omp parallel do private(i,k,ubglob,vbglob) - do k=1,km - us(k) = D0_0 - vs(k) = D0_0 - do i=1,imh - us(k) = us(k) + (uvbglob(i+imh,k,1)-uvbglob(i,k,1))*sinlon(i) & - + (uvbglob(i,k,2)-uvbglob(i+imh,k,2))*coslon(i) - vs(k) = vs(k) + (uvbglob(i+imh,k,1)-uvbglob(i,k,1))*coslon(i) & - + (uvbglob(i+imh,k,2)-uvbglob(i,k,2))*sinlon(i) - enddo - - us(k) = us(k)/im - vs(k) = vs(k)/im - do i=1,imh - vbglob(i) = us(k)*cosl5(i) - vs(k)*sinl5(i) - vbglob(i+imh) = -vbglob(i) - enddo - do i=ifirst,ilast - v(i,1,k) = vbglob(i) - enddo - enddo - endif - - if ( jlast == jm ) then -! Projection at NP -!$omp parallel do private(i,k,ubglob,vbglob) - do k=1,km - un(k) = D0_0 - vn(k) = D0_0 - do i=1,imh - un(k) = un(k) + (uvbglob(i+imh,k,3)-uvbglob(i,k,3))*sinlon(i) & - + (uvbglob(i+imh,k,4)-uvbglob(i,k,4))*coslon(i) - vn(k) = vn(k) + (uvbglob(i,k,3)-uvbglob(i+imh,k,3))*coslon(i) & - + (uvbglob(i+imh,k,4)-uvbglob(i,k,4))*sinlon(i) - enddo - - un(k) = un(k)/im - vn(k) = vn(k)/im - do i=1,imh - vbglob(i) = -un(k)*cosl5(i) - vn(k)*sinl5(i) - vbglob(i+imh) = -vbglob(i) - enddo - do i=ifirst,ilast - v(i,jm,k) = vbglob(i) - enddo - enddo - endif - - return -!EOC - end subroutine b2d3d -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: c2a3d -- 2nd order C-to-A grid transform (3D) XY decomp. -! Output array is i,j,k -! -! !INTERFACE: - - subroutine c2a3d( grid, u, v, ua, va ) - -! !USES: - -#if defined( SPMD ) - use parutilitiesmodule, only : parcollective3d, sumop - use mod_comm, only: commglobal, mp_send3d, mp_recv3d -#endif - - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - real(r8), intent(in) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(in) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: ua(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(inout) :: va(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !DESCRIPTION: -! -! This routine performs a second order -! interpolation of three-dimensional wind -! fields on a C grid to an A grid. Only for an XY decomposition! -! -! !REVISION HISTORY: -! WMP 06.11.03 : Creation from d2a3d -! -!EOP -!----------------------------------------------------------------------- -!BOC - integer :: im ! Dimensions longitude (total) - integer :: jm ! Dimensions latitude (total) - integer :: km ! Dimensions level (total) - integer :: ifirst ! longitude strip start - integer :: ilast ! longitude strip finish - integer :: jfirst ! latitude strip start - integer :: jlast ! latitude strip finish - integer :: iam, myidxy_y, nprxy_x, commxy_x - - real(r8), pointer :: coslon(:) ! Cosine in longitude - real(r8), pointer :: sinlon(:) ! Sine in longitude - - integer imh, i, j, k, itot, jtot, ltot, lbegin, lend, ik - - real(r8) :: un(grid%km), vn(grid%km), us(grid%km), vs(grid%km) - real(r8) :: ueast(grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) :: vnorth(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) :: uvaglob(grid%im,grid%km,4) - real(r8) :: uvaloc(grid%ifirstxy:grid%ilastxy,grid%km,4) - real(r8) :: uaglob(grid%im),vaglob(grid%im) - -#if defined( SPMD ) - integer dest, src, incount, outcount -#endif - -! -! Retrieve values from grid -! - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - nprxy_x = grid%nprxy_x - commxy_x = grid%commxy_x - myidxy_y = grid%myidxy_y - - coslon =>grid%coslon - sinlon =>grid%sinlon - - itot = ilast-ifirst+1 - jtot = jlast-jfirst+1 - - imh = im/2 - -#if defined( SPMD ) -! Set va on A-grid - call mp_send3d( commglobal, iam-nprxy_x, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jfirst, jfirst, 1, km, v ) - call mp_recv3d( commglobal, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, vnorth ) - - if ( jlast .lt. jm ) then -!$omp parallel do private(i, k) - - do k=1,km - do i=ifirst,ilast - va(i,jlast,k) = D0_5 * ( v(i,jlast,k) + vnorth(i,k) ) - enddo - enddo - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst, jlast-1 - do i=ifirst,ilast - va(i,j,k) = D0_5*(v(i,j,k) + v(i,j+1,k)) - enddo - enddo - enddo - -! Set ua on A-grid - -!$omp parallel do private(j,k) - - do k = 1,km - do j=jfirst,jlast - ueast(j,k) = u(ifirst,j,k) - enddo - enddo - -#if defined( SPMD ) - if (itot .ne. im) then - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ifirst, jfirst, jlast, 1, km, u ) - call mp_recv3d( commglobal, src, im, jm, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, ueast ) - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst, jlast - do i=ifirst,ilast-1 - ua(i,j,k) = D0_5*(u(i,j,k) + u(i+1,j,k)) - enddo - ua(ilast,j,k) = D0_5*(u(ilast,j,k) + ueast(j,k)) - enddo - enddo - -!$omp parallel do private(i,ik,k) - - do ik=1,4 - do k=1,km - do i=1,im - uvaglob(i,k,ik) = D0_0 - enddo - enddo - enddo - - if (jfirst .eq. 1) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvaloc(i,k,1) = ua(i,2,k) - uvaloc(i,k,2) = va(i,2,k) - uvaglob(i,k,1) = ua(i,2,k) - uvaglob(i,k,2) = va(i,2,k) - enddo - enddo - lbegin = 1 - lend = 2 - endif - - if (jlast .eq. jm) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvaloc(i,k,3) = ua(i,jm-1,k) - uvaloc(i,k,4) = va(i,jm-1,k) - uvaglob(i,k,3) = ua(i,jm-1,k) - uvaglob(i,k,4) = va(i,jm-1,k) - enddo - enddo - lbegin = 3 - lend = 4 - endif - if (jtot .eq. jm) lbegin=1 - -#if defined( SPMD ) - if (itot .ne. im) then - if (jfirst .eq. 1 .or. jlast .eq. jm) then - ltot = lend-lbegin+1 - call parcollective3d(commxy_x, sumop, im, km, ltot, uvaglob(1,1,lbegin)) - endif - endif -#endif - - if ( jfirst .eq. 1 ) then -! Projection at SP -!$omp parallel do private(i,k,uaglob,vaglob) - do k=1,km - us(k) = D0_0 - vs(k) = D0_0 - do i=1,imh - us(k) = us(k) + (uvaglob(i+imh,k,1)-uvaglob(i,k,1))*sinlon(i) & - + (uvaglob(i,k,2)-uvaglob(i+imh,k,2))*coslon(i) - vs(k) = vs(k) + (uvaglob(i+imh,k,1)-uvaglob(i,k,1))*coslon(i) & - + (uvaglob(i+imh,k,2)-uvaglob(i,k,2))*sinlon(i) - enddo - - us(k) = us(k)/im - vs(k) = vs(k)/im - do i=1,imh - uaglob(i) = -us(k)*sinlon(i) - vs(k)*coslon(i) - vaglob(i) = us(k)*coslon(i) - vs(k)*sinlon(i) - uaglob(i+imh) = -uaglob(i) - vaglob(i+imh) = -vaglob(i) - enddo - do i=ifirst,ilast - ua(i,1,k) = uaglob(i) - va(i,1,k) = vaglob(i) - enddo - enddo - endif - - if ( jlast .eq. jm ) then -! Projection at NP -!$omp parallel do private(i,k,uaglob,vaglob) - do k=1,km - un(k) = D0_0 - vn(k) = D0_0 - do i=1,imh - un(k) = un(k) + (uvaglob(i+imh,k,3)-uvaglob(i,k,3))*sinlon(i) & - + (uvaglob(i+imh,k,4)-uvaglob(i,k,4))*coslon(i) - vn(k) = vn(k) + (uvaglob(i,k,3)-uvaglob(i+imh,k,3))*coslon(i) & - + (uvaglob(i+imh,k,4)-uvaglob(i,k,4))*sinlon(i) - enddo - - un(k) = un(k)/im - vn(k) = vn(k)/im - do i=1,imh - uaglob(i) = -un(k)*sinlon(i) + vn(k)*coslon(i) - vaglob(i) = -un(k)*coslon(i) - vn(k)*sinlon(i) - uaglob(i+imh) = -uaglob(i) - vaglob(i+imh) = -vaglob(i) - enddo - do i=ifirst,ilast - ua(i,jm,k) = uaglob(i) - va(i,jm,k) = vaglob(i) - enddo - enddo - endif - - return -!EOC - end subroutine c2a3d -!----------------------------------------------------------------------- - -end module dynamics_vars diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/fft99.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/fft99.F90 deleted file mode 100644 index eae01e783..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/fft99.F90 +++ /dev/null @@ -1,1207 +0,0 @@ - SUBROUTINE FFT99(A,WORK,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN) -! -! PURPOSE PERFORMS MULTIPLE FAST FOURIER TRANSFORMS. THIS PACKAGE -! WILL PERFORM A NUMBER OF SIMULTANEOUS REAL/HALF-COMPLEX -! PERIODIC FOURIER TRANSFORMS OR CORRESPONDING INVERSE -! TRANSFORMS, I.E. GIVEN A SET OF REAL DATA VECTORS, THE -! PACKAGE RETURNS A SET OF 'HALF-COMPLEX' FOURIER -! COEFFICIENT VECTORS, OR VICE VERSA. THE LENGTH OF THE -! TRANSFORMS MUST BE AN EVEN NUMBER GREATER THAN 4 THAT HAS -! NO OTHER FACTORS EXCEPT POSSIBLY POWERS OF 2, 3, AND 5. -! THIS IS AN ALL FORTRAN VERSION OF THE CRAYLIB PACKAGE -! THAT IS MOSTLY WRITTEN IN CAL. -! -! THE PACKAGE FFT99F CONTAINS SEVERAL USER-LEVEL ROUTINES: -! -! SUBROUTINE SET99 -! AN INITIALIZATION ROUTINE THAT MUST BE CALLED ONCE -! BEFORE A SEQUENCE OF CALLS TO THE FFT ROUTINES -! (PROVIDED THAT N IS NOT CHANGED). -! -! SUBROUTINES FFT99 AND FFT991 -! TWO FFT ROUTINES THAT RETURN SLIGHTLY DIFFERENT -! ARRANGEMENTS OF THE DATA IN GRIDPOINT SPACE. -! -! -! ACCESS THIS FORTRAN VERSION MAY BE ACCESSED WITH -! -! *FORTRAN,P=XLIB,SN=FFT99F -! -! TO ACCESS THE CRAY OBJECT CODE, CALLING THE USER ENTRY -! POINTS FROM A CRAY PROGRAM IS SUFFICIENT. THE SOURCE -! FORTRAN AND CAL CODE FOR THE CRAYLIB VERSION MAY BE -! ACCESSED USING -! -! FETCH P=CRAYLIB,SN=FFT99 -! FETCH P=CRAYLIB,SN=CAL99 -! -! USAGE LET N BE OF THE FORM 2**P * 3**Q * 5**R, WHERE P .GE. 1, -! Q .GE. 0, AND R .GE. 0. THEN A TYPICAL SEQUENCE OF -! CALLS TO TRANSFORM A GIVEN SET OF REAL VECTORS OF LENGTH -! N TO A SET OF 'HALF-COMPLEX' FOURIER COEFFICIENT VECTORS -! OF LENGTH N IS -! -! DIMENSION IFAX(13),TRIGS(3*N/2+1),A(M*(N+2)), -! + WORK(M*(N+1)) -! -! CALL SET99 (TRIGS, IFAX, N) -! CALL FFT99 (A,WORK,TRIGS,IFAX,INC,JUMP,N,M,ISIGN) -! -! SEE THE INDIVIDUAL WRITE-UPS FOR SET99, FFT99, AND -! FFT991 BELOW, FOR A DETAILED DESCRIPTION OF THE -! ARGUMENTS. -! -! HISTORY THE PACKAGE WAS WRITTEN BY CLIVE TEMPERTON AT ECMWF IN -! NOVEMBER, 1978. IT WAS MODIFIED, DOCUMENTED, AND TESTED -! FOR NCAR BY RUSS REW IN SEPTEMBER, 1980. -! -!----------------------------------------------------------------------- -! -! SUBROUTINE SET99 (TRIGS, IFAX, N) -! -! PURPOSE A SET-UP ROUTINE FOR FFT99 AND FFT991. IT NEED ONLY BE -! CALLED ONCE BEFORE A SEQUENCE OF CALLS TO THE FFT -! ROUTINES (PROVIDED THAT N IS NOT CHANGED). -! -! ARGUMENT IFAX(13),TRIGS(3*N/2+1) -! DIMENSIONS -! -! ARGUMENTS -! -! ON INPUT TRIGS -! A FLOATING POINT ARRAY OF DIMENSION 3*N/2 IF N/2 IS -! EVEN, OR 3*N/2+1 IF N/2 IS ODD. -! -! IFAX -! AN INTEGER ARRAY. THE NUMBER OF ELEMENTS ACTUALLY USED -! WILL DEPEND ON THE FACTORIZATION OF N. DIMENSIONING -! IFAX FOR 13 SUFFICES FOR ALL N LESS THAN A MILLION. -! -! N -! AN EVEN NUMBER GREATER THAN 4 THAT HAS NO PRIME FACTOR -! GREATER THAN 5. N IS THE LENGTH OF THE TRANSFORMS (SEE -! THE DOCUMENTATION FOR FFT99 AND FFT991 FOR THE -! DEFINITIONS OF THE TRANSFORMS). -! -! ON OUTPUT IFAX -! CONTAINS THE FACTORIZATION OF N/2. IFAX(1) IS THE -! NUMBER OF FACTORS, AND THE FACTORS THEMSELVES ARE STORED -! IN IFAX(2),IFAX(3),... IF SET99 IS CALLED WITH N ODD, -! OR IF N HAS ANY PRIME FACTORS GREATER THAN 5, IFAX(1) -! IS SET TO -99. -! -! TRIGS -! AN ARRAY OF TRIGONOMETRIC FUNCTION VALUES SUBSEQUENTLY -! USED BY THE FFT ROUTINES. -! -!----------------------------------------------------------------------- -! -! SUBROUTINE FFT991 (A,WORK,TRIGS,IFAX,INC,JUMP,N,M,ISIGN) -! AND -! SUBROUTINE FFT99 (A,WORK,TRIGS,IFAX,INC,JUMP,N,M,ISIGN) -! -! PURPOSE PERFORM A NUMBER OF SIMULTANEOUS REAL/HALF-COMPLEX -! PERIODIC FOURIER TRANSFORMS OR CORRESPONDING INVERSE -! TRANSFORMS, USING ORDINARY SPATIAL ORDER OF GRIDPOINT -! VALUES (FFT991) OR EXPLICIT CYCLIC CONTINUITY IN THE -! GRIDPOINT VALUES (FFT99). GIVEN A SET -! OF REAL DATA VECTORS, THE PACKAGE RETURNS A SET OF -! 'HALF-COMPLEX' FOURIER COEFFICIENT VECTORS, OR VICE -! VERSA. THE LENGTH OF THE TRANSFORMS MUST BE AN EVEN -! NUMBER THAT HAS NO OTHER FACTORS EXCEPT POSSIBLY POWERS -! OF 2, 3, AND 5. THESE VERSION OF FFT991 AND FFT99 ARE -! OPTIMIZED FOR USE ON THE CRAY-1. -! -! ARGUMENT A(M*(N+2)), WORK(M*(N+1)), TRIGS(3*N/2+1), IFAX(13) -! DIMENSIONS -! -! ARGUMENTS -! -! ON INPUT A -! AN ARRAY OF LENGTH M*(N+2) CONTAINING THE INPUT DATA -! OR COEFFICIENT VECTORS. THIS ARRAY IS OVERWRITTEN BY -! THE RESULTS. -! -! WORK -! A WORK ARRAY OF DIMENSION M*(N+1) -! -! TRIGS -! AN ARRAY SET UP BY SET99, WHICH MUST BE CALLED FIRST. -! -! IFAX -! AN ARRAY SET UP BY SET99, WHICH MUST BE CALLED FIRST. -! -! INC -! THE INCREMENT (IN WORDS) BETWEEN SUCCESSIVE ELEMENTS OF -! EACH DATA OR COEFFICIENT VECTOR (E.G. INC=1 FOR -! CONSECUTIVELY STORED DATA). -! -! JUMP -! THE INCREMENT (IN WORDS) BETWEEN THE FIRST ELEMENTS OF -! SUCCESSIVE DATA OR COEFFICIENT VECTORS. ON THE CRAY-1, -! TRY TO ARRANGE DATA SO THAT JUMP IS NOT A MULTIPLE OF 8 -! (TO AVOID MEMORY BANK CONFLICTS). FOR CLARIFICATION OF -! INC AND JUMP, SEE THE EXAMPLES BELOW. -! -! N -! THE LENGTH OF EACH TRANSFORM (SEE DEFINITION OF -! TRANSFORMS, BELOW). -! -! M -! THE NUMBER OF TRANSFORMS TO BE DONE SIMULTANEOUSLY. -! -! ISIGN -! = +1 FOR A TRANSFORM FROM FOURIER COEFFICIENTS TO -! GRIDPOINT VALUES. -! = -1 FOR A TRANSFORM FROM GRIDPOINT VALUES TO FOURIER -! COEFFICIENTS. -! -! ON OUTPUT A -! IF ISIGN = +1, AND M COEFFICIENT VECTORS ARE SUPPLIED -! EACH CONTAINING THE SEQUENCE: -! -! A(0),B(0),A(1),B(1),...,A(N/2),B(N/2) (N+2 VALUES) -! -! THEN THE RESULT CONSISTS OF M DATA VECTORS EACH -! CONTAINING THE CORRESPONDING N+2 GRIDPOINT VALUES: -! -! FOR FFT991, X(0), X(1), X(2),...,X(N-1),0,0. -! FOR FFT99, X(N-1),X(0),X(1),X(2),...,X(N-1),X(0). -! (EXPLICIT CYCLIC CONTINUITY) -! -! WHEN ISIGN = +1, THE TRANSFORM IS DEFINED BY: -! X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! AND I=SQRT (-1) -! -! IF ISIGN = -1, AND M DATA VECTORS ARE SUPPLIED EACH -! CONTAINING A SEQUENCE OF GRIDPOINT VALUES X(J) AS -! DEFINED ABOVE, THEN THE RESULT CONSISTS OF M VECTORS -! EACH CONTAINING THE CORRESPONDING FOURIER COFFICIENTS -! A(K), B(K), 0 .LE. K .LE N/2. -! -! WHEN ISIGN = -1, THE INVERSE TRANSFORM IS DEFINED BY: -! C(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*EXP(-2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND I=SQRT(-1) -! -! A CALL WITH ISIGN=+1 FOLLOWED BY A CALL WITH ISIGN=-1 -! (OR VICE VERSA) RETURNS THE ORIGINAL DATA. -! -! NOTE: THE FACT THAT THE GRIDPOINT VALUES X(J) ARE REAL -! IMPLIES THAT B(0)=B(N/2)=0. FOR A CALL WITH ISIGN=+1, -! IT IS NOT ACTUALLY NECESSARY TO SUPPLY THESE ZEROS. -! -! EXAMPLES GIVEN 19 DATA VECTORS EACH OF LENGTH 64 (+2 FOR EXPLICIT -! CYCLIC CONTINUITY), COMPUTE THE CORRESPONDING VECTORS OF -! FOURIER COEFFICIENTS. THE DATA MAY, FOR EXAMPLE, BE -! ARRANGED LIKE THIS: -! -! FIRST DATA A(1)= . . . A(66)= A(70) -! VECTOR X(63) X(0) X(1) X(2) ... X(63) X(0) (4 EMPTY LOCATIONS) -! -! SECOND DATA A(71)= . . . A(140) -! VECTOR X(63) X(0) X(1) X(2) ... X(63) X(0) (4 EMPTY LOCATIONS) -! -! AND SO ON. HERE INC=1, JUMP=70, N=64, M=19, ISIGN=-1, -! AND FFT99 SHOULD BE USED (BECAUSE OF THE EXPLICIT CYCLIC -! CONTINUITY). -! -! ALTERNATIVELY THE DATA MAY BE ARRANGED LIKE THIS: -! -! FIRST SECOND LAST -! DATA DATA DATA -! VECTOR VECTOR VECTOR -! -! A(1)= A(2)= A(19)= -! -! X(63) X(63) . . . X(63) -! A(20)= X(0) X(0) . . . X(0) -! A(39)= X(1) X(1) . . . X(1) -! . . . -! . . . -! . . . -! -! IN WHICH CASE WE HAVE INC=19, JUMP=1, AND THE REMAINING -! PARAMETERS ARE THE SAME AS BEFORE. IN EITHER CASE, EACH -! COEFFICIENT VECTOR OVERWRITES THE CORRESPONDING INPUT -! DATA VECTOR. -! -!----------------------------------------------------------------------- -! -! $Id$ -! $Author$ -! - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - INTEGER :: IFAX(13),INC,JUMP,N,LOT,ISIGN - REAL(R8) :: A(LOT*(N+2)),WORK(LOT*(N+1)), TRIGS(3*N/2+1) - -! -! SUBROUTINE "FFT99" - MULTIPLE FAST REAL PERIODIC TRANSFORM -! CORRESPONDING TO OLD SCALAR ROUTINE FFT9 -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(N-1),X(0),X(1),X(2),...,X(N),X(0) -! I.E. EXPLICIT CYCLIC CONTINUITY; (N+2) LOCATIONS REQUIRED -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! -! -! - INTEGER :: NFAX, NX, NH, INK, IGO, IBASE, JBASE, I, J, K, L, M, & - IA, JA, LA, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=INC+1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE - - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=INC+1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, & - INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, & - 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=IA - DO 100 L=1,LOT - I=IBASE - J=JBASE - - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN CYCLIC BOUNDARY POINTS - 110 CONTINUE - IA=1 - IB=N*INC+1 - - DO 120 L=1,LOT - A(IA)=A(IB) - A(IB+INC)=A(IA+INC) - IA=IA+JUMP - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - REAL(R8) :: A(*),WORK(*),TRIGS(*) - INTEGER :: INC,JUMP,N,LOT - -! -! SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 -! (SPECTRAL TO GRIDPOINT TRANSFORM) -! - REAL(R8) :: C, S - INTEGER :: NH, NX, INK, IA, IB, JA, JB, IABASE, JABASE, K, L, & - IBBASE, JBBASE - - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - IA=1 - IB=N*INC+1 - JA=1 - JB=2 - - DO 10 L=1,LOT - WORK(JA)=A(IA)+A(IB) - WORK(JB)=A(IA)-A(IB) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 10 CONTINUE -! -! REMAINING WAVENUMBERS - IABASE=2*INC+1 - IBBASE=(N-2)*INC+1 - JABASE=3 - JBBASE=N-1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) - - DO 20 L=1,LOT - WORK(JA)=(A(IA)+A(IB))-(S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JB)=(A(IA)+A(IB))+(S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+(A(IA+INC)-A(IB+INC)) - WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))-(A(IA+INC)-A(IB+INC)) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 20 CONTINUE - IABASE=IABASE+INK - IBBASE=IBBASE-INK - JABASE=JABASE+2 - JBBASE=JBBASE-2 - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - - DO 40 L=1,LOT - WORK(JA)=2.0*A(IA) - WORK(JA+1)=-2.0*A(IA+INC) - IA=IA+JUMP - JA=JA+NX - 40 CONTINUE -! - 50 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - REAL(R8) :: WORK(*),A(*),TRIGS(*) - INTEGER :: INC,JUMP,N,LOT - -! -! SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 -! (GRIDPOINT TO SPECTRAL TRANSFORM) -! - REAL(R8) :: SCALE, C, S - INTEGER :: NH, NX, INK, IA, IB, JA, JB, K, L, & - IABASE, JABASE, IBBASE, JBBASE - - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - SCALE=1.0/FLOAT(N) - IA=1 - IB=2 - JA=1 - JB=N*INC+1 - - DO 10 L=1,LOT - A(JA)=SCALE*(WORK(IA)+WORK(IB)) - A(JB)=SCALE*(WORK(IA)-WORK(IB)) - A(JA+INC)=0.0 - A(JB+INC)=0.0 - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 10 CONTINUE -! -! REMAINING WAVENUMBERS - SCALE=0.5*SCALE - IABASE=3 - IBBASE=N-1 - JABASE=2*INC+1 - JBBASE=(N-2)*INC+1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) - - DO 20 L=1,LOT - A(JA)=SCALE*((WORK(IA)+WORK(IB)) & - +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JB)=SCALE*((WORK(IA)+WORK(IB)) & - -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) & - +(WORK(IB+1)-WORK(IA+1))) - A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) & - -(WORK(IB+1)-WORK(IA+1))) - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 20 CONTINUE - IABASE=IABASE+2 - IBBASE=IBBASE-2 - JABASE=JABASE+INK - JBBASE=JBBASE-INK - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - SCALE=2.0*SCALE - - DO 40 L=1,LOT - A(JA)=SCALE*WORK(IA) - A(JA+INC)=-SCALE*WORK(IA+1) - IA=IA+NX - JA=JA+JUMP - 40 CONTINUE -! - 50 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE FFT991(A,WORK,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - REAL(R8) :: A(*),WORK(*),TRIGS(*) - INTEGER :: IFAX(13), INC, JUMP, N, LOT, ISIGN - -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! - INTEGER :: NFAX, NX, NH, INK, IGO, IBASE, JBASE, I, J, K, L, M, & - IA, LA, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 - -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE - - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE - - IGO=60 - GO TO 40 - -! PREPROCESSING (ISIGN=+1) -! ------------------------ - - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 - -! COMPLEX TRANSFORM -! ----------------- - - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, & - INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, & - 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE - - IF (ISIGN.EQ.-1) GO TO 130 - -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE - - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE - -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 - - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 - -! POSTPROCESSING (ISIGN=-1): -! -------------------------- - - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) - - 140 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE SET99 (TRIGS, IFAX, N) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - REAL(R8) :: TRIGS(*) - INTEGER :: IFAX(13), N - -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - INTEGER :: MODE, I - - DATA MODE /3/ - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) THEN - WRITE(6,*) ' SET99 -- INVALID N' - STOP 'SET99' - ENDIF - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE FAX(IFAX,N,MODE) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - INTEGER :: IFAX(10), N, MODE - - INTEGER :: NN, I, K, L, II, ISTOP, ITEM, INC, NFAX - - NN=N - IF (IABS(MODE).EQ.1) GO TO 10 - IF (IABS(MODE).EQ.8) GO TO 10 - NN=N/2 - IF ((NN+NN).EQ.N) GO TO 10 - IFAX(1)=-99 - RETURN - 10 K=1 -! TEST FOR FACTORS OF 4 - 20 IF (MOD(NN,4).NE.0) GO TO 30 - K=K+1 - IFAX(K)=4 - NN=NN/4 - IF (NN.EQ.1) GO TO 80 - GO TO 20 -! TEST FOR EXTRA FACTOR OF 2 - 30 IF (MOD(NN,2).NE.0) GO TO 40 - K=K+1 - IFAX(K)=2 - NN=NN/2 - IF (NN.EQ.1) GO TO 80 -! TEST FOR FACTORS OF 3 - 40 IF (MOD(NN,3).NE.0) GO TO 50 - K=K+1 - IFAX(K)=3 - NN=NN/3 - IF (NN.EQ.1) GO TO 80 - GO TO 40 -! NOW FIND REMAINING FACTORS - 50 L=5 - INC=2 -! INC ALTERNATELY TAKES ON VALUES 2 AND 4 - 60 IF (MOD(NN,L).NE.0) GO TO 70 - K=K+1 - IFAX(K)=L - NN=NN/L - IF (NN.EQ.1) GO TO 80 - GO TO 60 - 70 L=L+INC - INC=6-INC - GO TO 60 - 80 IFAX(1)=K-1 -! IFAX(1) CONTAINS NUMBER OF FACTORS - NFAX=IFAX(1) -! SORT FACTORS INTO ASCENDING ORDER - IF (NFAX.EQ.1) GO TO 110 - DO 100 II=2,NFAX - ISTOP=NFAX+2-II - DO 90 I=2,ISTOP - IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 - ITEM=IFAX(I) - IFAX(I)=IFAX(I+1) - IFAX(I+1)=ITEM - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE FFTRIG(TRIGS,N,MODE) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - REAL(R8) :: TRIGS(*) - INTEGER :: N, MODE - - REAL(R8) :: PI, DEL, ANGLE - INTEGER :: IMODE, NN, I, L, NH, LA - -!BMP PI=2.0*ASIN(1.0) - PI=3.14159265358979323846_r8 - IMODE=IABS(MODE) - NN=N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 - DEL=(PI+PI)/FLOAT(NN) - L=NN+NN - DO 10 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(I)=COS(ANGLE) - TRIGS(I+1)=SIN(ANGLE) - 10 CONTINUE - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - DEL=0.5*DEL - NH=(NN+1)/2 - L=NH+NH - LA=NN+NN - DO 20 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(LA+I)=COS(ANGLE) - TRIGS(LA+I+1)=SIN(ANGLE) - 20 CONTINUE - IF (IMODE.LE.3) RETURN - DEL=0.5*DEL - LA=LA+NN - IF (MODE.EQ.5) GO TO 40 - DO 30 I=2,NN - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=2.0*SIN(ANGLE) - 30 CONTINUE - RETURN - 40 CONTINUE - DEL=0.5*DEL - DO 50 I=2,N - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=SIN(ANGLE) - 50 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE VPASSM(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC,LA) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - REAL(R8) :: A(*),B(*),C(*),D(*),TRIGS(*) - INTEGER :: INC1,INC2,INC3,INC4,LOT,N,IFAC,LA - -! SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA" -! PERFORMS ONE PASS THROUGH DATA -! AS PART OF MULTIPLE COMPLEX FFT ROUTINE -! A IS FIRST REAL INPUT VECTOR -! B IS FIRST IMAGINARY INPUT VECTOR -! C IS FIRST REAL OUTPUT VECTOR -! D IS FIRST IMAGINARY OUTPUT VECTOR -! TRIGS IS PRECALCULATED TABLE OF SINES " COSINES -! INC1 IS ADDRESSING INCREMENT FOR A AND B -! INC2 IS ADDRESSING INCREMENT FOR C AND D -! INC3 IS ADDRESSING INCREMENT BETWEEN A"S & B"S -! INC4 IS ADDRESSING INCREMENT BETWEEN C"S & D"S -! LOT IS THE NUMBER OF VECTORS -! N IS LENGTH OF VECTORS -! IFAC IS CURRENT FACTOR OF N -! LA IS PRODUCT OF PREVIOUS FACTORS - - - REAL(R8) :: SIN36, COS36, SIN72, COS72, SIN60, & - C1, S1, C2, S2, C3, S3, C4, S4 - - INTEGER :: IINK, JINK, JUMP, IBASE, JBASE, IGO, & - IA, JA, IB, JB, KB, KC, IC, JC, ID, JD, KD, IE, JE, KE, & - I, J, K, L, M, LA1, IJK - - DATA SIN36/0.587785252292473_r8/,COS36/0.809016994374947_r8/, & - SIN72/0.951056516295154_r8/,COS72/0.309016994374947_r8/, & - SIN60/0.866025403784437_r8/ - - M=N/IFAC - IINK=M*INC1 - JINK=LA*INC2 - JUMP=(IFAC-1)*JINK - IBASE=0 - JBASE=0 - IGO=IFAC-1 - IF (IGO.GT.4) RETURN - GO TO (10,50,90,130),IGO - -! CODING FOR FACTOR 2 - - 10 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - DO 20 L=1,LA - I=IBASE - J=JBASE - - DO 15 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=A(IA+I)-A(IB+I) - D(JB+J)=B(IA+I)-B(IB+I) - I=I+INC3 - J=J+INC4 - 15 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 20 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 40 K=LA1,M,LA - KB=K+K-2 - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - DO 30 L=1,LA - I=IBASE - J=JBASE - - DO 25 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) - D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) - I=I+INC3 - J=J+INC4 - 25 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 30 CONTINUE - JBASE=JBASE+JUMP - 40 CONTINUE - RETURN - -! CODING FOR FACTOR 3 - - 50 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - DO 60 L=1,LA - I=IBASE - J=JBASE - - DO 55 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))) - C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))) - D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))) - D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))) - I=I+INC3 - J=J+INC4 - 55 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 60 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 80 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - DO 70 L=1,LA - I=IBASE - J=JBASE - - DO 65 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)= & - C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) & - -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - D(JB+J)= & - S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) & - +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - C(JC+J)= & - C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) & - -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - D(JC+J)= & - S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) & - +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - I=I+INC3 - J=J+INC4 - 65 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 70 CONTINUE - JBASE=JBASE+JUMP - 80 CONTINUE - RETURN - -! CODING FOR FACTOR 4 - - 90 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - DO 100 L=1,LA - I=IBASE - J=JBASE - - DO 95 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) - C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) - C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) - D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) - D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) - I=I+INC3 - J=J+INC4 - 95 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 100 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 120 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - DO 110 L=1,LA - I=IBASE - J=JBASE - - DO 105 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - C(JC+J)= & - C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) & - -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - D(JC+J)= & - S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) & - +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - C(JB+J)= & - C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) & - -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - D(JB+J)= & - S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) & - +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - C(JD+J)= & - C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) & - -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - D(JD+J)= & - S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) & - +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 105 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 110 CONTINUE - JBASE=JBASE+JUMP - 120 CONTINUE - RETURN -! -! CODING FOR FACTOR 5 -! - 130 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - IE=ID+IINK - JE=JD+JINK - DO 140 L=1,LA - I=IBASE - J=JBASE - - DO 135 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 135 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 140 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 160 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - KE=KD+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - C4=TRIGS(KE+1) - S4=TRIGS(KE+2) - DO 150 L=1,LA - I=IBASE - J=JBASE - - DO 145 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)= & - C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) & - -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JB+J)= & - S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) & - +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JE+J)= & - C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) & - -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JE+J)= & - S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) & - +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JC+J)= & - C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) & - -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JC+J)= & - S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) & - +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - C(JD+J)= & - C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) & - -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JD+J)= & - S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) & - +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - I=I+INC3 - J=J+INC4 - 145 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 150 CONTINUE - JBASE=JBASE+JUMP - 160 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dycore.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dycore.F deleted file mode 100644 index e33c5147b..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dycore.F +++ /dev/null @@ -1,2012 +0,0 @@ - subroutine dycore ( IM,JM,LM,SIG,PTOP,KM,DT, - . OMEGA, CP, RGAS, AE, - . ROTATION, TILT, DLAM, DPHI, - . PHS, PKH, - . PIB, UOB, VOB, POB, QOB, - . PIM, UOM, VOM, POM, QOM, - . PII, UOI, VOI, POI, QOI, - . OMG, VOR, PSIGDOT, ASSLN, lattice ) - -C ********************************************************************** -C PURPOSE -C Update Time-Tendencies of Prognostic Fields -C due to Hydrodynamical Processes -C -C INPUT ARGUMENT DESCRIPTION -C -C IM .... Number of Grid Intervals in Zonal Direction -C JM .... Number of Grid Intervals in Meridional Direction -C LM .... Number of Vertical Levels -C SIG ... (LM+1): Sigma at Interfaces. SIG(1)=0; SIG(LM+1)=1 -C PTOP .. Model Top Pressure -C KM .... Number of Scalars, Including H2O, but not Theta. -C DT .... Time-Step fron n-1 to n+1 (Seconds) -C -C OMEGA.. Rotation rate (rad/sec) -C CP..... Specific heat at constant pressure (J/(kg K)) -C RGAS... Gas contant (J/(kg K)) -C AE..... 'Earth' radius (meters) -C -C ROTATION ... Longitude of the Computational Pole (Degrees) -C TILT ....... Latitude of the Computational Pole (Degrees) -C DLAM ....... Longitude Grid Increments -C DPHI ....... Latitude Grid Increments -C -C PHS ... (IM,JM): Surface Geopotential (m * m/sec**2) -C PKH ... (IM,JM,LM+1): (P/P00)**KAPPA -C -C PIB ... (IM,JM): Mass (Psurf-Ptop) mb at Current Time-Level -C UOB ... (IM,JM,LM): Zonal Wind m/s at Current Time-Level -C VOB ... (IM,JM,LM): Meridional Wind m/s at Current Time-Level -C POB ... (IM,JM,LM): Potential Temp. K at Current Time-Level -C QOB ... (IM,JM,LM,KM): Scalar Fields at Current Time-Level -C -C PIM ... (IM,JM): Mass (Psurf-Ptop) at Previous Time-Level -C UOM ... (IM,JM,LM): Zonal Wind at Previous Time-Level -C VOM ... (IM,JM,LM): Meridional Wind at Previous Time-Level -C POM ... (IM,JM,LM): Potential Temperature at Previous Time-Level -C QOM ... (IM,JM,LM,KM): Scalar Fields at Previous Time-Level -C -C OUTPUT ARGUMENT DESCRIPTION-- Tendencies are in per second. -c -C PII ... (IM,JM): Updated Surface Pressure Time-Tendency -C UOI ... (IM,JM,LM): Updated Zonal Wind Time-Tendency -C VOI ... (IM,JM,LM): Updated Meridional Wind Time-Tendency -C POI ... (IM,JM,LM): Updated PI-Weighted Theta Time-Tendency -C QOI ... (IM,JM,LM,KM): Updated PI-Weighted Scalar Time-Tendency -C -C OMG ... (IM,JM,LM): Omega Diagnostic (mb/sec) -C VOR ... (IM,JM,LM): Vorticity Diagnostic (1/sec) -C PSIGDOT (IM,JM,LM): Pi*Sigdot Diagnostic (mb/sec) -C ASSLN.. Asselin Filter Coefficient -C -C NOTES: -C (1) JDIM is no longer used -C Over-indexing vectorization technique no longer used. -C (2) The Vertical Layers are numbered from TOP(1) to BOTTOM(LM). -C (3) All Time-Tendencies are INCREMENTED (bumped). -C The Momentum Time-Tendencies ARE NOT mass-weighted. -C The Potential Temperature and Scalar Time-Tendencies ARE -C mass-weighted (by PI). -C (4) JM is 180 degrees divided by the meridional grid size. -C (5) UXX(I,J) are located half a grid interval EAST of PXX(I,J). -C VXX(I,J) are located half a grid interval SOUTH of PXX(I,J). -C (6) If PTOP>0, the PKH MUST be defined. -C (7) The previous time level fields (PIM,UOM,etc) are used for the -C economical explicit calculation done in conjunction with -C leap-frog steps. If you are not doing leap-frog or do not -C wish to have economical explicit tendencies, pass the current -C time-level fields twice (i.e., in PIB,UOB,etc and again in -C PIM,UOM,etc.). -C -C SPACE REQUIREMENTS: -C (1) Takes IM*JM*19+4*JM+2*IM words from the heap for STATIC storage; -C these are kept throughout the run. -C (2) Takes IM*JM*(LM+25) + 3*LM + 1 words from the heap for DYNAMIC -C storage when PTOP=0; for PTOP!=0, add IM*JM*LM words. -C All of this storage is freed before returning. -C -C ********************************************************************** - - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - REAL(kind=8) ZERO, ONE, TWO, THREE, FOUR, FIVE, SIX - REAL(kind=8) HALF, FOURTH, THIRD - REAL(kind=8) pi - - PARAMETER ( ZERO=0.0) - PARAMETER ( ONE=1.0) - PARAMETER ( TWO=2.0) - PARAMETER (THREE=3.0) - PARAMETER ( FOUR=4.0) - PARAMETER ( FIVE=5.0) - PARAMETER ( SIX =6.0) - PARAMETER ( PI =3.1415926535898) - - PARAMETER (FOURTH=ONE/FOUR ) - PARAMETER ( HALF=ONE/TWO ) - PARAMETER ( THIRD=ONE/THREE) - - INTEGER TMPVRS - PARAMETER (TMPVRS=12) - - REAL(kind=8) ALPHA, ASSLN, thbar - -c ARGUMENTS -c --------- - INTEGER IM - INTEGER JM - INTEGER LM - INTEGER KM - - REAL(kind=8) OMEGA - REAL(kind=8) AE - REAL(kind=8) CP - REAL(kind=8) RGAS - - REAL(kind=8) PTOP - REAL(kind=8) DT - - REAL(kind=8) SIG(LM+1) - - REAL(kind=8) UOB(IM,JM,LM) - REAL(kind=8) VOB(IM,JM,LM) - REAL(kind=8) POB(IM,JM,LM) - REAL(kind=8) QOB(IM,JM,LM,1) - REAL(kind=8) PIB(IM,JM) - - REAL(kind=8) UOM(IM,JM,LM) - REAL(kind=8) VOM(IM,JM,LM) - REAL(kind=8) POM(IM,JM,LM) - REAL(kind=8) QOM(IM,JM,LM,1) - REAL(kind=8) PIM(IM,JM) - - REAL(kind=8) UOI(IM,JM,LM) - REAL(kind=8) VOI(IM,JM,LM) - REAL(kind=8) POI(IM,JM,LM) - REAL(kind=8) QOI(IM,JM,LM,1) - REAL(kind=8) PII(IM,JM) - - REAL(kind=8) TILT, PHI_NP - REAL(kind=8) ROTATION, LAMBDA_NP - REAL(kind=8) DLAM(lattice%imglobal), DPHI(lattice%jmglobal) - - REAL(kind=8) PHS(IM,JM) - REAL(kind=8) PKH(IM,JM,LM+1) - - REAL(kind=8) OMG(IM,JM,LM) - REAL(kind=8) VOR(IM,JM,LM) - REAL(kind=8) psigdot(IM,JM,LM) - -c THESE ARE DYNAMIC (RESET EACH TIME) LOCALS -c ------------------------------------------ - REAL(kind=8) DSG(LM) - -c LOCAL VECTOR TEMPORARIES -c ------------------------ - REAL(kind=8) ALF (0:im+1,0:jm+1) - REAL(kind=8) BET (0:im+1,0:jm+1) - REAL(kind=8) GAM (0:im+1,0:jm+1) - REAL(kind=8) DEL (0:im+1,0:jm+1) - REAL(kind=8) EPS (0:im+1,0:jm+1) - REAL(kind=8) LAM (0:im+1,0:jm+1) - REAL(kind=8) MUU (0:im+1,0:jm+1) - REAL(kind=8) PSD (0:im+1,0:jm+1,1:lm) - - REAL(kind=8) VT1 (0:im+1,0:jm+1) - REAL(kind=8) VT2 (0:im+1,0:jm+1) - REAL(kind=8) VT3 (0:im+1,0:jm+1) - REAL(kind=8) VT4 (0:im+1,0:jm+1) - - REAL(kind=8) USB (0:im+1, 0:jm+1) - REAL(kind=8) VSB (0:im+1, 0:jm+1) - REAL(kind=8) ZOB (0:im+1,-1:jm+2) - -c GHOSTED LOCALS -c -------------- - real(kind=8) pgx(0:im+1,jm) - real(kind=8) gx(0:im+1,jm) - real(kind=8) pgy(im,0:jm+1) - -c VECTOR TEMPORARIES -c ------------------ - REAL(kind=8) PKL (0:im+1,0:jm+1,LM) - REAL(kind=8) PHI (0:im+1,0:jm+1,LM) - REAL(kind=8) theta(0:im+1,0:jm+1,LM) - REAL(kind=8) pkht (0:im+1,0:jm+1,LM+1) - - REAL(kind=8) PBI (IM,JM) - REAL(kind=8) PBJ (IM,JM) - REAL(kind=8) BIP (IM,JM) - REAL(kind=8) BJP (IM,JM) - REAL(kind=8) ACH (IM,JM) - REAL(kind=8) DDX (IM,JM) - REAL(kind=8) DDY (IM,JM) - REAL(kind=8) DPX (IM,JM) - REAL(kind=8) DPY (IM,JM) - REAL(kind=8) PIV (IM,JM) - -c SCALAR TEMPORARIES -c ------------------ - REAL(kind=8) PSUMS - REAL(kind=8) PSUMN - - REAL(kind=8) SUMSO - REAL(kind=8) SUMNO - - REAL(kind=8) ST1 - REAL(kind=8) ST2 - - LOGICAL LEAP - -c STATIC LOCALS -c ------------- - real(kind=8), allocatable, save :: DXUIJ(:,:) - real(kind=8), allocatable, save :: DYUIJ(:,:) - real(kind=8), allocatable, save :: DXVIJ(:,:) - real(kind=8), allocatable, save :: DYVIJ(:,:) - real(kind=8), allocatable, save :: D2PIJ(:,:) - real(kind=8), allocatable, save :: D2UIJ(:,:) - real(kind=8), allocatable, save :: D2VIJ(:,:) - real(kind=8), allocatable, save :: D2ZIJ(:,:) - real(kind=8), allocatable, save :: DYVIN(:,:) - real(kind=8), allocatable, save :: DXUIN(:,:) - real(kind=8), allocatable, save :: D2PIN(:,:) - real(kind=8), allocatable, save :: D2ZIN(:,:) - real(kind=8), allocatable, save :: FFFIJ(:,:) - -c Uniform-Grid Standard Filter Arrays -c ----------------------------------- - real(kind=8), allocatable, save :: su (:,:) - real(kind=8), allocatable, save :: sv (:,:) - -c Stretched-Grid Convolution Filter Arrays -c ---------------------------------------- -c real, allocatable, save :: wp(:,:,:) ! Convolution Weights for P-Point -c real, allocatable, save :: wu(:,:,:) ! Convolution Weights for U-Point -c real, allocatable, save :: wv(:,:,:) ! Convolution Weights for V-Point - -c logical stretched -c save stretched - - -C THESE DETERMINE THE REINITIALIZATION OF THE HORIZONTAL GRID -c ------------------------------------------------------------ - INTEGER IM0, JM0 - DATA IM0/0/, JM0/0/ - REAL(kind=8) AE0 - DATA AE0/0./ - - INTEGER I,j, L, K, LL - integer p1,p2,p3,jmm1,jmm2,jmm3 - - -c Initialization -c -------------- - theta(1:im,1:jm,1:lm) = pob(1:im,1:jm,1:lm) - pkht (1:im,1:jm,1:lm+1) = pkh(1:im,1:jm,1:lm+1) - - do L=1,lm - call ghostx ( theta(1:im ,1:jm,L) ,theta(0:im+1,1:jm ,L) ,im ,jm,1, 1,lattice,'east' ) - call ghosty ( theta(0:im+1,1:jm,L) ,theta(0:im+1,0:jm+1,L) ,im+2,jm,1,0,1,1,lattice,'north' ) - call ghostx ( pkht(1:im ,1:jm,L) , pkht(0:im+1,1:jm ,L) ,im ,jm,1, 1,lattice,'east' ) - call ghosty ( pkht(0:im+1,1:jm,L) , pkht(0:im+1,0:jm+1,L) ,im+2,jm,1,0,1,1,lattice,'north' ) - enddo - call ghostx ( pkht(1:im ,1:jm,lm+1), pkht(0:im+1,1:jm ,lm+1),im ,jm,1, 1,lattice,'east' ) - call ghosty ( pkht(0:im+1,1:jm,lm+1), pkht(0:im+1,0:jm+1,lm+1),im+2,jm,1,0,1,1,lattice,'north' ) - - omg(:,:,:) = 0.0 - psigdot(:,:,:) = 0.0 - -c Set J-Index Range -c ----------------- - if ( lattice%pej.eq.0 ) then - p1 = 1 - p2 = 2 - p3 = 3 - else - p1 = 1 - p2 = 1 - p3 = 1 - endif - if ( lattice%pej.eq.lattice%ny-1 ) then - jmm1 = jm-1 - jmm2 = jm-2 - jmm3 = jm-3 - else - jmm1 = jm - jmm2 = jm - jmm3 = jm - endif - -c Compute Optimum Brown-Campana Coefficent -c ---------------------------------------- - ALPHA = 0.965*( (ASSLN**2+4.0)*(ASSLN+2.0)/32.0 ) - - IF( IM.NE.IM0 .OR. JM.NE.JM0 .OR. AE.NE.AE0 ) THEN - - IF(IM0.NE.0) THEN - deallocate (DXUIJ) - deallocate (DYUIJ) - deallocate (DXVIJ) - deallocate (DYVIJ) - deallocate (D2PIJ) - deallocate (D2UIJ) - deallocate (D2VIJ) - deallocate (D2ZIJ) - deallocate (DYVIN) - deallocate (DXUIN) - deallocate (D2PIN) - deallocate (D2ZIN) - deallocate (FFFIJ) - deallocate (SU ) - deallocate (SV ) -c deallocate (wp) -c deallocate (wu) -c deallocate (wv) - ENDIF - - allocate ( DXUIJ(IM,JM) ) - allocate ( DYUIJ(IM,JM) ) - allocate ( DXVIJ(IM,JM) ) - allocate ( DYVIJ(IM,JM) ) - allocate ( D2PIJ(IM,JM) ) - allocate ( D2UIJ(IM,JM) ) - allocate ( D2VIJ(IM,JM) ) - allocate ( D2ZIJ(IM,JM) ) - allocate ( DYVIN(IM,JM) ) - allocate ( DXUIN(IM,JM) ) - allocate ( D2PIN(IM,JM) ) - allocate ( D2ZIN(IM,JM) ) - allocate ( FFFIJ(IM,JM) ) - allocate ( SU(lattice%imglobal+2 ,jm) ) - allocate ( SV(lattice%imglobal+2 ,jm) ) -c allocate ( wp(lattice%imglobal,lattice%imglobal,jm) ) -c allocate ( wu(lattice%imglobal,lattice%imglobal,jm) ) -c allocate ( wv(lattice%imglobal,lattice%imglobal,jm) ) - -C ********************************************************************* -C ***** Compute Grid Metric Factors **** -C ********************************************************************* - - phi_np = tilt*pi/180. - lambda_np = rotation*pi/180. - - CALL GRIDH( IM,JM, AE, OMEGA - *, SIN(PHI_NP), LAMBDA_NP, DLAM, DPHI - *, DXUIJ, DYUIJ, DXVIJ, DYVIJ - *, D2PIJ, D2UIJ, D2VIJ, D2ZIJ - *, DYVIN, DXUIN, D2PIN, D2ZIN, FFFIJ, SU, SV - *, lattice ) -c *, stretched, wp,wu,wv, lattice ) - - IM0 = IM - JM0 = JM - AE0 = AE - ENDIF - - CALL GRIDV ( LM,SIG,DSG ) - -C ********************************************************************* -C ***** L-Independent Quantities **** -C ********************************************************************* - - LEAP = DT .GT. ZERO - - call ghostx ( pib,pgx,im,jm,1,1,lattice,'east' ) - -c Mass-Points -c ----------- - DO j = p2,jmm1 - DO I = 1,IM - PBI(I,j) = (PIB(I,j) + pgx(i+1,j)) * HALF - BIP(I,j) = ONE / PBI(I,j) - PIV(I,j) = ONE / PIB(I,j) - VT2(I,j) = D2PIJ(I,j) * PIB(I,j) - ENDDO - ENDDO - - call ghostx ( vt2(1:im,1:jm),vt2(0:im+1,1:jm),im,jm,1,1,lattice,'east' ) - - DO j = p2,jmm1 - DO I = 1,IM - VT1(I,j) = (VT2(I,j) + VT2(i+1,j)) * HALF ! Mass-Point - ENDDO - ENDDO - - call ghosty ( vt1(1:im,1:jm),vt1(1:im,0:jm+1),im,jm,1,0,1,1,lattice,'north' ) - call ghosty ( pib,pgy, im,jm,1,0,1,1,lattice,'north' ) - -c Vort-Points -c ----------- - DO j = p2,jmm2 - DO I = 1,IM - PBJ(I,j) = (pgy(I,j+1) + PIB(I,j)) * HALF - BJP(I,j) = ONE / PBJ(I,j ) - ACH(I,j) = D2ZIJ(I,j) / (HALF* ( VT1(I,j+1) + VT1(I,j))) - ENDDO - ENDDO - -c Vort-Point at North Pole -c ------------------------ - if ( lattice%pej.eq.lattice%ny-1 ) then - call par_dot ( pib(1,jm-1),d2pij(1,jm-1),psumn,im,1,lattice ) - psumn = psumn * (HALF/FLOAT(lattice%imglobal)) - DO I =1,IM - ACH(I,JM-1) = D2ZIJ(I,JM-1) * (ONE/PSUMN) - ENDDO - endif - -c Vort-Point at South Pole -c ------------------------ - if ( lattice%pej.eq.0 ) then - call par_dot ( pib(1,2),d2pij(1,2),psums,im,1,lattice ) - psums = psums * (HALF/FLOAT(lattice%imglobal)) - DO I =1,IM - ACH(I,1) = D2ZIJ(I,1) * (ONE/PSUMS) - ENDDO - endif - -C ********************************************************************* -C ***** Begin First L-Loop **** -C ********************************************************************* - - DO 1000 L=1,LM - -c P TO THE KAPPA -c -------------- - DO j = p2,jmm1 - DO I = 1,IM - ST1 = PIB(I,j)*SIG(L )+PTOP - ST2 = PIB(I,j)*SIG(L+1)+PTOP - PKL(I,j,L) = (ST2*PKH(I,j,L+1)-ST1*PKH(I,j,L)) / ( (ST2-ST1)*((RGAS/CP)+ONE) ) - ENDDO - ENDDO - -c MASS FLUXES -c ----------- - DO j = p2,jmm1 - DO I = 1,IM - USB(I,j) = DYUIJ(I,j) * PBI(I,j) * UOB(I,j,L) ! UWND-Point - ENDDO - ENDDO - DO j = p2,jmm2 - DO I = 1,IM - VSB(I,j) = DXVIJ(I,j) * PBJ(I,j) * VOB(I,j,L) ! VWND-Point - ENDDO - ENDDO - - -c V-Mass Flux at North Pole -c ------------------------- - if ( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - VSB(I,JM-1) = ZERO - ENDDO - endif - -c V-Mass Flux at South Pole -c ------------------------- - if ( lattice%pej.eq.0 ) then - DO I = 1,IM - VSB(I,1) = ZERO - ENDDO - endif - - call ghostx ( usb(1:im, 1:jm),usb(0:im+1,1:jm ),im, jm,1, 1,lattice,'both' ) - call ghosty ( usb(0:im+1,1:jm),usb(0:im+1,0:jm+1),im+2,jm,1,0,-1,1,lattice,'both' ) - - call ghostx ( vsb(1:im, 1:jm),vsb(0:im+1,1:jm ),im, jm,1, 1,lattice,'both' ) - call ghosty ( vsb(0:im+1,1:jm),vsb(0:im+1,0:jm+1),im+2,jm,1,1,-1,1,lattice,'both' ) - -c HORIZONTAL ADVECTION OF TRACERS -c ------------------------------- - IF(KM.GT.0) THEN - DO K = 1,KM - CALL HADVECT( USB(0:im+1,0:jm+1),VSB(0:im+1,0:jm+1),QOB(1,1,L,K),IM,JM, - . VT3(0:im+1,0:jm+1),VT1(0:im+1,0:jm+1),VT2(0:im+1,0:jm+1),lattice ) - DO j = p2,jmm1 - DO I = 1,IM - QOI(I,j,L,K) = QOI(I,j,L,K) - VT3(I,j)*D2PIN(I,j) - ENDDO - ENDDO - ENDDO - ENDIF - -c HORIZONTAL ADVECTION OF POTENTIAL TEMPERATURE -c --------------------------------------------- - CALL HADVECT( USB(0:im+1,0:jm+1),VSB(0:im+1,0:jm+1),POB(1,1,L),IM,JM, - . VT3(0:im+1,0:jm+1),VT1(0:im+1,0:jm+1),VT2(0:im+1,0:jm+1),lattice ) - DO j = p2,jmm1 - DO I = 1,IM - POI(I,j,L) = POI(I,j,L) - VT3(I,j)*D2PIN(I,j) - ENDDO - ENDDO - -c COMPUTE CONVERGENCE -c ------------------- - DO j = p2,jmm1 - DO I = 1,IM - PSD(I,j,L) = ( (USB(i-1,j)-USB(I,j)) - * + (VSB(I,j-1)-VSB(I,j)) ) * (D2PIN(I,j)*DSG(L)) - ENDDO - ENDDO - -c COMPUTE VORTICITY -c ----------------- - DO j = p2,jmm1 - DO I = 1,IM - VT2(I,j) = DXUIJ(I,j) * UOB(I,j,L) ! UWND-Point - ENDDO - ENDDO - - call ghostx ( vob(1,1,L), gx, im,jm,1, 1,lattice,'east' ) - call ghosty ( vt2(1:im,1:jm),vt2(1:im,0:jm+1),im,jm,1,0,-1,1,lattice,'north' ) - DO j = p2,jmm2 - DO I = 1,IM - ZOB(I,j) = ( (gx(i+1,j) - VOB(I,j,L)) * DYVIJ(I,j) - * + ( VT2(I,j) - VT2(I,j+1)) ) * D2ZIN(I,j) ! Vort-Point - ENDDO - ENDDO - -c Vort-Point at North Pole -c ------------------------ - if ( lattice%pej.eq.lattice%ny-1 ) then - call par_dot ( uob(1,jm-1,L),dxuij(1,jm-1),sumno,im,1,lattice ) - sumno = sumno * ( ONE/FLOAT(lattice%imglobal)) - DO I =1,IM - ZOB(I,JM-1) = SUMNO * D2ZIN(1,JM-1) ! Vort-Point at Pole - ENDDO - endif - -c Vort-Point at South Pole -c ------------------------ - if ( lattice%pej.eq.0 ) then - call par_dot ( uob(1,2,L),dxuij(1,2),sumso,im,1,lattice ) - sumso = sumso * (-ONE/FLOAT(lattice%imglobal)) - DO I =1,IM - ZOB(I,1) = SUMSO * D2ZIN(1,1) ! Vort-Point at Pole - ENDDO - endif - - DO j = p1,jmm1 - DO I = 1,IM - VOR(I,j,L) = ZOB(I,j) - ENDDO - ENDDO - - DO j = p1,jmm1 - DO I = 1,IM - ZOB(I,j) = (ZOB(I,j)+FFFIJ(I,j)) * ACH(I,j) ! Vort-Point - ENDDO - ENDDO - - call ghostx ( zob(1:im, 1:jm),zob(0:im+1, 1:jm ),im, jm,1, 1,lattice,'both' ) - call ghosty ( zob(0:im+1,1:jm),zob(0:im+1,-1:jm+2),im+2,jm,1,1,1,2,lattice,'both' ) - -c COMPUTE VORTICITY COEFFICIENTS -c ------------------------------ - DO j = p2,jmm1 - DO I = 1,IM - EPS(I,j) = ( ZOB(i ,j-1) + ZOB(i ,j ) ) - LAM(I,j) = ( ZOB(i-1,j-1) + ZOB(i+1,j ) ) - MUU(I,j) = ( ZOB(i-1,j ) + ZOB(i+1,j-1) ) - ENDDO - ENDDO - - DO j = p2,jmm2 - DO I = 1,IM - ALF(I,j) = ( EPS(I,j) + ZOB(i+1,j ) ) - BET(I,j) = ( EPS(I,j) + ZOB(i-1,j ) ) - ALF(I,j) = (THREE*HALF)*ALF(I,j) - HALF*( MUU(I,j)+ZOB(I,j+1) ) - BET(I,j) = (THREE*HALF)*BET(I,j) - HALF*( LAM(I,j)+ZOB(I,j+1) ) - ENDDO - ENDDO - DO j = p3,jmm1 - DO I = 1,IM - GAM(I,j) = ( EPS(I,j) + ZOB(i-1,j-1) ) - DEL(I,j) = ( EPS(I,j) + ZOB(i+1,j-1) ) - GAM(I,j) = (THREE*HALF)*GAM(I,j) - HALF*( MUU(I,j)+ZOB(I,j-2) ) - DEL(I,j) = (THREE*HALF)*DEL(I,j) - HALF*( LAM(I,j)+ZOB(I,j-2) ) - ENDDO - ENDDO - - - DO j = p2,jmm2 - DO I = 1,IM - MUU(I,j) = HALF*(ZOB(I,j-1) - ZOB(I,j+1)) ! Vort-Point - ENDDO - ENDDO - DO j = p3,jmm3 - DO I = 1,IM - LAM(I,j) = HALF*(ZOB(i+1,j) - ZOB(i-1,j)) ! Vort-Point - ENDDO - ENDDO - - -c Lambda Averaging near North Pole -c -------------------------------- - if ( lattice%pej.eq.lattice%ny-1 ) then - DO I =1,IM - LAM(I,JM-2) = (THREE/FIVE)*LAM(I,JM-3) - ENDDO - endif - -c Lambda Averaging near South Pole -c -------------------------------- - if ( lattice%pej.eq.0 ) then - DO I =1,IM - LAM(I,2) = (THREE/FIVE)*LAM(I,3) - ENDDO - endif - -c Ghost ALF,BET,GAM,DEL,LAM,MUU -c ----------------------------- - call ghostx ( alf(1:im,1:jm),alf(0:im+1,1:jm),im,jm,1,1,lattice,'west' ) - call ghostx ( del(1:im,1:jm),del(0:im+1,1:jm),im,jm,1,1,lattice,'west' ) - call ghostx ( muu(1:im,1:jm),muu(0:im+1,1:jm),im,jm,1,1,lattice,'west' ) - - call ghosty ( gam(1:im ,1:jm),gam(1:im ,0:jm+1),im ,jm,1,0,1,1,lattice,'north' ) - call ghosty ( del(0:im+1,1:jm),del(0:im+1,0:jm+1),im+2,jm,1,0,1,1,lattice,'north' ) - call ghosty ( lam(1:im ,1:jm),lam(1:im ,0:jm+1),im ,jm,1,1,1,1,lattice,'south' ) - -c U INCREMENT -c ----------- - DO j = p2,jmm2 - DO I = 1,IM - EPS(I,j) = BET(I,j) * VSB(i ,j ) - * + ALF(I,j) * VSB(i+1,j ) - * - LAM(I,j) * USB(i ,j+1) - ENDDO - ENDDO - -c Zero EPS near North Pole -c ------------------------ - if ( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - EPS(I,JM-1) = ZERO - ENDDO - endif - - DO j = p3,jmm1 - DO I = 1,IM - EPS(I,j) = EPS(I,j ) - * + GAM(I,j ) * VSB(i ,j-1) - * + DEL(I,j ) * VSB(i+1,j-1) - * + LAM(I,j-1) * USB(i ,j-1) - ENDDO - ENDDO - - DO j = p2,jmm1 - DO I = 1,IM - UOI(I,j,L) = UOI(I,j,L) + (THIRD*FOURTH)*EPS(I,j)*DXUIN(I,j) - ENDDO - ENDDO - -c V INCREMENT -c ----------- - DO j = p2,jmm2 - DO I = 1,IM - ST1 = BET(I ,j ) * USB(i ,j ) - * + GAM(I ,j+1) * USB(i ,j+1) - * + DEL(i-1,j+1) * USB(i-1,j+1) - * + ALF(i-1,j ) * USB(i-1,j ) - * + MUU(I ,j ) * VSB(i+1,j ) - * - MUU(i-1,j ) * VSB(i-1,j ) - VOI(I,j,L) = VOI(I,j,L) - (THIRD*FOURTH)*ST1*DYVIN(I,j) - ENDDO - ENDDO - -1000 CONTINUE - -C ********************************************************************* -C ***** Begin L-Critical Section **** -C ********************************************************************* - -c VERTICAL INTERGRAL OF CONTINUITY EQUATION -c ----------------------------------------- - DO L = 2,LM - DO j = p2,jmm1 - DO I = 1,IM - PSD(I,j,L) = PSD(I,j,L-1) + PSD(I,j,L) - ENDDO - ENDDO - ENDDO - -c SURFACE PRESSURE TENDENCY -c ------------------------- - DO j = p2,jmm1 - DO I = 1,IM - PII(I,j) = PII(I,j) + PSD(I,j,LM) - ENDDO - ENDDO - -c DDX AND DDY ARE USED IN OMEGA CALCULATION -c ----------------------------------------- - DO j = p2,jmm1 - DO I = 1,IM - DDX(I,j) = (pgx(i+1,j)-PIB(I,j))*DYUIJ(I,j)*PBI(I,j) - ENDDO - ENDDO - - DO j = p2,jmm2 - DO I = 1,IM - DDY(I,j) = (pgy(I,j+1)-PIB(I,j))*DXVIJ(I,j)*PBJ(I,j) - ENDDO - ENDDO - -C ********************************************************************* -C ***** Begin Second L-Loop **** -C ********************************************************************* - - DO 2000 LL = 1,2 - DO 2000 L = LL,LM-1,2 - -C VERTICAL ADVECTION -C ------------------ - DO j = p2,jmm1 - DO I = 1,IM - PSD(I,j,L) = PSD(I,j,L) - PSD(I,j,LM)*SIG(L+1) - psigdot(i,j,L) = psd(i,j,L) ! PSIGDOT Diagnostic - ENDDO - ENDDO - - call ghostx ( psd(1:im, 1:jm,L),psd(0:im+1,1:jm ,L),im, jm,1, 1,lattice,'east' ) - call ghosty ( psd(0:im+1,1:jm,L),psd(0:im+1,0:jm+1,L),im+2,jm,1,0,1,1,lattice,'both' ) - - DO j = p2,jmm1 - DO I = 1,IM - ALF(I,j) = (PKH(I,j,L+1)-PKL(I,j,L)) / (PKL(I,j,L+1)-PKL(I,j,L)) - ENDDO - ENDDO - - DO j = p2,jmm1 - DO I = 1,IM - ST1 = ( (POB(I,j,L)-POB(I,j,L+1))*ALF(I,j) + POB(I,j,L+1) )*PSD(I,j,L) - POI(I,j,L ) = POI(I,j,L ) - ST1 * (ONE/DSG(L )) - POI(I,j,L+1) = POI(I,j,L+1) + ST1 * (ONE/DSG(L+1)) - ENDDO - ENDDO - - IF(KM.GT.0) THEN - DO K =1,KM - DO j = p2,jmm1 - DO I = 1,IM - ST1 = ( (QOB(I,j,L,K)+QOB(I,j,L+1,K))*HALF )*PSD(I,j,L) - QOI(I,j,L ,K) = QOI(I,j,L ,K) - ST1 * (ONE/DSG(L )) - QOI(I,j,L+1,K) = QOI(I,j,L+1,K) + ST1 * (ONE/DSG(L+1)) - ENDDO - ENDDO - ENDDO - ENDIF - - DO j = p2,jmm1 - DO I = 1,IM - ST1 = ( UOB(I,j,L+1)-UOB(I,j,L) )*( PSD(i+1,j,L)+PSD(I,j,L) )*BIP(I,j) - UOI(I,j,L ) = UOI(I,j,L ) - ST1 * (FOURTH/DSG(L )) - UOI(I,j,L+1) = UOI(I,j,L+1) - ST1 * (FOURTH/DSG(L+1)) - ENDDO - ENDDO - - DO j = p2,jmm2 - DO I = 1,IM - ST1 = ( VOB(I,j,L+1)-VOB(I,j,L) )*( PSD(I,j+1,L)+PSD(I,j,L) )*BJP(I,j) - VOI(I,j,L ) = VOI(I,j,L ) - ST1 * (FOURTH/DSG(L )) - VOI(I,j,L+1) = VOI(I,j,L+1) - ST1 * (FOURTH/DSG(L+1)) - ENDDO - ENDDO - -c Omega Diagnostic -c ---------------- - DO j = p2,jmm1 - DO I = 1,IM - VT1(I,j) = UOB(I,j,L )*DDX(I,j) ! UWND-Point - VT3(I,j) = UOB(I,j,L+1)*DDX(I,j) ! UWND-Point - ENDDO - ENDDO - - DO j = p2,jmm2 - DO I = 1,IM - VT2(I,j) = VOB(I,j,L )*DDY(I,j) ! VWND-Point - VT4(I,j) = VOB(I,j,L+1)*DDY(I,j) ! VWND-Point - ENDDO - ENDDO - -c Zero VT2 and VT4 at North Pole -c ------------------------------ - if ( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - VT2(I,JM-1) = ZERO - VT4(I,JM-1) = ZERO - ENDDO - endif - -c Zero VT2 and VT4 at South Pole -c ------------------------------ - if ( lattice%pej.eq.0 ) then - DO I = 1,IM - VT2(I,1) = ZERO - VT4(I,1) = ZERO - ENDDO - endif - - call ghostx ( vt1(1:im,1:jm),vt1(0:im+1,1:jm),im,jm,1, 1,lattice,'west' ) - call ghostx ( vt3(1:im,1:jm),vt3(0:im+1,1:jm),im,jm,1, 1,lattice,'west' ) - call ghosty ( vt2(1:im,1:jm),vt2(1:im,0:jm+1),im,jm,1,1,-1,1,lattice,'south' ) - call ghosty ( vt4(1:im,1:jm),vt4(1:im,0:jm+1),im,jm,1,1,-1,1,lattice,'south' ) - - DO j = p2,jmm1 - DO I = 1,IM - ALF(I,j) = (PKH(I,j,L+1)-PKL(I,j,L )) / (PKH(I,j,L+1)-PKH(I,j,L )) - BET(I,j) = (PKL(I,j,L+1)-PKH(I,j,L+1)) / (PKH(I,j,L+2)-PKH(I,j,L+1)) - ENDDO - ENDDO - - DO j = p2,jmm1 - DO I = 1,IM - ST1 = SIG(L+1)*PSD(I,j,LM) + PSD(I,j,L) - ST2 = HALF*(VT1(i-1,j)+VT1(I,j)+VT2(I,j)+VT2(I,j-1)) * SIG(L+1)*D2PIN(I,j)*PIV(I,j) - OMG(I,j,L) = OMG(I,j,L ) + ALF(I,j) * (ST1 + ST2) - ST2 = HALF*(VT3(i-1,j)+VT3(I,j)+VT4(I,j)+VT4(I,j-1)) * SIG(L+1)*D2PIN(I,j)*PIV(I,j) - OMG(I,j,L+1) = OMG(I,j,L+1) + BET(I,j) * (ST1 + ST2) - ENDDO - ENDDO - - IF(L.EQ.LM-1) THEN - DO j = p2,jmm1 - DO I = 1,IM - BET(I,j) = (PKH(I,j,L+2)-PKL(I,j,L+1)) / (PKH(I,j,L+2)-PKH(I,j,L+1)) - ENDDO - ENDDO - DO j = p2,jmm1 - DO I = 1,IM - ST1 = PSD(I,j,LM) - ST2 = HALF*(VT3(i-1,j)+VT3(I,j)+VT4(I,j)+VT4(I,j-1)) * D2PIN(I,j)*PIV(I,j) - OMG(I,j,L+1) = OMG(I,j,L+1) + BET(I,j) * (ST1 + ST2) - ENDDO - ENDDO - ENDIF - -2000 CONTINUE - -C ********************************************************************* -C ***** Begin L-Critical Section **** -C ********************************************************************* - -C Filtering of Scalars on Stretched-Grid -c -------------------------------------- -c if( stretched ) then -c call avrxg ( poi,wp,im,jm,lm,lattice ) ! Potential Temperature Tendency -c call avrxg ( pii,wp,im,jm,1 ,lattice ) ! Surface Pressure Tendency -c do k=1,km -c call avrxg ( qoi(1,1,1,k),wp,im,jm,lm,lattice ) ! Tracer Tendencies -c enddo -c call avrxg ( omg ,wp,im,jm,lm,lattice ) ! Vertical Velocity (Pressure) -c call avrxg ( psigdot,wp,im,jm,lm,lattice ) ! Vertical Velocity (Sigma) -c else -C Filtering of Scalars on Uniform-Grid -c ------------------------------------ - call avrx ( poi,im,jm,lm,su,lattice ) - call avrx ( pii,im,jm,1 ,su,lattice ) - do k = 1,km - call avrx ( qoi(1,1,1,K),im,jm,lm,su,lattice ) - enddo - call avrx ( omg ,im,jm,lm,su,lattice ) - call avrx ( psigdot,im,jm,lm,su,lattice ) -c endif - -c AT THIS POINT THETA, Q, AND PS INCREMENTS ARE COMPLETE -c AND CAN BE USED FOR COMPUTING THE PRESSURE GRADIENT -c IN THE ECONOMICAL EXPLICIT SCHEME -c --------------------------------- - IF(LEAP) THEN - DO j = p2,jmm1 - DO I = 1,IM - ST1 = PIM(I,j) + DT*PII(I,j) - VT3(I,j) = ONE / ST1 - VT1(I,j) = ALPHA*(PIM(I,j)+ST1) + (ONE-TWO*ALPHA)*PIB(I,j) - ENDDO - ENDDO - ELSE - DO j = p2,jmm1 - DO I = 1,IM - VT1(I,j) = PIB(I,j) - ENDDO - ENDDO - ENDIF - - call ghostx ( vt1(1:im, 1:jm),vt1(0:im+1,1:jm ),im, jm,1, 1,lattice,'east' ) - call ghosty ( vt1(0:im+1,1:jm),vt1(0:im+1,0:jm+1),im+2,jm,1,0,1,1,lattice,'north' ) - -c GRADIENT OF SURFACE PRESSURE -c ---------------------------- - DO j = p2,jmm1 - DO I = 1,IM - DPX(I,j) = (VT1(i+1,j) - VT1(I,j)) - ENDDO - ENDDO - - DO j = p2,jmm2 - DO I = 1,IM - DPY(I,j) = (VT1(I,j+1) - VT1(I,j)) - ENDDO - ENDDO - -c HYDROSTATIC EQUATION -c -------------------- - DO j = p2,jmm1 - DO I = 1,IM - PHI(I,j,LM) = PHS(I,j) - ENDDO - ENDDO - - DO L = LM,2,-1 - IF(LEAP) THEN - DO j = p2,jmm1 - DO I = 1,IM - VT1(I,j) = ( POM(I,j,L)*PIM(I,j) + DT*POI(I,j,L) )*VT3(I,j) - VT1(I,j) = ALPHA*(POM(I,j,L) + VT1(I,j)) + (ONE-TWO*ALPHA)*POB(I,j,L) - ENDDO - ENDDO - ELSE - DO j = p2,jmm1 - DO I = 1,IM - VT1(I,j) = POB(I,j,L) - ENDDO - ENDDO - ENDIF - DO j = p2,jmm1 - DO I = 1,IM - ST1 = VT1(I,j) - PHI(I,j,L-1) = PHI(I,j,L) + ST1*(CP*(PKH(I,j,L+1)-PKH(I,j,L))) - PHI(I,j,L ) = PHI(I,j,L) + ST1*(CP*(PKH(I,j,L+1)-PKL(I,j,L))) - ENDDO - ENDDO - ENDDO - - IF(LEAP) THEN - DO j = p2,jmm1 - DO I = 1,IM - VT1(I,j) = ( POM(I,j,1)*PIM(I,j) + DT*POI(I,j,1) )*VT3(I,j) - VT1(I,j) = ALPHA*(POM(I,j,1) + VT1(I,j)) + (ONE-TWO*ALPHA)*POB(I,j,1) - ENDDO - ENDDO - ELSE - DO j = p2,jmm1 - DO I = 1,IM - VT1(I,j) = POB(I,j,1) - ENDDO - ENDDO - ENDIF - - DO j = p2,jmm1 - DO I = 1,IM - ST1 = VT1(I,j) - PHI(I,j,1) = PHI(I,j,1) + ST1*(CP*(PKH(I,j,2)-PKL(I,j,1))) - ENDDO - ENDDO - -C ********************************************************************* -C ***** Begin Third L-Loop **** -C ********************************************************************* - - DO 3000 L = 1,LM - - call ghostx ( vob(1:im,1:jm,L),vsb(0:im+1,1:jm),im,jm,1, 1,lattice,'both' ) - call ghosty ( uob(1:im,1:jm,L),usb(1:im,0:jm+1),im,jm,1,0,-1,1,lattice,'both' ) - -c KINETIC ENERGY (SADOURNEY SICKPROOF), THERE IS A 1/2 IN DXDY[UV] -c ----------------------------------------------------------------- - ST2 = FIVE/SIX - - DO j = p3,jmm2 - DO I = 1,IM - ST1 = HALF*( USB(i,j-1)+USB(i,j+1) ) - VT1(I,j) = ( (ST2)*UOB(i,j,L)*UOB(i,j,L) + (ONE-ST2)*ST1*ST1 ) *D2UIJ(I,j) - ENDDO - ENDDO - - DO j = p2,jmm2 - DO I = 1,IM - ST1 = HALF*( VSB(i+1,j)+VSB(i-1,j) ) - VT2(I,j) = ( (ST2)*VOB(i,j,L)*VOB(i,j,L) + (ONE-ST2)*ST1*ST1 ) *D2VIJ(I,j) - ENDDO - ENDDO - -c Sickproof at North Pole -c ----------------------- - if ( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - VT1(I,JM-1) = UOB(I,JM-1,L)*UOB(I,JM-1,L)*D2UIJ(I,JM-1) - VT2(I,JM-1) = ZERO - ENDDO - endif - -c Sickproof at South Pole -c ----------------------- - if ( lattice%pej.eq.0 ) then - DO I = 1,IM - VT1(I,2) = UOB(I,2,L)*UOB(I,2,L)*D2UIJ(I,2) - VT2(I,1) = ZERO - ENDDO - endif - - call ghostx ( vt1(1:im,1:jm),vt1(0:im+1,1:jm),im,jm,1, 1,lattice,'west' ) - call ghosty ( vt2(1:im,1:jm),vt2(1:im,0:jm+1),im,jm,1,1,1,1,lattice,'south' ) - - DO j = p2,jmm1 - DO I = 1,IM - PHI(I,j,L) = PHI(I,j,L) - * + HALF*( HALF*(VT1(i-1,j) + VT1(I,j )) - * + HALF*(VT2(I ,j) + VT2(I,j-1)) )*D2PIN(I,j) - ENDDO - ENDDO - - call ghostx ( phi(1:im ,1:jm,L), phi(0:im+1,1:jm ,L),im ,jm,1, 1,lattice,'east' ) - call ghosty ( phi(0:im+1,1:jm,L), phi(0:im+1,0:jm+1,L),im+2,jm,1,0,1,1,lattice,'north' ) - call ghostx ( pkl(1:im ,1:jm,L), pkl(0:im+1,1:jm ,L),im ,jm,1, 1,lattice,'east' ) - call ghosty ( pkl(0:im+1,1:jm,L), pkl(0:im+1,0:jm+1,L),im+2,jm,1,0,1,1,lattice,'north' ) - -c PRESSURE GRADIENT FORCE, INCLUDING GRAD OF KE, GAM IS (CP THETA DP/DPI) -c ------------------------------------------------------------------------ -#if junk -c conservation of irrotationality method -c -------------------------------------- - DO j = p2,jmm1 - DO I = 1,IM - GAM(i,j) = ( SIG(L )*(PKL(i,j,L )-PKH(i,j,L)) - * + SIG(L+1)*(PKH(i,j,L+1)-PKL(i,j,L)) )*(CP/DSG(L))*PIV(i,j)*POB(i,j,L) - ENDDO - ENDDO - call ghostx ( gam(1:im ,1:jm ),gam(0:im+1,1:jm ) ,im ,jm,1, 1,lattice,'east' ) - call ghosty ( gam(0:im+1,1:jm ),gam(0:im+1,0:jm+1) ,im+2,jm,1,0,1,1,lattice,'north' ) - - DO j = p2,jmm1 - DO I = 1,IM - ST1 = ( phi(i+1,j,L)-phi(i,j,L) ) + DPX(i,j) * HALF*( gam(i+1,j)+gam(i,j) ) - UOI(I,j,L) = UOI(I,j,L) - ST1*DXUIN(i,j) - ENDDO - ENDDO - - DO j = p2,jmm2 - DO I = 1,IM - ST1 = ( phi(i,j+1,L)-phi(i,j,L) ) + DPY(i,j) * HALF*( gam(i,j+1)+gam(i,j) ) - VOI(I,j,L) = VOI(I,j,L) - ST1*DYVIN(i,j) - ENDDO - ENDDO -#endif - -c conservation of energy method -c ----------------------------- - do j=p2,jmm1 - do i=1,im - -c finite-volume theta_bar -c ----------------------- -c thbar = ( theta(i+1,j,L)*( pkht(i+1,j,L+1)-pkht(i+1,j,L) ) -c . + theta(i ,j,L)*( pkht(i ,j,L+1)-pkht(i ,j,L) ) ) -c . /( pkht(i+1,j,L+1)-pkht(i+1,j,L) -c . + pkht(i ,j,L+1)-pkht(i ,j,L) ) - -c conservation theta_bar -c ---------------------- - thbar = ( theta(i+1,j,L)+theta(i,j,L) )*0.5 - - ST1 = ( phi(i+1,j,L)-phi(i,j,L) ) + cp*thbar*( pkl(i+1,j,L)-pkl(i,j,L) ) - UOI(I,j,L) = UOI(I,j,L) - ST1*DXUIN(i,j) - enddo - enddo - - do j=p2,jmm2 - do i=1,im - -c finite-volume theta_bar -c ----------------------- -c thbar = ( theta(i,j+1,L)*( pkht(i,j+1,L+1)-pkht(i,j+1,L) ) -c . + theta(i ,j,L)*( pkht(i ,j,L+1)-pkht(i ,j,L) ) ) -c . /( pkht(i,j+1,L+1)-pkht(i,j+1,L) -c . + pkht(i ,j,L+1)-pkht(i ,j,L) ) - -c conservation theta_bar -c ---------------------- - thbar = ( theta(i,j+1,L)+theta(i,j,L) )*0.5 - - ST1 = ( phi(i,j+1,L)-phi(i,j,L) ) + cp*thbar*( pkl(i,j+1,L)-pkl(i,j,L) ) - VOI(I,j,L) = VOI(I,j,L) - ST1*DYVIN(i,j) - enddo - enddo - -3000 CONTINUE - -C************************************************************ -C***************** END THIRD L LOOP ************************* -C************************************************************ - -C Filtering of Momentum Fields on Stretched-Grid -c ---------------------------------------------- -c if( stretched ) then -c call avrxg ( uoi,wu,im,jm,lm,lattice ) ! U-Wind Tendency -c call avrxg ( voi,wv,im,jm,lm,lattice ) ! V-Wind Tendency -c else -C Filtering of Momentum Fields on Uniform-Grid -c -------------------------------------------- - call avrx ( uoi,im,jm,lm,su,lattice ) ! U-Wind Tendency - call avrx ( voi,im,jm,lm,sv,lattice ) ! V-Wind Tendency -c endif - - return - end - - subroutine gridh ( IM,JM, AE, OMEGA - *, SINPNP, LAMNP,DLAM,DPHI - *, DXUIJ, DYUIJ, DXVIJ, DYVIJ - *, D2PIJ, D2UIJ, D2VIJ, D2ZIJ - *, DYVIN, DXUIN, D2PIN, D2ZIN, FFFIJ, SU, SV - *, lattice ) -c *, stretched, wp,wu,wv, lattice ) - - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - REAL(kind=8) ONE - REAL(kind=8) TWO - REAL(kind=8) HALF - REAL(kind=8) FOURTH - REAL(kind=8) ZERO - REAL(kind=8) PI - REAL(kind=8) UNDEF,GETCON - - PARAMETER ( ONE=1.0 ) - PARAMETER ( TWO=2.0 ) - PARAMETER ( ZERO=0.0 ) - PARAMETER ( HALF=0.5 ) - PARAMETER (FOURTH=0.25) - PARAMETER ( PI=3.1415926535898) - - REAL(kind=8) SINPNP - REAL(kind=8) LAMNP - - INTEGER IM, JM - - REAL(kind=8) AE - REAL(kind=8) OMEGA - - - REAL(kind=8) DXUIJ(IM,JM) - REAL(kind=8) DYUIJ(IM,JM) - REAL(kind=8) DYVIJ(IM,JM) - REAL(kind=8) DXVIJ(IM,JM) - - REAL(kind=8) DYVIN(IM,JM) - REAL(kind=8) DXUIN(IM,JM) - REAL(kind=8) D2ZIN(IM,JM) - REAL(kind=8) D2PIN(IM,JM) - - REAL(kind=8) D2PIJ(IM,JM) - REAL(kind=8) D2UIJ(IM,JM) - REAL(kind=8) D2VIJ(IM,JM) - REAL(kind=8) D2ZIJ(IM,JM) - - REAL(kind=8) FFFIJ(IM,JM) - - REAL(kind=8) SU(lattice%imglobal+2,JM) - REAL(kind=8) SV(lattice%imglobal+2,JM) - - REAL(kind=8) DLAM (lattice%imglobal) - REAL(kind=8) DPHI (lattice%jmglobal) - - real(kind=8) gostx (0:im+1,1:jm ) - real(kind=8) gosty (1:im ,0:jm+1) - real(kind=8) gostxy(0:im+1,0:jm+1) - -c Stretched-Grid Variables -c ------------------------ -c real(kind=8) wp(lattice%imglobal,lattice%imglobal,jm) -c real(kind=8) wu(lattice%imglobal,lattice%imglobal,jm) -c real(kind=8) wv(lattice%imglobal,lattice%imglobal,jm) -c logical stretched - - -C LOCALS - - REAL(kind=8) COSPNP, FS, FC, SUM,DOT - - REAL(kind=8) LAMBDA(lattice%imglobal) - REAL(kind=8) PHI (lattice%jmglobal) - - REAL(kind=8) DXPIJ(IM,JM) - REAL(kind=8) DYPIJ(IM,JM) - REAL(kind=8) SL (lattice%imglobal+1) - REAL(kind=8) CL (lattice%imglobal+1) - REAL(kind=8) CC (lattice%jmglobal+1) - REAL(kind=8) SC (lattice%jmglobal+1) - REAL(kind=8) CV (lattice%jmglobal+1) - - INTEGER I,J - REAL(kind=8) SUMIN, SVMIN - integer p1,p2,p3,jmm1,jmm2,jmm3 - - UNDEF = getcon('UNDEF') - COSPNP = SQRT( ONE-SINPNP**2 ) - - -c Set J-Index Range -c ----------------- - if ( lattice%pej.eq.0 ) then - p1 = 1 - p2 = 2 - p3 = 3 - else - p1 = 1 - p2 = 1 - p3 = 1 - endif - if ( lattice%pej.eq.lattice%ny-1 ) then - jmm1 = jm-1 - jmm2 = jm-2 - jmm3 = jm-3 - else - jmm1 = jm - jmm2 = jm - jmm3 = jm - endif - -c Check for Stretched-Grid -c ------------------------ -c stretched = .false. -c i = 2 -c do while( .not.stretched .and. i.le.lattice%imglobal ) -c stretched = dlam(i).ne.dlam(1) -c i = i+1 -c enddo -c j = 2 -c do while( .not.stretched .and. j.le.lattice%jmglobal ) -c stretched = dphi(j).ne.dphi(1) -c j = j+1 -c enddo - -C Global Longitude and Latitude -c ----------------------------- - LAMBDA(1) = -PI - DO I = 2,lattice%imglobal - LAMBDA(I) = LAMBDA(I-1) + DLAM(I-1) - ENDDO - - PHI(1) = -PI*HALF - DO J = 2,lattice%jmglobal-1 - PHI(J) = PHI(J-1) + DPHI(J-1) - ENDDO - PHI(lattice%jmglobal) = PI*HALF - -C HORIZONTAL GRID -c --------------- - DO I = 1,lattice%imglobal - SL(I) = SIN( LAMBDA(i)-LAMNP ) - CL(I) = COS( LAMBDA(i)-LAMNP ) - ENDDO - SL(lattice%imglobal+1) = SL(1) - CL(lattice%imglobal+1) = CL(1) - - DO J = 1,lattice%jmglobal - CC(J) = COS( PHI(j) ) - SC(J) = SIN( PHI(j) ) - ENDDO - CC(1) = ZERO - SC(1) = -ONE - CC(lattice%jmglobal) = ZERO - SC(lattice%jmglobal) = ONE - CC(lattice%jmglobal+1) = undef - SC(lattice%jmglobal+1) = undef - - DO J = 2,lattice%jmglobal-2 - CV(J) = HALF*(CC(J+1)+CC(J)) - ENDDO - CV(1) = ZERO - CV(lattice%jmglobal-1) = ZERO - CV(lattice%jmglobal ) = undef - CV(lattice%jmglobal+1) = undef - - -c DXU & DYV ARE DEFINED FROM THE GRID: ALL OTHER FACTORS ARE DEFINED IN TERMS OF THEM -c ------------------------------------------------------------------------------------ - DO J = 1,JM - DO I = 1,IM - DXUIJ(I,J) = AE*DLAM( lattice%iglobal(i) )*CC( lattice%jglobal(j) ) - ENDDO - ENDDO - - DO J = 1,JM - DO I = 1,IM - DYVIJ(I,J) = AE*DPHI( lattice%jglobal(j) ) - ENDDO - ENDDO - - -c DXP AND DXV -c ----------- - call ghostx ( dxuij,gostx,im,jm,1,1,lattice,'west' ) - DO j = 1,JM - DO I = 1,IM - DXPIJ(I,j) = HALF*( DXUIJ(I,j)+gostx(i-1,j) ) - ENDDO - ENDDO - - call ghosty ( dxpij,gosty,im,jm,1,0,1,1,lattice,'north' ) - DO j = p2,jmm2 - DO I = 1,IM - DXVIJ(I,j) = HALF*( gosty(I,j+1)+DXPIJ(I,j) ) - ENDDO - ENDDO - - if( lattice%pej.eq.0 ) then - DO I = 1,IM - DXVIJ(I,1) = ZERO - ENDDO - endif - if( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - DXVIJ(I,JM-1) = ZERO - ENDDO - endif - - -c DYU & DYP -c --------- - call ghosty ( dyvij,gosty,im,jm,1,1,1,1,lattice,'south' ) - DO j = p3,jmm2 - DO I = 1,IM - DYPIJ(I,j) = HALF*( gosty(I,j-1)+DYVIJ(I,j) ) - ENDDO - ENDDO - - if( lattice%pej.eq.0 ) then - DO I = 1,IM - DYPIJ(I,1) = ZERO - DYPIJ(I,2) = AE*( DPHI(1) + HALF*DPHI(2) ) - ENDDO - endif - if( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - DYPIJ(I,JM-1) = AE*( DPHI(lattice%jmglobal-1) + HALF*DPHI(lattice%jmglobal-2) ) - DYPIJ(I,JM ) = ZERO - ENDDO - endif - - DO j = 1,JM - DO I = 1,IM - DYUIJ(I,j) = DYPIJ(I,j) - ENDDO - ENDDO - - -c AREA FACTORS -c ------------ - call ghosty ( dxvij,gosty,im,jm,1,1,1,1,lattice,'south' ) - DO j = p3,jmm2 - DO I = 1,IM - D2PIJ(I,j) = HALF*( gosty(I,j-1)+DXVIJ(I,j) ) * DYPIJ(I,j) - D2UIJ(I,j) = DXUIJ(I,j) * DYUIJ(I,j) - ENDDO - ENDDO - - if( lattice%pej.eq.0 ) then - DO I = 1,IM - D2PIJ(I,2) = DXPIJ(I,2) * DYVIJ(I,1) - D2UIJ(I,2) = D2PIJ(I,2) - ENDDO - endif - if( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - D2PIJ(I,JM-1) = DXPIJ(I,JM-1) * DYVIJ(I,JM-1) - D2PIJ(I,JM ) = ZERO - D2UIJ(I,JM-1) = D2PIJ(I,JM-1) - D2UIJ(I,JM ) = ZERO - ENDDO - endif - - call ghostx ( d2pij(1:im, 1:jm),gostxy(0:im+1,1:jm ),im, jm,1, 1,lattice,'east' ) - call ghosty ( gostxy(0:im+1,1:jm),gostxy(0:im+1,0:jm+1),im+2,jm,1,0,1,1,lattice,'north' ) - - DO j = p2,jmm2 - DO I = 1,IM - D2VIJ(I,j) = DXVIJ(I,j) * DYVIJ(I,j) - D2ZIJ(I,j) = FOURTH*( gostxy(i ,j)+gostxy(i ,j+1) - * + gostxy(i+1,j)+gostxy(i+1,j+1) ) - ENDDO - ENDDO - - if( lattice%pej.eq.0 ) then - call par_sum ( d2pij(1,2),sum,im,1,lattice ) - DO I = 1,IM - D2VIJ(I,1) = ZERO - D2ZIJ(I,1) = (HALF/FLOAT( lattice%imglobal ))*sum - ENDDO - endif - if( lattice%pej.eq.lattice%ny-1 ) then - call par_sum ( d2pij(1,jm-1),sum,im,1,lattice ) - DO I = 1,IM - D2VIJ(I,JM-1) = ZERO - D2ZIJ(I,JM-1) = (HALF/FLOAT( lattice%imglobal ))*sum - ENDDO - endif - - -c CORIOLIS PARAMETER -c ------------------ - call ghosty ( dxuij,gosty,im,jm,1,0,1,1,lattice,'north' ) - DO J = p2,jmm2 - DO I = 1,IM - FS = (CC( lattice%jglobal(j)+1 )*gosty(i,j+1)-CC( lattice%jglobal(j) )*DXUIJ(I,J)) - FC = ( DYVIJ(I,J)*(SL(lattice%iglobal(i)+1)-SL(lattice%iglobal(i))) - . + HALF*(CL(lattice%iglobal(i)+1)+CL(lattice%iglobal(i))) - . * (gosty(i,j+1)*SC( lattice%jglobal(j)+1 )-DXUIJ(I,J)*SC( lattice%jglobal(j) )) ) - FFFIJ(I,J) = -(AE*OMEGA/D2ZIJ(I,J)) * (SINPNP*FS - COSPNP*FC) - ENDDO - ENDDO - - if( lattice%pej.eq.0 ) then - call par_sum ( dxuij(1,2),sum,im,1,lattice ) - FS = CC(2)*(ONE/FLOAT( lattice%imglobal ))*sum - call par_dot ( dxuij(1,2),cl(lattice%iglobal(1)),dot,im,1,lattice ) - FC = SC(2)*(ONE/FLOAT( lattice%imglobal ))*dot - DO I = 1,IM - FFFIJ(I,1) = -(AE*OMEGA/D2ZIJ(I,1))*(SINPNP*FS - COSPNP*FC) - ENDDO - endif - - if( lattice%pej.eq.lattice%ny-1 ) then - call par_sum ( dxuij(1,jm-1),sum,im,1,lattice ) - FS = CC(lattice%jmglobal-1)*(ONE/FLOAT( lattice%imglobal ))*sum - call par_dot ( dxuij(1,JM-1),cl(lattice%iglobal(1)),dot,im,1,lattice ) - FC = SC(lattice%jmglobal-1)*(ONE/FLOAT( lattice%imglobal ))*dot - DO I = 1,IM - FFFIJ(I,JM-1) = (AE*OMEGA/D2ZIJ(I,JM-1))*(SINPNP*FS - COSPNP*FC) - ENDDO - endif - - -c PRE-COMPUTE INVERSES -c -------------------- - DO J = p2,jmm1 - DO I = 1,IM - DXUIN(I,J) = ONE / DXUIJ(I,J) - D2PIN(I,J) = ONE / D2PIJ(I,J) - ENDDO - ENDDO - - DO J = p2,jmm2 - DO I = 1,IM - DYVIN(I,J) = ONE / DYVIJ(I,J) - ENDDO - ENDDO - - DO J = p1,jmm1 - DO I = 1,IM - D2ZIN(I,J) = ONE / D2ZIJ(I,J) - ENDDO - ENDDO - - -C AVRX Filter Arrays for the Stretched-Grid -c ----------------------------------------- -c if( stretched ) then -c if( lattice%myid.eq.0 ) then -c print * -c print *, 'Computing Convolution Weights for Stretched-Grid' -c print *, '------------------------------------------------' -c print * -c endif -c call weights_p ( wp,dlam,dphi,lattice%imglobal,lattice%jmglobal,lattice ) -c call weights_u ( wu,dlam,dphi,lattice%imglobal,lattice%jmglobal,lattice ) -c call weights_v ( wv,dlam,dphi,lattice%imglobal,lattice%jmglobal,lattice ) -c else - -C AVRX Filter Arrays for the Uniform-Grid -c --------------------------------------- -c if( lattice%myid.eq.0 ) then -c print * -c print *, 'Computing Spectral Filters for Uniform-Grid' -c print *, '-------------------------------------------' -c print * -c endif - DO j = 1,JM - DO I = 1,lattice%imglobal+2 - SU(I,j) = ONE - SV(I,j) = ONE - ENDDO - ENDDO - FC = COS(45.*PI/180.) - DO J = p2,jmm1 - DO I = 3,lattice%imglobal+2 - SU(I,J) = MIN ( (CC(lattice%jglobal(j))/FC)/SIN(INT((I-1)/2)*PI/FLOAT(lattice%imglobal)),ONE ) ** 2 - ENDDO - ENDDO - DO J = p2,jmm2 - DO I = 3,lattice%imglobal+2 - SV(I,J) = MIN ( (CV(lattice%jglobal(j))/FC)/SIN(INT((I-1)/2)*PI/FLOAT(lattice%imglobal)),ONE ) ** 2 - ENDDO - ENDDO -c endif - - return - end - - subroutine gridv ( LM,SIG,DSG ) - IMPLICIT NONE - INTEGER LM - REAL(kind=8) SIG(LM+1) - REAL(kind=8) DSG(LM) - INTEGER L - DO L=1,LM - DSG(L) = SIG(L+1) - SIG(L) - ENDDO - RETURN - END - - subroutine avrx ( U,IM,JM,LM,S,lattice ) - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - include 'mpif.h' - integer status(mpi_status_size) - integer stats(mpi_status_size,0:lattice%nx-1) - integer statr(mpi_status_size,0:lattice%nx-1) - - integer sendquest(0:lattice%nx-1) - integer recvquest(0:lattice%nx-1) - integer ierror,peid - - logical first, flag - data first /.true./ - - INTEGER FORWARD, BACKWARD - PARAMETER (FORWARD=-1, BACKWARD=1) - - REAL(kind=8) ONE - REAL(kind=8) ZERO - PARAMETER ( ONE=1.0) - PARAMETER (ZERO=0.0) - -c ARGUMENTS -c --------- - INTEGER IM,JM,LM - REAL(kind=8) U(IM,JM,LM) - REAL(kind=8) S(lattice%imglobal+2,JM) - -c SCRATCH SPACE -c ------------- - real(kind=8), allocatable :: sendbuf(:,:) - real(kind=8), allocatable :: recvbuf(:,:) - real(kind=8), allocatable :: z(:,:) - real(kind=8), allocatable :: b(:,:) - integer, allocatable :: j2(:) - - INTEGER I,J,L, J1(JM*LM), L1(JM*LM) - INTEGER NFFTS - INTEGER IM0 - DATA IM0/0/ - - integer n,num,rem,isum,lsum,len,len0 - integer p1,p2,p3,jmm1,jmm2,jmm3 - integer, save :: ix(19) - real(kind=8), allocatable, save :: tr(:) - - if (lattice%imglobal.ne.im0) then - if(im0.ne.0) deallocate ( tr ) - allocate ( tr(lattice%imglobal*2) ) - call fftfax (lattice%imglobal,ix,tr) - im0=lattice%imglobal - endif - -c Set J-Index Range -c ----------------- - if ( lattice%pej.eq.0 ) then - p1 = 1 - p2 = 2 - p3 = 3 - else - p1 = 1 - p2 = 1 - p3 = 1 - endif - if ( lattice%pej.eq.lattice%ny-1 ) then - jmm1 = jm-1 - jmm2 = jm-2 - jmm3 = jm-3 - else - jmm1 = jm - jmm2 = jm - jmm3 = jm - endif - -c Compute Number of FFTs to Perform and Load Data into Buffer -c ----------------------------------------------------------- - allocate ( sendbuf(im,jm*lm) ) - - nffts = 0 - do j=p1,jmm1 - if( s(lattice%imglobal+2,j).lt.0.9999 ) then - do L=1,lm - nffts = nffts + 1 - j1(nffts) = j - L1(nffts) = L - do i=1,im - sendbuf(i,nffts) = u(i,j,L) - enddo - enddo - endif - enddo - - num = nffts/lattice%nx - rem = nffts-lattice%nx*num - - len0 = num ! Define number of FFTs on myid - if( lattice%pei.le.rem-1 ) len0 = num+1 ! Define number of FFTs on myid - -#if 0 - if( first ) then - if( lattice%myid.eq.0 ) then - print *, 'FFT Load Balance for Upper-Air Field:' - print *, '-------------------------------------' - endif - do n=0,lattice%nx*lattice%ny-1 - if( n.eq.lattice%myid ) then - write(6,1000) lattice%myid,lattice%pei,lattice%pej,nffts,num,rem,len0 - if( mod(n+1,lattice%nx).eq.0 ) print * - endif - call my_barrier (lattice%comm) - enddo - if( lattice%myid.eq.lattice%nx*lattice%ny-1 ) print * - first = .false. - endif - 1000 format(1x,'absolute PE id: ',i3,' relative (pei,pej): ',i2,',',i2,' nffts: ',i6,2x, - . 'num: ',i6,2x,'rem: ',i6,2x,'len0: ',i6) -#endif - -c Distribute Data Across PEs in X-direction -c ----------------------------------------- - if( nffts.ne.0 ) then - - allocate ( j2(len0) ) - allocate ( z(lattice%imglobal+2,len0 ) ) - allocate ( b(lattice%imglobal+2,len0*2) ) - - isum = 0 - lsum = 0 - do n = 0,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - len = num - if( n.le.rem-1 ) len = num+1 - sendquest(n) = mpi_request_null - if( len.ne.0 ) then - if( peid.ne.lattice%myid ) then - - call mpi_isend ( sendbuf(1,1+lsum),im*len,mpi_double_precision,peid,peid,lattice%comm,sendquest(n),ierror ) - - else - do L=1,len0 - j2(L) = j1(L+lsum) - do i=1,im - z(i+isum,L) = sendbuf(i,L+lsum) - enddo - enddo - endif - endif - isum = isum + lattice%im(n) - lsum = lsum + len - enddo - -c Receive Data and Perform FFT -c ---------------------------- - if( len0.ne.0 ) then - - allocate ( recvbuf( lattice%imglobal*len0,0:lattice%nx-1 ) ) - do n = 0,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - if( peid.ne.lattice%myid ) then - - call mpi_irecv ( recvbuf(1,n),lattice%im(n)*len0,mpi_double_precision,peid,lattice%myid,lattice%comm, - . recvquest(n),ierror ) - - else - recvquest(n) = mpi_request_null - endif - enddo - - call mpi_waitall ( lattice%nx,sendquest(0:lattice%nx-1),stats(1,0),ierror ) - call mpi_waitall ( lattice%nx,recvquest(0:lattice%nx-1),statr(1,0),ierror ) - - isum = 0 - do n = 0,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - if( peid.ne.lattice%myid ) then - lsum = 0 - do L=1,len0 - do i=1,lattice%im(n) - lsum = lsum+1 - z(i+isum,L) = recvbuf(lsum,n) - enddo - enddo - endif - isum = isum + lattice%im(n) - enddo - - do L=1,len0 - z(lattice%imglobal+1,L) = 0.0 - z(lattice%imglobal+2,L) = 0.0 - enddo - -c Perform FFT -c ----------- - call rfftmlt( Z,B,TR,IX,1,lattice%imglobal+2,lattice%imglobal,len0,FORWARD ) - do L=1,len0 - do i=1,lattice%imglobal+2 - z(i,L) = z(i,L)*s(i,j2(L)) - enddo - enddo - call rfftmlt( Z,B,TR,IX,1,lattice%imglobal+2,lattice%imglobal,len0,BACKWARD ) - -c Distribute Filtered Data Back to source PEs -c ------------------------------------------- - deallocate ( sendbuf ) - deallocate ( recvbuf ) - allocate ( sendbuf( lattice%imglobal*len0,0:lattice%nx-1 ) ) - isum = 0 - do n = 0,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - if( peid.ne.lattice%myid ) then - - lsum = 0 - do L=1,len0 - do i=1,lattice%im(n) - lsum = lsum+1 - sendbuf(lsum,n) = z(i+isum,L) - enddo - enddo - call mpi_isend ( sendbuf(1,n),lsum,mpi_double_precision,peid,peid,lattice%comm,sendquest(n),ierror ) - - else - sendquest(n) = mpi_request_null - endif - isum = isum + lattice%im(n) - enddo - - endif ! End len0.ne.0 check - -c Receive Filtered Data -c --------------------- - allocate ( recvbuf(im,nffts) ) - isum = 0 - lsum = 0 - do n = 0,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - len = num - if( n.le.rem-1 ) len = num+1 - recvquest(n) = mpi_request_null - if( len.ne.0 ) then - if( peid.ne.lattice%myid ) then - - call mpi_irecv ( recvbuf(1,1+lsum),im*len,mpi_double_precision,peid,lattice%myid,lattice%comm,recvquest(n),ierror ) - - else - do L=1,len0 - do i=1,im - recvbuf(i,L+lsum) = z(i+isum,L) - enddo - enddo - endif - endif - isum = isum + lattice%im(n) - lsum = lsum + len - enddo - - call mpi_waitall ( lattice%nx,sendquest(0:lattice%nx-1),stats(1,0),ierror ) - call mpi_waitall ( lattice%nx,recvquest(0:lattice%nx-1),statr(1,0),ierror ) - -c Reconstruct Filtered Field -c -------------------------- - do n=1,nffts - do i=1,im - u(i,j1(n),L1(n)) = recvbuf(i,n) - enddo - enddo - - deallocate ( z,b,j2 ) - deallocate ( sendbuf ) - deallocate ( recvbuf ) - else - deallocate ( sendbuf ) - endif - - return - end - - subroutine hadvect (U,V,P,IM,JM,DIV,VT1,VT2,lattice) - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - INTEGER IM,JM - REAL(kind=8) P(IM,JM) - - REAL(kind=8) U(0:im+1,0:jm+1) - REAL(kind=8) V(0:im+1,0:jm+1) - REAL(kind=8) Q(0:im+1,0:jm+1) - REAL(kind=8) DIV(0:im+1,0:jm+1) - REAL(kind=8) VT1(0:im+1,0:jm+1) - REAL(kind=8) VT2(0:im+1,0:jm+1) - - REAL(kind=8) ST1 - REAL(kind=8) ST2 - - integer i,j,p1,p2,p3,jmm1,jmm2,jmm3 - -c Set J-Index Range -c ----------------- - if ( lattice%pej.eq.0 ) then - p1 = 1 - p2 = 2 - p3 = 3 - else - p1 = 1 - p2 = 1 - p3 = 1 - endif - if ( lattice%pej.eq.lattice%ny-1 ) then - jmm1 = jm-1 - jmm2 = jm-2 - jmm3 = jm-3 - else - jmm1 = jm - jmm2 = jm - jmm3 = jm - endif - - call ghostx ( p(1:im, 1:jm),q(0:im+1,1:jm ),im, jm,1, 1,lattice,'both' ) - call ghosty ( q(0:im+1,1:jm),q(0:im+1,0:jm+1),im+2,jm,1,0,1,1,lattice,'both' ) - -c CORNER FLUXES -c ------------- - DO j = p2,jmm1 - DO I = 1,IM - DIV(I,j) = (U(I,j)-U(i-1,j)) - (V(I,j)-V(I,j-1)) ! Mass-Point - ENDDO - ENDDO - - call ghostx ( div(1:im, 1:jm),div(0:im+1,1:jm ),im, jm,1, 1,lattice,'east' ) - call ghosty ( div(0:im+1,1:jm),div(0:im+1,0:jm+1),im+2,jm,1,0,1,1,lattice,'both' ) - - DO j = p2,jmm2 - DO I = 1,IM - VT1(I,j) = 0.5*( Q(i,j )+Q(i+1,j+1) ) * ( DIV(i ,j+1)-DIV(i+1,j) ) ! VWND-Point - VT2(I,j) = 0.5*( Q(i,j+1)+Q(i+1,j ) ) * ( DIV(i+1,j+1)-DIV(i ,j) ) ! VWND-Point - ENDDO - ENDDO - -c Corner Flux at North Pole -c ------------------------- - if ( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - VT1(I,JM-1) = 0. ! VWND-Point at Pole - VT2(I,JM-1) = 0. ! VWND-Point at Pole - ENDDO - endif - -c Corner Flux at South Pole -c ------------------------- - if ( lattice%pej.eq.0 ) then - DO I = 1,IM - VT1(I,1) = 0. ! VWND-Point at Pole - VT2(I,1) = 0. ! VWND-Point at Pole - ENDDO - endif - - call ghostx ( vt1(1:im, 1:jm),vt1(0:im+1,1:jm ),im, jm,1, 1,lattice,'west' ) - call ghosty ( vt1(0:im+1,1:jm),vt1(0:im+1,0:jm+1),im+2,jm,1,1,1,1,lattice,'south' ) - call ghostx ( vt2(1:im, 1:jm),vt2(0:im+1,1:jm ),im, jm,1, 1,lattice,'west' ) - call ghosty ( vt2(0:im+1,1:jm),vt2(0:im+1,0:jm+1),im+2,jm,1,1,1,1,lattice,'south' ) - - DO j = p2,jmm1 - DO I = 1,IM - DIV(I,j) = (1./48.)*( (VT1(i ,j) - VT1(i-1,j-1)) - * + (VT2(i-1,j) - VT2(i ,j-1)) ) ! Mass-Point - ENDDO - ENDDO - -c NEAR FLUXES -c ----------- - DO j = p3,jmm2 - DO I = 1,IM - ST1 = 28.*U(I,j) + 3.*(U(i+1,j)+U(i-1,j)) - (U(I,j-1)+U(I,j+1)) - VT1(I,j) = 0.5*(Q(i+1,j) + Q(i,j))*ST1 ! UWND-Point - ENDDO - ENDDO - DO j = p3,jmm3 - DO I = 1,IM - ST2 = 28.*V(I,j) + 3.*(V(I,j+1)+V(I,j-1)) - (V(i+1,j)+V(i-1,j)) - VT2(I,j) = 0.5*(Q(I,j+1) + Q(I,j))*ST2 ! VWND-Point - ENDDO - ENDDO - - -c Near Flux Near North Pole -c ------------------------- - if ( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - ST1 = 0.5*(U(i+1,JM-1)+U(i-1,JM-1)-V(I,JM-2)+V(i+1,JM-2)) - ST1 = 28.*U(I,JM-1) + 3.*(U(i+1,JM-1)+U(i-1,JM-1)) - (ST1 + U(I,JM-2)) - VT1(I,JM-1) = 0.5*(Q(i+1,JM-1) + Q(i,JM-1))*ST1 ! UWND-Point Near Pole - - ST2 = 26.*V(I,JM-2) + 3.*(V(I,JM-3)) - (V(i+1,JM-2)+V(i-1,JM-2)) - VT2(I,JM-2) = 0.5*(Q(I,JM-1) + Q(I,JM-2))*ST2 ! VWND-Point Near Pole - VT2(I,JM-1) = 0. ! VWND-Point at Pole - ENDDO - endif - -c Near Flux Near South Pole -c ------------------------- - if ( lattice%pej.eq.0 ) then - DO I = 1,IM - ST1 = 0.5*(U(i+1,2)+U(i-1,2)+V(I,2)-V(i+1,2)) - ST1 = 28.*U(I,2) + 3.*(U(i+1,2)+U(i-1,2)) - (ST1 + U(I,3)) - VT1(I,2) = 0.5*(Q(i+1,2) + Q(i,2))*ST1 ! UWND-Point Near Pole - - ST2 = 26.*V(I,2) + 3.*(V(I,3)) - (V(i+1,2)+V(i-1,2)) - VT2(I,2) = 0.5*(Q(I,3) + Q(I,2))*ST2 ! VWND-Point Near Pole - VT2(I,1) = 0. ! VWND-Point at Pole - ENDDO - endif - - call ghostx ( vt1(1:im,1:jm),vt1(0:im+1,1:jm ),im,jm,1, 1,lattice,'west' ) - call ghosty ( vt2(1:im,1:jm),vt2(1:im ,0:jm+1),im,jm,1,1,-1,1,lattice,'south' ) - - DO j = p2,jmm1 - DO I = 1,IM - DIV(I,j) = DIV(I,j) + (1./24.)*( (VT1(I,j) - VT1(i-1,j)) - * + (VT2(I,j) - VT2(i,j-1)) ) ! Mass-Point - ENDDO - ENDDO - -c FAR FLUXES -c ---------- - DO j = p2,jmm1 - DO I = 1,IM - ST1 = U(I,j) + U(i-1,j) - VT1(I,j) = 0.5*(Q(i+1,j) + Q(i-1,j))*ST1 ! Mass-Point - ENDDO - ENDDO - DO j = p3,jmm2 - DO I = 1,IM - ST2 = V(I,j) + V(i,j-1) - VT2(I,j) = 0.5*(Q(i,j+1) + Q(i,j-1))*ST2 ! Mass-Point - ENDDO - ENDDO - -c Far Flux Near North Pole -c ------------------------ - if ( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - VT2(I,JM-1) = 0. ! Mass-Point Near Pole - ENDDO - endif - -c Far Flux Near South Pole -c ------------------------ - if ( lattice%pej.eq.0 ) then - DO I = 1,IM - VT2(I,2) = 0. ! Mass-Point Near Pole - ENDDO - endif - - call ghostx ( vt1(1:im,1:jm),vt1(0:im+1,1:jm ),im,jm,1, 1,lattice,'both' ) - call ghosty ( vt2(1:im,1:jm),vt2(1:im ,0:jm+1),im,jm,1,0,-1,1,lattice,'both' ) - - DO j = p3,jmm2 - DO I = 1,IM - DIV(I,j) = DIV(I,j) - (1./12.)*( (VT1(i+1,j) - VT1(i-1,j)) - * + (VT2(i,j+1) - VT2(i,j-1)) ) ! Mass-Point - ENDDO - ENDDO - -c DIV Near North Pole -c ------------------- - if ( lattice%pej.eq.lattice%ny-1 ) then - DO I = 1,IM - DIV(I,JM-1) = DIV(I,JM-1) - (1./12.)*( VT1(i+1,JM-1)-VT1(i-1,JM-1)-VT2(i,JM-2) ) ! Mass-Point Near Pole - ENDDO - endif - -c DIV Near South Pole -c ------------------- - if ( lattice%pej.eq.0 ) then - DO I = 1,IM - DIV(I,2) = DIV(I,2) - (1./12.)*( VT1(i+1,2)-VT1(i-1,2)+VT2(i,3) ) ! Mass-Point Near Pole - ENDDO - endif - - RETURN - END diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_lattice_module.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_lattice_module.F deleted file mode 100644 index b2d1a529d..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_lattice_module.F +++ /dev/null @@ -1,108 +0,0 @@ - module g3_dynamics_lattice_module - -c Define Lattice -c -------------- - type dynamics_lattice_type - integer :: imglobal ! Global Size in X - integer :: jmglobal ! Global Size in Y - integer :: lm ! Global Size in Z (Note: Same as Local Size) - integer :: imax ! Maximum local im - integer :: jmax ! Maximum local jm - integer :: comm ! MPI Communicator - integer :: nx,ny ! Size of PE lattice - integer :: pei,pej ! Relative address of local PE on lattice - integer :: myid ! Absolute address of local PE - integer :: mpi_rkind ! mpi_real or mpi_double_precision based on kind - integer, pointer :: npeg(:) ! Number of pole PE ghosts per processor - integer, pointer :: img(:,:) ! Number of grid-points associated with each pole PE ghost - integer, pointer :: im0(:,:) ! Beginning address associated with each pole PE ghost - integer, pointer :: ppeg(:) ! Relative address of pole PE ghost for each iglobal - integer, pointer :: im(:) ! Array of local zonal dimension for each PE in x - integer, pointer :: jm(:) ! Array of local meridional dimension for each PE in y - integer, pointer :: ilocal(:) ! Array of local i-index for global i-location - integer, pointer :: jlocal(:) ! Array of local j-index for global j-location - integer, pointer :: iglobal(:) ! Array of global i-index for local i-location - integer, pointer :: jglobal(:) ! Array of global j-index for local j-location - integer, pointer :: peiglobal(:) ! Relative PE address associated with iglobal - integer, pointer :: pejglobal(:) ! Relative PE address associated with jglobal - endtype dynamics_lattice_type - - contains - -C ********************************************************************** - subroutine create_dynamics_lattice (lattice,nx,ny) -C ********************************************************************** - implicit none - type ( dynamics_lattice_type) lattice - integer n,m,nx,ny - -c Lattice%im -c ---------- - if(.not.associated(lattice%im)) then - allocate ( lattice%im(0:nx-1) ) - do n=0,nx-1 - lattice%im(n) = 0 - enddo - else - m=size(lattice%im) - if(m.ne.nx) then - print *, 'Allocated Lattice Size (',m,') does not match request (',nx,') for lattice%im!' - stop - endif - endif - -c Lattice%jm -c ---------- - if(.not.associated(lattice%jm)) then - allocate ( lattice%jm(0:ny-1) ) - do n=0,ny-1 - lattice%jm(n) = 0 - enddo - else - m=size(lattice%jm) - if(m.ne.ny) then - print *, 'Allocated Lattice Size (',m,') does not match request (',ny,') for lattice%jm!' - stop - endif - endif - -c Lattice%npeg -c ------------ - if(.not.associated(lattice%npeg)) then - allocate ( lattice%npeg(0:nx-1) ) - do n=0,nx-1 - lattice%npeg(n) = 0 - enddo - else - m=size(lattice%npeg) - if(m.ne.nx) then - print *, 'Allocated Lattice Size (',m,') does not match request (',nx,') for lattice%npeg!' - stop - endif - endif - - return - end subroutine create_dynamics_lattice - -C ********************************************************************** - subroutine destroy_dynamics_lattice (lattice) -C ********************************************************************** - implicit none - type ( dynamics_lattice_type) lattice - if(associated( lattice%im )) deallocate ( lattice%im ) - if(associated( lattice%jm )) deallocate ( lattice%jm ) - if(associated( lattice%npeg )) deallocate ( lattice%npeg ) - if(associated( lattice%ppeg )) deallocate ( lattice%ppeg ) - if(associated( lattice%img )) deallocate ( lattice%img ) - if(associated( lattice%im0 )) deallocate ( lattice%im0 ) - if(associated( lattice%ilocal )) deallocate ( lattice%ilocal ) - if(associated( lattice%jlocal )) deallocate ( lattice%jlocal ) - if(associated( lattice%iglobal )) deallocate ( lattice%iglobal ) - if(associated( lattice%jglobal )) deallocate ( lattice%jglobal ) - if(associated( lattice%peiglobal )) deallocate ( lattice%peiglobal ) - if(associated( lattice%pejglobal )) deallocate ( lattice%pejglobal ) - return - end subroutine destroy_dynamics_lattice - - endmodule g3_dynamics_lattice_module - diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_state_module.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_state_module.F deleted file mode 100644 index a7b7bb8f3..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_dynamics_state_module.F +++ /dev/null @@ -1,133 +0,0 @@ - module g3_dynamics_state_module - -c Declare Used Modules -c -------------------- - use g3_dynamics_lattice_module - - implicit none - -c Dynamics State Variables -c ------------------------ - type dynamics_vars_type - real(kind=8) , pointer :: p(:,:) - real(kind=8) , pointer :: u(:,:,:) - real(kind=8) , pointer :: v(:,:,:) - real(kind=8) , pointer :: t(:,:,:) - real(kind=8) , pointer :: q(:,:,:,:) - endtype dynamics_vars_type - - -c Dynamics Grid -c ------------- - type dynamics_grid_type - type ( dynamics_lattice_type ) lattice - real(kind=8) ptop, pimean - real(kind=8) lam_np, phi_np, lam_0 - real(kind=8) dl, dp - integer im,jm,lm,n - integer ntracer, ptracer - real(kind=8) , pointer :: dlam(:) - real(kind=8) , pointer :: dphi(:) - real(kind=8) , pointer :: sige(:) - real(kind=8) , pointer :: sig(:) - real(kind=8) , pointer :: dsig(:) - real(kind=8) , pointer :: alf(:) - real(kind=8) , pointer :: bet(:) - endtype dynamics_grid_type - - -c Define Dynamics State -c --------------------- - type dynamics_state_type - type ( dynamics_grid_type ) grid - type ( dynamics_vars_type ) vars(2) - endtype dynamics_state_type - - contains - -C ********************************************************************** - subroutine create_dynamics (state,im,jm,lm,nt) -C ********************************************************************** - implicit none - type ( dynamics_state_type) state - integer im,jm,lm,nt - call create_dynamics_vars (state%vars(1),im,jm,lm,nt) - call create_dynamics_vars (state%vars(2),im,jm,lm,nt) - call create_dynamics_grid (state%grid,state%grid%lattice%imglobal, - . state%grid%lattice%jmglobal,lm) - return - end subroutine create_dynamics - -C ********************************************************************** - subroutine create_dynamics_vars (vars,im,jm,lm,nt) -C ********************************************************************** - implicit none - include 'g3_mymalloc_interface' - type ( dynamics_vars_type) vars - integer im,jm,lm,nt - call mymalloc ( vars%p,im,jm ) - call mymalloc ( vars%u,im,jm,lm ) - call mymalloc ( vars%v,im,jm,lm ) - call mymalloc ( vars%t,im,jm,lm ) - call mymalloc ( vars%q,im,jm,lm,nt ) - return - end subroutine create_dynamics_vars - -C ********************************************************************** - subroutine create_dynamics_grid (grid,im,jm,lm) -C ********************************************************************** - implicit none - include 'g3_mymalloc_interface' - type ( dynamics_grid_type) grid - integer im,jm,lm - call mymalloc ( grid%dlam,im ) - call mymalloc ( grid%dphi,jm ) - call mymalloc ( grid%alf ,lm+1 ) - call mymalloc ( grid%bet ,lm+1 ) - call mymalloc ( grid%sige,lm+1 ) - call mymalloc ( grid% sig,lm ) - call mymalloc ( grid%dsig,lm ) - return - end subroutine create_dynamics_grid - -C ********************************************************************** - subroutine destroy_dynamics (state) -C ********************************************************************** - implicit none - type ( dynamics_state_type) state - call destroy_dynamics_vars (state%vars(1)) - call destroy_dynamics_vars (state%vars(2)) - call destroy_dynamics_grid (state%grid) - return - end subroutine destroy_dynamics - -C ********************************************************************** - subroutine destroy_dynamics_vars (vars) -C ********************************************************************** - implicit none - type ( dynamics_vars_type) vars - if(associated( vars%p )) deallocate ( vars%p ) - if(associated( vars%u )) deallocate ( vars%u ) - if(associated( vars%v )) deallocate ( vars%v ) - if(associated( vars%t )) deallocate ( vars%t ) - if(associated( vars%q )) deallocate ( vars%q ) - return - end subroutine destroy_dynamics_vars - -C ********************************************************************** - subroutine destroy_dynamics_grid (grid) -C ********************************************************************** - implicit none - type ( dynamics_grid_type) grid - if(associated( grid%dlam )) deallocate ( grid%dlam ) - if(associated( grid%dphi )) deallocate ( grid%dphi ) - if(associated( grid%alf )) deallocate ( grid%alf ) - if(associated( grid%bet )) deallocate ( grid%bet ) - if(associated( grid%sige )) deallocate ( grid%sige ) - if(associated( grid%sig )) deallocate ( grid%sig ) - if(associated( grid%dsig )) deallocate ( grid%dsig ) - return - end subroutine destroy_dynamics_grid - - - endmodule g3_dynamics_state_module diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_fft.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_fft.F deleted file mode 100755 index 03ee6bbdd..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_fft.F +++ /dev/null @@ -1,456 +0,0 @@ - subroutine atod ( qa,qd,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded data **** -C **** to 'D' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted left (westward), **** -C **** u is shifted down (southward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real(kind=8) qa (im,jm,lm) - real(kind=8) qd (im,jm,lm) - - real(kind=8) qax ( im+2 ,lm) - real(kind=8) cx (2*(im+2),lm) - real(kind=8) qay ( 2*jm ,lm) - real(kind=8) cy (2*(2*jm),lm) - - real(kind=8) cosx (im/2), sinx(im/2) - real(kind=8) cosy (jm) , siny(jm) - real(kind=8) trigx(3*(im+1)) - real(kind=8) trigy(3*(2*jm)) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - -C ********************************************************* -C **** shift left (-dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qa(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) + qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) - qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qd(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift down (-dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qa(i,j+1,L) - qay(j+jmm1,L) = -qa(i+imh,jm-j,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) + qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) - qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qd(i,j+1,L) = qay(j,L) - qd(i+imh,jm-j+1,L) = -qay(j+jmm1,L) - enddo - enddo - enddo - - endif - - return - end - - subroutine dtoa ( qd,qa,im,jm,lm,itype ) - -C ****************************************************************** -C **** **** -C **** This program converts 'D' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** The D-Grid Triplet is defined as: **** -C **** **** -C **** u(i,j+1) **** -C **** | **** -C **** v(i,j)---delp(i,j)---v(i+1,j) **** -C **** | **** -C **** u(i,j) **** -C **** **** -C **** Thus, v is shifted right (eastward), **** -C **** u is shifted up (northward) **** -C **** **** -C **** An FFT shift transformation is made in x for itype = 1 **** -C **** An FFT shift transformation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - real(kind=8) qa (im,jm,lm) - real(kind=8) qd (im,jm,lm) - - real(kind=8) qax ( im+2 ,lm) - real(kind=8) cx (2*(im+2),lm) - real(kind=8) qay ( 2*jm ,lm) - real(kind=8) cy (2*(2*jm),lm) - - real(kind=8) cosx (im/2), sinx(im/2) - real(kind=8) cosy (jm) , siny(jm) - real(kind=8) trigx(3*(im+1)) - real(kind=8) trigy(3*(2*jm)) - - integer IFX (100) - integer IFY (100) - - jmm1 = jm-1 - jp = 2*jmm1 - - imh = im/2 - pi = 4.0*atan(1.0) - dx = 2*pi/im - dy = pi/jmm1 - -C ********************************************************* -C **** shift right (dx/2) **** -C ********************************************************* - - if (itype.eq.1) then - - call fftfax (im,ifx,trigx) - - do k=1,imh - thx = k*dx*0.5 - cosx(k) = cos(thx) - sinx(k) = sin(thx) - enddo - - do j=1,jm - do L=1,lm - do i=1,im - qax(i,L) = qd(i,j,L) - enddo - enddo - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm,-1) - - do L=1,lm - do k=1,imh - kr = 2*k+1 - ki = 2*k+2 - crprime = qax(kr,L)*cosx(k) - qax(ki,L)*sinx(k) - ciprime = qax(ki,L)*cosx(k) + qax(kr,L)*sinx(k) - qax(kr,L) = crprime - qax(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qax,cx,trigx,ifx,1 ,im+2,im,lm, 1) - do L=1,lm - do i=1,im - qa(i,j,L) = qax(i,L) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** shift up (dy/2) **** -C ********************************************************* - - if (itype.eq.2) then - - call fftfax (jp,ify,trigy) - - do L=1,jmm1 - thy = L*dy*0.5 - cosy(L) = cos(thy) - siny(L) = sin(thy) - enddo - - do i=1,imh - do L=1,lm - do j=1,jmm1 - qay(j,L) = qd(i,j+1,L) - qay(j+jmm1,L) = -qd(i+imh,jm-j+1,L) - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm,-1) - - do L=1,lm - do k=1,jmm1 - kr = 2*k+1 - ki = 2*k+2 - crprime = qay(kr,L)*cosy(k) - qay(ki,L)*siny(k) - ciprime = qay(ki,L)*cosy(k) + qay(kr,L)*siny(k) - qay(kr,L) = crprime - qay(ki,L) = ciprime - enddo - enddo - - call rfftmlt (qay,cy,trigy,ify,1 ,jp+2,jp,lm, 1) - - do L=1,lm - do j=1,jmm1 - qa(i,j+1,L) = qay(j,L) - qa(i+imh,jm-j,L) = -qay(j+jmm1,L) - enddo - enddo - - enddo - - do L=1,lm - do i=1,imh - qa(i+imh,jm,L) = -qa(i,jm,L) - qa(i,1,L) = -qa(i+imh,1,L) - enddo - enddo - endif - - return - end - - subroutine rfftmlt (a,work,trigs,ifax,inc,jump,n,lot,isign) - integer INC, JUMP, N, LOT, ISIGN - real(kind=8) A(*),WORK(*),TRIGS(*) - integer IFAX(*) -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR -! CALL Q8QST4 ( 4HXLIB, 6HFFT99F, 6HFFT991, 10HVERSION 01) -!FPP$ NOVECTOR R - integer NFAX, NH, NX, INK - integer I, J, IBASE, JBASE, L, IGO, IA, LA, K, M, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, - * INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, - * 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE -!DIR$ IVDEP - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 -!DIR$ IVDEP - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END - subroutine fftfax (n,ifax,trigs) - integer IFAX(13) - integer N - REAL(kind=8) TRIGS(*) -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - integer I, MODE - DATA MODE /3/ -!FPP$ NOVECTOR R - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) WRITE(6,FMT="(//5X, ' FFTFAX -- INVALID N =', I5,/)") N - IF (IFAX(1) .LE. 0 ) STOP 999 - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_gcmutil.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_gcmutil.F deleted file mode 100644 index 467341bc9..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_gcmutil.F +++ /dev/null @@ -1,259 +0,0 @@ - subroutine getpl (p,pl,grid,im,jm) -C*********************************************************************** -C -C PURPOSE -C Compute pressure at model levels -C -C p ........ Dynamics Surface Pressure State Variable -C pl ....... Pressure at model levels -C grid ..... Dynamics Grid Structure -C im ....... Dimension in x -C jm ....... Dimension in y -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - -c Declare Modules Used -c -------------------- - use g3_dynamics_state_module - - implicit none -c Declare Input Variables -c ----------------------- - type ( dynamics_grid_type ) grid - - integer i,j,L - integer im,jm,lm - real(kind=8) p(im,jm) - real(kind=8) pl(im,jm,grid%lm) - real(kind=8) ple(im,jm,grid%lm+1) - - lm = grid%lm - - call getple (p,ple,grid,im,jm) - do L = 1,lm - do j = 1,jm - do i = 1,im - pl(i,j,L) = ( ple(i,j,L)+ple(i,j,L+1) )*0.5 - enddo - enddo - enddo - - return - end - - subroutine getpke (p,pke,grid,im,jm) -C*********************************************************************** -C -C PURPOSE -C Compute pressure at model levels -C -C p ........ Dynamics Surface Pressure State Variable -C pke ...... Pressure**kappa at model edges -C grid ..... Dynamics Grid Structure -C im ....... Dimension in x -C jm ....... Dimension in y -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - -c Declare Modules Used -c -------------------- - use g3_dynamics_state_module - - implicit none -c Declare Input Variables -c ----------------------- - type ( dynamics_grid_type ) grid - - integer i,j,L - integer im,jm,lm - real(kind=8) p(im,jm) - real(kind=8) ple(im,jm,grid%lm+1) - real(kind=8) pke(im,jm,grid%lm+1) - real(kind=8) getcon,kappa - - lm = grid%lm - kappa = getcon('KAPPA') - - call getple (p,ple,grid,im,jm) - do L = 1,lm+1 - do j = 1,jm - do i = 1,im - pke(i,j,L) = ple(i,j,L)**kappa - enddo - enddo - enddo - - return - end - - subroutine getple (p,ple,grid,im,jm) -C*********************************************************************** -C -C PURPOSE -C Compute pressure at model edge-levels -C -C p ........ Dynamics Surface Pressure State Variable -C ple ...... Pressure at model edge-levels -C grid ..... Dynamics Grid Structure -C im ....... Dimension in x -C jm ....... Dimension in y -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - -c Declare Modules Used -c -------------------- - use g3_dynamics_state_module - - implicit none -c Declare Input Variables -c ----------------------- - type ( dynamics_grid_type ) grid - - integer i,j,L - integer im,jm,lm - real(kind=8) p(im,jm) - real(kind=8) ple(im,jm,grid%lm+1) - - lm = grid%lm - - do L = 1,lm+1 - do j = 1,jm - do i = 1,im -! ple(i,j,L) = grid%alf(L) + grid%bet(L)*p(i,j) - ple(i,j,L) = grid%sige(L)*p(i,j) + grid%ptop - enddo - enddo - enddo - - return - end - - subroutine getpk (p,pke,pk,grid,im,jm) -C*********************************************************************** -C -C PURPOSE -C Compute pressure**kappa at model levels (Phillips formulation) -C -C p ........ Dynamics Surface Pressure State Variable -C pke ...... p**kappa at model edge-levels -C pk ....... Pressure at model levels -C grid ..... Dynamics Grid Structure -C im ....... Dimension in x -C jm ....... Dimension in y -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - -c Declare Modules Used -c -------------------- - use g3_dynamics_state_module - - implicit none -c Declare Input Variables -c ----------------------- - type ( dynamics_grid_type ) grid - - integer i,j,L - integer im,jm,lm - real(kind=8) p(im,jm) - real(kind=8) pk(im,jm,grid%lm) - real(kind=8) pke(im,jm,grid%lm+1) - real(kind=8) ple(im,jm,grid%lm+1) - real(kind=8) pinv(im,jm) - - real(kind=8) kappa,getcon,fact - kappa = getcon('KAPPA') - fact = 1.0/( 1.0+kappa ) - - lm = grid%lm - -c Get ple at model edges -c ---------------------- - call getple (p,ple,grid,im,jm) - -c Compute pk at model mid-levels -c ------------------------------ - do L = 1,lm - do j = 1,jm - do i = 1,im - pk(i,j,L) = ( ple(i,j,L+1)*pke(i,j,L+1)-ple(i,j,L)*pke(i,j,L) )*fact - . / ( ple(i,j,L+1) -ple(i,j,L) ) - enddo - enddo - enddo - - return - end - - subroutine harm (F,FNAME,L,IM) - - PARAMETER ( FOUR = 4.0 ) - PARAMETER ( ONE = 1.0 ) - PARAMETER ( AHALF = 0.5 ) - PARAMETER ( ZERO = 0.0 ) - PARAMETER ( P001 = 0.001 ) - integer IFAX (100) - REAL(kind=8) TRIGS(3*(IM+1)) - - real(kind=8) F(IM), FZ(IM+2), C(2*(IM+2)) - CHARACTER*4 FNAME - - PI = FOUR * ATAN(ONE) - PID2 = PI * AHALF - CALL FFTFAX (IM,IFAX,TRIGS) - WRITE(6,100) FNAME, L - - DO 10 I=1,IM - FZ(I) = F(I) - 10 CONTINUE - - CALL RFFTMLT (FZ,C,TRIGS,IFAX,1 ,IM+2,IM,1,-1) - - DO 20 I=1,IM+2 - C(I) = FZ(I) - 20 CONTINUE - - WRITE(6,200) C(1) - WRITE(6,300) - KM = IM/2 - KM1 = IM/2-1 - DO 30 K=1,KM1 - SIZE = FLOAT(IM)/FLOAT(K) - K2 = 2*K+1 - AK = 2*C(K2) - BK = -2*C(K2+1) - AMPL = SQRT( AK**2 + BK**2 ) - - IF(AK.EQ.ZERO) TEMP = PID2 - ( ONE - SIGN(ONE,BK) )*PID2 - IF(AK.NE.ZERO) - .TEMP = ATAN(BK/AK) - . + SIGN(ONE,BK) * (ONE-SIGN(ONE,AK)) * PID2 - - PHAZ = -TEMP - IF( AMPL.LT.P001) PHAZ = ZERO - WRITE(6,400) K,SIZE,AK,BK,AMPL,PHAZ - 30 CONTINUE - - AK = C(IM+1) - BK = ZERO - PHAZ = -(ONE-SIGN(ONE,AK)) * PID2 - AMPL = ABS(AK) - - IF( AMPL.LT.P001) PHAZ = ZERO - SIZE = FLOAT(IM)/FLOAT(KM) - WRITE(6,400) KM,SIZE,AK,BK,AMPL,PHAZ - - 100 FORMAT(/,/,5X,'HARMONIC ANALYSIS FOR ',A4,' FIELD, LEVEL = ',I2) - 200 FORMAT(/1X,'MEAN VALUE:',2X,F13.4) - 300 FORMAT(/1X,'WAVENUMBER',3X,'WAVELENGTH', - $ 6X,' COS ',7X,' SIN ',7X,' AMPL ',5X,' PHASE ') - 400 FORMAT(4X,I3,6X,F8.1,6X,F9.3,3X,F9.3,3X,F9.3,3X,F9.3) - RETURN - END diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_grids.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_grids.F deleted file mode 100644 index 4346410d7..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_grids.F +++ /dev/null @@ -1,3253 +0,0 @@ - subroutine rotate_f ( q_geo,q_cmp,im,jm,lm, - . dlam,dphi,rotation,tilt,precession, - . sgn,norder,check,lattice ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute a forward transformation from the geophysical grid to the -C computational grid. -C -C INPUT: -C ====== -C q_geo ...... Field q_geo(im,jm,lm) on the geophysical grid -C im ......... Longitudinal dimension of q_geo -C jm ......... Latitudinal dimension of q_geo -C lm ......... Vertical dimension of q_geo -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C rotation ... Rotation parameter lam_np (Degrees) -C tilt ....... Rotation parameter phi_np (Degrees) -C precession . Rotation parameter lam_0 (Degrees) -C sgn ........ Flag for scalar field ( sgn = 1 ) -C or vector component ( sgn = -1 ) -C norder ..... Order of Interpolation: Bi-Linear => abs(norder) = 1 -C Bi-Cubic => abs(norder) = 3 -C Note: If norder < 0, then check for positive definite -C check ...... Logical Flag to check for Undefined values -C -C OUTPUT: -C ======= -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - include 'mpif.h' - integer status(mpi_status_size) - integer stats(mpi_status_size,0:lattice%nx*lattice%ny-1) - integer statr(mpi_status_size,0:lattice%nx*lattice%ny-1) - - integer sendquest(0:lattice%nx*lattice%ny-1) - integer recvquest(0:lattice%nx*lattice%ny-1) - integer ierror - - integer, allocatable, save :: sendlen(:) ! Number of unique grid-points needed to SEND to other PEs - integer, allocatable, save :: recvlen(:) ! Number of unique grid-points needed to RECV from other PEs - integer, allocatable, save :: sendloc(:,:) ! Global index locations of the grid-points needed to SEND to other PEs - integer, allocatable, save :: recvloc(:,:) ! Global index locations of the grid-points needed to RECV from other PEs - - integer, allocatable :: bucket (:) ! Dummy bucket for array reduction - real(kind=8), allocatable :: sendbuf(:,:) ! Dummy buffer to SEND data - real(kind=8), allocatable :: recvbuf(:,:) ! Dummy buffer to RECV data - -c Input Variables -c --------------- - integer im,jm,lm,norder,sgn - real(kind=8) q_geo(im,jm,lm) - real(kind=8) q_cmp(im,jm,lm) - real(kind=8) dlam(lattice%imglobal) - real(kind=8) dphi(lattice%jmglobal) - real(kind=8) rotation, tilt, precession - logical check - -c Local Variables -c --------------- - integer i,j,l,m,n,sgnjp1 - integer peid, num,sgnjm2 - integer pei_im2 - integer pei_im1 - integer pei_ip0 - integer pei_ip1 - integer pej_jm2 - integer pej_jm1 - integer pej_jp0 - integer pej_jp1 - -c Index Locations -c --------------- - integer, allocatable :: len(:) ! Total number of grid-points needed from other PEs - integer, allocatable :: nn(:,:) ! Mapping from total to unique grid-points - integer, allocatable :: pos(:,:) ! Position index of data to RECV from other PEs - integer, allocatable :: loc(:,:) - - integer, allocatable :: ip1(:,:), ip0(:,:), im1(:,:), im2(:,:) - integer, allocatable :: jp1(:,:), jp0(:,:), jm1(:,:), jm2(:,:) - integer, allocatable :: im2jm2(:,:), im2jm1(:,:), im2jp0(:,:), im2jp1(:,:) - integer, allocatable :: im1jm2(:,:), im1jm1(:,:), im1jp0(:,:), im1jp1(:,:) - integer, allocatable :: ip0jm2(:,:), ip0jm1(:,:), ip0jp0(:,:), ip0jp1(:,:) - integer, allocatable :: ip1jm2(:,:), ip1jm1(:,:), ip1jp0(:,:), ip1jp1(:,:) - integer, allocatable :: pe_im2jm2(:,:), pe_im2jm1(:,:), pe_im2jp0(:,:), pe_im2jp1(:,:) - integer, allocatable :: pe_im1jm2(:,:), pe_im1jm1(:,:), pe_im1jp0(:,:), pe_im1jp1(:,:) - integer, allocatable :: pe_ip0jm2(:,:), pe_ip0jm1(:,:), pe_ip0jp0(:,:), pe_ip0jp1(:,:) - integer, allocatable :: pe_ip1jm2(:,:), pe_ip1jm1(:,:), pe_ip1jp0(:,:), pe_ip1jp1(:,:) - - integer, allocatable, save :: msgn(:,:) - integer, allocatable, save :: nsgn(:,:) - integer, allocatable, save :: n_im2jm2(:,:), n_im2jm1(:,:), n_im2jp0(:,:), n_im2jp1(:,:) - integer, allocatable, save :: n_im1jm2(:,:), n_im1jm1(:,:), n_im1jp0(:,:), n_im1jp1(:,:) - integer, allocatable, save :: n_ip0jm2(:,:), n_ip0jm1(:,:), n_ip0jp0(:,:), n_ip0jp1(:,:) - integer, allocatable, save :: n_ip1jm2(:,:), n_ip1jm1(:,:), n_ip1jp0(:,:), n_ip1jp1(:,:) - integer, allocatable, save :: p_im2jm2(:,:), p_im2jm1(:,:), p_im2jp0(:,:), p_im2jp1(:,:) - integer, allocatable, save :: p_im1jm2(:,:), p_im1jm1(:,:), p_im1jp0(:,:), p_im1jp1(:,:) - integer, allocatable, save :: p_ip0jm2(:,:), p_ip0jm1(:,:), p_ip0jp0(:,:), p_ip0jp1(:,:) - integer, allocatable, save :: p_ip1jm2(:,:), p_ip1jm1(:,:), p_ip1jp0(:,:), p_ip1jp1(:,:) - -c Bi-Linear Weights -c ----------------- - real(kind=8), allocatable, save :: wl_ip0jp0 (:,:) - real(kind=8), allocatable, save :: wl_im1jp0 (:,:) - real(kind=8), allocatable, save :: wl_ip0jm1 (:,:) - real(kind=8), allocatable, save :: wl_im1jm1 (:,:) - -c Bi-Cubic Weights -c ---------------- - real(kind=8), allocatable, save :: wc_ip1jp1 (:,:) - real(kind=8), allocatable, save :: wc_ip0jp1 (:,:) - real(kind=8), allocatable, save :: wc_im1jp1 (:,:) - real(kind=8), allocatable, save :: wc_im2jp1 (:,:) - real(kind=8), allocatable, save :: wc_ip1jp0 (:,:) - real(kind=8), allocatable, save :: wc_ip0jp0 (:,:) - real(kind=8), allocatable, save :: wc_im1jp0 (:,:) - real(kind=8), allocatable, save :: wc_im2jp0 (:,:) - real(kind=8), allocatable, save :: wc_ip1jm1 (:,:) - real(kind=8), allocatable, save :: wc_ip0jm1 (:,:) - real(kind=8), allocatable, save :: wc_im1jm1 (:,:) - real(kind=8), allocatable, save :: wc_im2jm1 (:,:) - real(kind=8), allocatable, save :: wc_ip1jm2 (:,:) - real(kind=8), allocatable, save :: wc_ip0jm2 (:,:) - real(kind=8), allocatable, save :: wc_im1jm2 (:,:) - real(kind=8), allocatable, save :: wc_im2jm2 (:,:) - - real(kind=8), allocatable, save :: old_dlam (:) - real(kind=8), allocatable, save :: old_dphi (:) - - real(kind=8) ux, ap1, ap0, am1, am2 - real(kind=8) uy, bp1, bp0, bm1, bm2 - - real(kind=8) lon_cmp(lattice%imglobal), lon_geo(lattice%imglobal) - real(kind=8) lat_cmp(lattice%jmglobal), lat_geo(lattice%jmglobal) - real(kind=8) pi,cosnp,sinnp,p1,p2,p3,eps,lam,phi,d - real(kind=8) lam1,lam2,phi1,phi2 - real(kind=8) dl,dp,lam_np,phi_np,lam_0,eps_np - real(kind=8) lam_geo, lam_cmp, dlam_max, dlam_min - real(kind=8) phi_geo, phi_cmp, dphi_max, dphi_min - real(kind=8) undef, getcon - integer im1_geo,igeo - integer jm1_geo,jgeo - - logical compute_weights - real(kind=8) old_rotation - real(kind=8) old_tilt - real(kind=8) old_precession - data old_rotation /-999.9/ - data old_tilt /-999.9/ - data old_precession /-999.9/ - - parameter ( eps = 1.e-10 ) - -c Initialization -c -------------- - call my_barrier (lattice%comm) ! Uncomment for more accurate timing - - pi = 4.*atan(1.) - dl = 2*pi/ lattice%imglobal ! Uniform Grid Delta Lambda - dp = pi/(lattice%jmglobal-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - if(.not.allocated(old_dlam)) then - - allocate ( old_dlam(lattice%imglobal) , old_dphi(lattice%jmglobal) ) - allocate ( wl_ip0jp0(im,jm) , wl_im1jp0(im,jm) ) - allocate ( wl_ip0jm1(im,jm) , wl_im1jm1(im,jm) ) - allocate ( wc_ip1jp1(im,jm) , wc_ip0jp1(im,jm) , wc_im1jp1(im,jm) , wc_im2jp1(im,jm) ) - allocate ( wc_ip1jp0(im,jm) , wc_ip0jp0(im,jm) , wc_im1jp0(im,jm) , wc_im2jp0(im,jm) ) - allocate ( wc_ip1jm1(im,jm) , wc_ip0jm1(im,jm) , wc_im1jm1(im,jm) , wc_im2jm1(im,jm) ) - allocate ( wc_ip1jm2(im,jm) , wc_ip0jm2(im,jm) , wc_im1jm2(im,jm) , wc_im2jm2(im,jm) ) - allocate ( msgn(im,jm) , nsgn(im,jm) ) - allocate ( n_im2jm2(im,jm) , n_im1jm2(im,jm) , n_ip0jm2(im,jm) , n_ip1jm2(im,jm) ) - allocate ( n_im2jm1(im,jm) , n_im1jm1(im,jm) , n_ip0jm1(im,jm) , n_ip1jm1(im,jm) ) - allocate ( n_im2jp0(im,jm) , n_im1jp0(im,jm) , n_ip0jp0(im,jm) , n_ip1jp0(im,jm) ) - allocate ( n_im2jp1(im,jm) , n_im1jp1(im,jm) , n_ip0jp1(im,jm) , n_ip1jp1(im,jm) ) - allocate ( p_im2jm2(im,jm) , p_im1jm2(im,jm) , p_ip0jm2(im,jm) , p_ip1jm2(im,jm) ) - allocate ( p_im2jm1(im,jm) , p_im1jm1(im,jm) , p_ip0jm1(im,jm) , p_ip1jm1(im,jm) ) - allocate ( p_im2jp0(im,jm) , p_im1jp0(im,jm) , p_ip0jp0(im,jm) , p_ip1jp0(im,jm) ) - allocate ( p_im2jp1(im,jm) , p_im1jp1(im,jm) , p_ip0jp1(im,jm) , p_ip1jp1(im,jm) ) - allocate ( recvloc(16*im*jm,0:lattice%nx*lattice%ny-1) ) - allocate ( recvlen( 0:lattice%nx*lattice%ny-1) ) - allocate ( sendlen( 0:lattice%nx*lattice%ny-1) ) - allocate ( sendloc( im*jm,0:lattice%nx*lattice%ny-1) ) -c allocate ( sendloc(lattice%imglobal*lattice%jmglobal,0:lattice%nx*lattice%ny-1) ) - - do i=1,lattice%imglobal - old_dlam(i) = 0.0 - enddo - do j=1,lattice%jmglobal - old_dphi(j) = 0.0 - enddo - - else - i = size (old_dlam) - j = size (old_dphi) - if(i.ne.lattice%imglobal .or. j.ne.lattice%jmglobal) then - deallocate ( old_dlam , old_dphi ) - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( msgn , nsgn ) - deallocate ( n_im2jm2 , n_im1jm2 , n_ip0jm2 , n_ip1jm2 ) - deallocate ( n_im2jm1 , n_im1jm1 , n_ip0jm1 , n_ip1jm1 ) - deallocate ( n_im2jp0 , n_im1jp0 , n_ip0jp0 , n_ip1jp0 ) - deallocate ( n_im2jp1 , n_im1jp1 , n_ip0jp1 , n_ip1jp1 ) - deallocate ( p_im2jm2 , p_im1jm2 , p_ip0jm2 , p_ip1jm2 ) - deallocate ( p_im2jm1 , p_im1jm1 , p_ip0jm1 , p_ip1jm1 ) - deallocate ( p_im2jp0 , p_im1jp0 , p_ip0jp0 , p_ip1jp0 ) - deallocate ( p_im2jp1 , p_im1jp1 , p_ip0jp1 , p_ip1jp1 ) - deallocate ( recvloc,recvlen,sendlen,sendloc ) - - allocate ( old_dlam(lattice%imglobal) , old_dphi(lattice%jmglobal) ) - allocate ( wl_ip0jp0(im,jm) , wl_im1jp0(im,jm) ) - allocate ( wl_ip0jm1(im,jm) , wl_im1jm1(im,jm) ) - allocate ( wc_ip1jp1(im,jm) , wc_ip0jp1(im,jm) , wc_im1jp1(im,jm) , wc_im2jp1(im,jm) ) - allocate ( wc_ip1jp0(im,jm) , wc_ip0jp0(im,jm) , wc_im1jp0(im,jm) , wc_im2jp0(im,jm) ) - allocate ( wc_ip1jm1(im,jm) , wc_ip0jm1(im,jm) , wc_im1jm1(im,jm) , wc_im2jm1(im,jm) ) - allocate ( wc_ip1jm2(im,jm) , wc_ip0jm2(im,jm) , wc_im1jm2(im,jm) , wc_im2jm2(im,jm) ) - allocate ( msgn(im,jm) , nsgn(im,jm) ) - allocate ( n_im2jm2(im,jm) , n_im1jm2(im,jm) , n_ip0jm2(im,jm) , n_ip1jm2(im,jm) ) - allocate ( n_im2jm1(im,jm) , n_im1jm1(im,jm) , n_ip0jm1(im,jm) , n_ip1jm1(im,jm) ) - allocate ( n_im2jp0(im,jm) , n_im1jp0(im,jm) , n_ip0jp0(im,jm) , n_ip1jp0(im,jm) ) - allocate ( n_im2jp1(im,jm) , n_im1jp1(im,jm) , n_ip0jp1(im,jm) , n_ip1jp1(im,jm) ) - allocate ( p_im2jm2(im,jm) , p_im1jm2(im,jm) , p_ip0jm2(im,jm) , p_ip1jm2(im,jm) ) - allocate ( p_im2jm1(im,jm) , p_im1jm1(im,jm) , p_ip0jm1(im,jm) , p_ip1jm1(im,jm) ) - allocate ( p_im2jp0(im,jm) , p_im1jp0(im,jm) , p_ip0jp0(im,jm) , p_ip1jp0(im,jm) ) - allocate ( p_im2jp1(im,jm) , p_im1jp1(im,jm) , p_ip0jp1(im,jm) , p_ip1jp1(im,jm) ) - allocate ( recvloc(16*im*jm,0:lattice%nx*lattice%ny-1) ) - allocate ( recvlen( 0:lattice%nx*lattice%ny-1) ) - allocate ( sendlen( 0:lattice%nx*lattice%ny-1) ) - allocate ( sendloc( im*jm,0:lattice%nx*lattice%ny-1) ) - - do i=1,lattice%imglobal - old_dlam(i) = 0.0 - enddo - do j=1,lattice%jmglobal - old_dphi(j) = 0.0 - enddo - endif - endif - - -c Compute Geophysical and Computational Lambda's and Phi's -c -------------------------------------------------------- - lon_geo(1) = -pi - lon_cmp(1) = -pi - do i=2,lattice%imglobal - lon_geo(i) = lon_geo(i-1) + dl - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_geo(1) = -pi*0.5 - lat_cmp(1) = -pi*0.5 - do j=2,lattice%jmglobal-1 - lat_geo(j) = lat_geo(j-1) + dp - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_geo(lattice%jmglobal) = pi*0.5 - lat_cmp(lattice%jmglobal) = pi*0.5 - - -c Check for Co-incident Grid-Point Latitude and Pole Locations -c ------------------------------------------------------------ - eps_np = 0.0 - do j=1,lattice%jmglobal - phi_cmp = lat_cmp(j)*180./pi - if( abs( phi_cmp-tilt ).lt.1.e-3 ) eps_np = 1.e-3 - if( tilt+eps_np .gt. 90. ) eps_np = -1.e-3 - enddo - - d = dl*dp - lam_np = pi/180.*rotation - phi_np = pi/180.*(tilt+eps_np) - lam_0 = pi/180.*precession - - undef = getcon('UNDEF') - if( tilt.eq.90. ) then - cosnp = 0.0 - sinnp = 1.0 - else if(tilt.eq.-90.0) then - cosnp = 0.0 - sinnp =-1.0 - else - cosnp = cos(phi_np) - sinnp = sin(phi_np) - endif - -c Determine if Weights Need to be Updated -c --------------------------------------- - compute_weights = rotation.ne.old_rotation .or. - . tilt.ne.old_tilt .or. - . precession.ne.old_precession - - i = 1 - do while ( .not.compute_weights .and. i.le.lattice%imglobal ) - compute_weights = dlam(i).ne.old_dlam(i) - i = i+1 - enddo - j = 1 - do while ( .not.compute_weights .and. j.le.lattice%jmglobal-1 ) - compute_weights = dphi(j).ne.old_dphi(j) - j = j+1 - enddo - - -c Computing Weights for Geophysical to Computational Grid Interpolation -c --------------------------------------------------------------------- - if( compute_weights ) then - - old_rotation = rotation - old_tilt = tilt - old_precession = precession - - dlam_min = dlam(1) - dlam_max = dlam(1) - do i=1,lattice%imglobal - old_dlam(i) = dlam(i) - if( dlam(i).lt.dlam_min ) dlam_min = dlam(i) - if( dlam(i).gt.dlam_max ) dlam_max = dlam(i) - enddo - dphi_min = dphi(1) - dphi_max = dphi(1) - do j=1,lattice%jmglobal-1 - old_dphi(j) = dphi(j) - if( dphi(j).lt.dphi_min ) dphi_min = dphi(j) - if( dphi(j).gt.dphi_max ) dphi_max = dphi(j) - enddo - old_dphi(lattice%jmglobal) = dphi(lattice%jmglobal) - - if( lattice%myid.eq.0 ) then - print *, 'Computing Weights for Geophysical to Computational Grid Interpolation' - print *, '---------------------------------------------------------------------' - print *, 'lam_np = ',rotation - print *, 'phi_np = ',tilt,' (eps_np = ',eps_np,')' - print *, 'lam_0 = ',precession - print * - print *, 'Longitudinal Stretching Factor: ',dlam_max/dlam_min - print *, ' Latitudinal Stretching Factor: ',dphi_max/dphi_min - print * - print *, ' Rotate_F Communication Matrix' - print *, ' -----------------------------' - endif - - allocate ( nn(16*im*jm,0:lattice%nx*lattice%ny-1) ) - allocate ( pos(16*im*jm,0:lattice%nx*lattice%ny-1) ) - allocate ( loc(16*im*jm,0:lattice%nx*lattice%ny-1) ) - allocate ( len( 0:lattice%nx*lattice%ny-1) ) - - allocate ( ip1(im,jm) , ip0(im,jm) , im1(im,jm) , im2(im,jm) ) - allocate ( jp1(im,jm) , jp0(im,jm) , jm1(im,jm) , jm2(im,jm) ) - allocate ( im2jm2(im,jm) , im1jm2(im,jm) , ip0jm2(im,jm) , ip1jm2(im,jm) ) - allocate ( im2jm1(im,jm) , im1jm1(im,jm) , ip0jm1(im,jm) , ip1jm1(im,jm) ) - allocate ( im2jp0(im,jm) , im1jp0(im,jm) , ip0jp0(im,jm) , ip1jp0(im,jm) ) - allocate ( im2jp1(im,jm) , im1jp1(im,jm) , ip0jp1(im,jm) , ip1jp1(im,jm) ) - allocate ( pe_im2jm2(im,jm) , pe_im1jm2(im,jm) , pe_ip0jm2(im,jm) , pe_ip1jm2(im,jm) ) - allocate ( pe_im2jm1(im,jm) , pe_im1jm1(im,jm) , pe_ip0jm1(im,jm) , pe_ip1jm1(im,jm) ) - allocate ( pe_im2jp0(im,jm) , pe_im1jp0(im,jm) , pe_ip0jp0(im,jm) , pe_ip1jp0(im,jm) ) - allocate ( pe_im2jp1(im,jm) , pe_im1jp1(im,jm) , pe_ip0jp1(im,jm) , pe_ip1jp1(im,jm) ) - - do j=1,jm - do i=1,im - lam_cmp = lon_cmp( lattice%iglobal(i) ) - phi_cmp = lat_cmp( lattice%jglobal(j) ) - - p1 = cosnp*cos(phi_cmp)*cos(lam_cmp-lam_np) - . + sin(phi_cmp)*sinnp - p1 = min(p1, 1.0) - p1 = max(p1,-1.0) - phi_geo = asin( p1 ) - - if( tilt.eq.90.0 .or. tilt.eq.-90.0 ) then - p2 = sinnp*cos(lam_cmp-lam_np) - else - p2 = sinnp*cos(phi_cmp)*cos(lam_cmp-lam_np) - . - sin(phi_cmp)*cosnp - p2 = p2 / max( cos(phi_geo),eps ) - p2 = min(p2, 1.0) - p2 = max(p2,-1.0) - endif - p2 = acos( p2 ) - - p3 = cos(phi_cmp)*sin(lam_cmp-lam_np) - if( p3.lt.0.0 ) p2 = -p2 - p2 = p2 - lam_0 - lam_geo = mod( p2+3.0*pi,2.0*pi ) - pi - -c Determine (i,j) Indexing Based on Geophysical Grid -c -------------------------------------------------- - im1_geo = 1 - do igeo = 2,lattice%imglobal - if( lon_geo(igeo).lt.lam_geo ) im1_geo = igeo - enddo - jm1_geo = 1 - do jgeo = 2,lattice%jmglobal - if( lat_geo(jgeo).lt.phi_geo ) jm1_geo = jgeo - enddo - - im1(i,j) = im1_geo - ip0(i,j) = im1(i,j) + 1 - ip1(i,j) = ip0(i,j) + 1 - im2(i,j) = im1(i,j) - 1 - - jm1(i,j) = jm1_geo - jp0(i,j) = jm1(i,j) + 1 - jp1(i,j) = jp0(i,j) + 1 - jm2(i,j) = jm1(i,j) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i,j).eq.lattice%imglobal) then - ip0(i,j) = 1 - ip1(i,j) = 2 - endif - if(im1(i,j).eq.1) then - im2(i,j) = lattice%imglobal - endif - if(ip0(i,j).eq.lattice%imglobal) then - ip1(i,j) = 1 - endif - -c Compute ij index -c ---------------- - msgn(i,j) = 2 - if( jp0(i,j).eq.lattice%jmglobal ) then - jp1(i,j) = lattice%jmglobal-1 - ip1jp1(i,j) = 1+mod(ip1(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jp1(i,j)-1 )*lattice%imglobal - ip0jp1(i,j) = 1+mod(ip0(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jp1(i,j)-1 )*lattice%imglobal - im1jp1(i,j) = 1+mod(im1(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jp1(i,j)-1 )*lattice%imglobal - im2jp1(i,j) = 1+mod(im2(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jp1(i,j)-1 )*lattice%imglobal - msgn(i,j) = 1 - else - ip1jp1(i,j) = ip1(i,j) + ( jp1(i,j)-1 )*lattice%imglobal - ip0jp1(i,j) = ip0(i,j) + ( jp1(i,j)-1 )*lattice%imglobal - im1jp1(i,j) = im1(i,j) + ( jp1(i,j)-1 )*lattice%imglobal - im2jp1(i,j) = im2(i,j) + ( jp1(i,j)-1 )*lattice%imglobal - endif - - ip1jp0(i,j) = ip1(i,j) + ( jp0(i,j)-1 )*lattice%imglobal - ip0jp0(i,j) = ip0(i,j) + ( jp0(i,j)-1 )*lattice%imglobal - im1jp0(i,j) = im1(i,j) + ( jp0(i,j)-1 )*lattice%imglobal - im2jp0(i,j) = im2(i,j) + ( jp0(i,j)-1 )*lattice%imglobal - - ip1jm1(i,j) = ip1(i,j) + ( jm1(i,j)-1 )*lattice%imglobal - ip0jm1(i,j) = ip0(i,j) + ( jm1(i,j)-1 )*lattice%imglobal - im1jm1(i,j) = im1(i,j) + ( jm1(i,j)-1 )*lattice%imglobal - im2jm1(i,j) = im2(i,j) + ( jm1(i,j)-1 )*lattice%imglobal - - nsgn(i,j) = 2 - if( jm1(i,j).eq.1 ) then - jm2(i,j) = 2 - ip1jm2(i,j) = 1+mod(ip1(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jm2(i,j)-1 )*lattice%imglobal - ip0jm2(i,j) = 1+mod(ip0(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jm2(i,j)-1 )*lattice%imglobal - im1jm2(i,j) = 1+mod(im1(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jm2(i,j)-1 )*lattice%imglobal - im2jm2(i,j) = 1+mod(im2(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jm2(i,j)-1 )*lattice%imglobal - nsgn(i,j) = 1 - else - ip1jm2(i,j) = ip1(i,j) + ( jm2(i,j)-1 )*lattice%imglobal - ip0jm2(i,j) = ip0(i,j) + ( jm2(i,j)-1 )*lattice%imglobal - im1jm2(i,j) = im1(i,j) + ( jm2(i,j)-1 )*lattice%imglobal - im2jm2(i,j) = im2(i,j) + ( jm2(i,j)-1 )*lattice%imglobal - endif - -c Determine PE location of Source Data -c ------------------------------------ - pej_jp1 = lattice%pejglobal( jp1(i,j) ) - pej_jp0 = lattice%pejglobal( jp0(i,j) ) - pej_jm1 = lattice%pejglobal( jm1(i,j) ) - pej_jm2 = lattice%pejglobal( jm2(i,j) ) - - pei_ip1 = lattice%peiglobal( ip1(i,j) ) - pei_ip0 = lattice%peiglobal( ip0(i,j) ) - pei_im1 = lattice%peiglobal( im1(i,j) ) - pei_im2 = lattice%peiglobal( im2(i,j) ) - - pe_ip1jp0(i,j) = pei_ip1 + pej_jp0*lattice%nx - pe_ip0jp0(i,j) = pei_ip0 + pej_jp0*lattice%nx - pe_im1jp0(i,j) = pei_im1 + pej_jp0*lattice%nx - pe_im2jp0(i,j) = pei_im2 + pej_jp0*lattice%nx - - pe_ip1jm1(i,j) = pei_ip1 + pej_jm1*lattice%nx - pe_ip0jm1(i,j) = pei_ip0 + pej_jm1*lattice%nx - pe_im1jm1(i,j) = pei_im1 + pej_jm1*lattice%nx - pe_im2jm1(i,j) = pei_im2 + pej_jm1*lattice%nx - - n = 1 + (ip1jp1(i,j)-1)/lattice%imglobal - m = ip1jp1(i,j) - (n-1)*lattice%imglobal - pei_ip1 = lattice%peiglobal( m ) - n = 1 + (ip0jp1(i,j)-1)/lattice%imglobal - m = ip0jp1(i,j) - (n-1)*lattice%imglobal - pei_ip0 = lattice%peiglobal( m ) - n = 1 + (im1jp1(i,j)-1)/lattice%imglobal - m = im1jp1(i,j) - (n-1)*lattice%imglobal - pei_im1 = lattice%peiglobal( m ) - n = 1 + (im2jp1(i,j)-1)/lattice%imglobal - m = im2jp1(i,j) - (n-1)*lattice%imglobal - pei_im2 = lattice%peiglobal( m ) - - pe_ip1jp1(i,j) = pei_ip1 + pej_jp1*lattice%nx - pe_ip0jp1(i,j) = pei_ip0 + pej_jp1*lattice%nx - pe_im1jp1(i,j) = pei_im1 + pej_jp1*lattice%nx - pe_im2jp1(i,j) = pei_im2 + pej_jp1*lattice%nx - - n = 1 + (ip1jm2(i,j)-1)/lattice%imglobal - m = ip1jm2(i,j) - (n-1)*lattice%imglobal - pei_ip1 = lattice%peiglobal( m ) - n = 1 + (ip0jm2(i,j)-1)/lattice%imglobal - m = ip0jm2(i,j) - (n-1)*lattice%imglobal - pei_ip0 = lattice%peiglobal( m ) - n = 1 + (im1jm2(i,j)-1)/lattice%imglobal - m = im1jm2(i,j) - (n-1)*lattice%imglobal - pei_im1 = lattice%peiglobal( m ) - n = 1 + (im2jm2(i,j)-1)/lattice%imglobal - m = im2jm2(i,j) - (n-1)*lattice%imglobal - pei_im2 = lattice%peiglobal( m ) - - pe_ip1jm2(i,j) = pei_ip1 + pej_jm2*lattice%nx - pe_ip0jm2(i,j) = pei_ip0 + pej_jm2*lattice%nx - pe_im1jm2(i,j) = pei_im1 + pej_jm2*lattice%nx - pe_im2jm2(i,j) = pei_im2 + pej_jm2*lattice%nx - -c Compute Immediate Surrounding Coordinates on Uniform Grid -c --------------------------------------------------------- - lam = lam_geo - phi = phi_geo - lam1 = -pi + (im1(i,j)-1)*dl - phi1 = -pi*0.5 + (jm1(i,j)-1)*dp - lam2 = lam1 + dl - phi2 = phi1 + dp - -c Bi-Linear Weights -c ----------------- - wl_im1jm1(i,j) = (lam2-lam)*(phi2-phi)/d - wl_ip0jm1(i,j) = (lam-lam1)*(phi2-phi)/d - wl_im1jp0(i,j) = (lam2-lam)*(phi-phi1)/d - wl_ip0jp0(i,j) = (lam-lam1)*(phi-phi1)/d - -c Bi-Cubic Weights -c ---------------- - ux = (lam2-lam)/dl - uy = (phi2-phi)/dp - - ap1 = -ux*(ux-1)*(ux-2)/6. - ap0 = (ux-1)*(ux-2)*(ux+1)/2. - am1 = -ux*(ux+1)*(ux-2)/2. - am2 = ux*(ux-1)*(ux+1)/6. - - bp1 = -uy*(uy-1)*(uy-2)/6. - bp0 = (uy-1)*(uy-2)*(uy+1)/2. - bm1 = -uy*(uy+1)*(uy-2)/2. - bm2 = uy*(uy-1)*(uy+1)/6. - - wc_ip1jp1(i,j) = bp1*ap1 - wc_ip0jp1(i,j) = bp1*ap0 - wc_im1jp1(i,j) = bp1*am1 - wc_im2jp1(i,j) = bp1*am2 - - wc_ip1jp0(i,j) = bp0*ap1 - wc_ip0jp0(i,j) = bp0*ap0 - wc_im1jp0(i,j) = bp0*am1 - wc_im2jp0(i,j) = bp0*am2 - - wc_ip1jm1(i,j) = bm1*ap1 - wc_ip0jm1(i,j) = bm1*ap0 - wc_im1jm1(i,j) = bm1*am1 - wc_im2jm1(i,j) = bm1*am2 - - wc_ip1jm2(i,j) = bm2*ap1 - wc_ip0jm2(i,j) = bm2*ap0 - wc_im1jm2(i,j) = bm2*am1 - wc_im2jm2(i,j) = bm2*am2 - - enddo - enddo - -c Create Data Index Array for Total and Non-Redundant Data -c Note: recvlen(peid): is the total number of unique grid-points needed from a given peid -c ----- recvloc(m,peid): is a list of the global locations of those points -c ------------------------------------------------------------------------- - allocate ( bucket(16*lattice%imglobal*lattice%jmglobal) ) - do peid = 0,lattice%nx*lattice%ny-1 - num = 0 - do j=1,jm - do i=1,im - if ( pe_im2jm2(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im2jm2(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_im1jm2(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im1jm2(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip0jm2(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip0jm2(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip1jm2(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip1jm2(i,j) - pos(num,peid) = i+(j-1)*im - endif - - if ( pe_im2jm1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im2jm1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_im1jm1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im1jm1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip0jm1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip0jm1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip1jm1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip1jm1(i,j) - pos(num,peid) = i+(j-1)*im - endif - - if ( pe_im2jp0(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im2jp0(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_im1jp0(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im1jp0(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip0jp0(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip0jp0(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip1jp0(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip1jp0(i,j) - pos(num,peid) = i+(j-1)*im - endif - - if ( pe_im2jp1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im2jp1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_im1jp1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im1jp1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip0jp1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip0jp1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip1jp1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip1jp1(i,j) - pos(num,peid) = i+(j-1)*im - endif - enddo - enddo - len(peid) = num - -c Strip redundancies from buffer -c ------------------------------ - m = 0 - if( num.ne.0 ) then - bucket(:) = 0 - do i=1,num - bucket( loc(i,peid) ) = 1 - enddo - do i=1,16*lattice%imglobal*lattice%jmglobal - if( bucket(i).eq.1 ) then - m = m+1 - recvloc(m,peid) = i - bucket (i) = m - endif - enddo - do i=1,num - nn(i,peid) = bucket( loc(i,peid) ) - enddo - endif - - recvlen(peid) = m - enddo - deallocate ( bucket ) - -c Store buffer locations -c ---------------------- - do peid = 0,lattice%nx*lattice%ny-1 - do m = 1,len(peid) - n = nn (m,peid) - j = 1 + (pos(m,peid)-1)/im - i = pos(m,peid) - (j-1)*im - if( recvloc(n,peid).eq.ip1jp1(i,j) ) then - n_ip1jp1(i,j) = n - p_ip1jp1(i,j) = peid - endif - if( recvloc(n,peid).eq.ip0jp1(i,j) ) then - n_ip0jp1(i,j) = n - p_ip0jp1(i,j) = peid - endif - if( recvloc(n,peid).eq.im1jp1(i,j) ) then - n_im1jp1(i,j) = n - p_im1jp1(i,j) = peid - endif - if( recvloc(n,peid).eq.im2jp1(i,j) ) then - n_im2jp1(i,j) = n - p_im2jp1(i,j) = peid - endif - - if( recvloc(n,peid).eq.ip1jp0(i,j) ) then - n_ip1jp0(i,j) = n - p_ip1jp0(i,j) = peid - endif - if( recvloc(n,peid).eq.ip0jp0(i,j) ) then - n_ip0jp0(i,j) = n - p_ip0jp0(i,j) = peid - endif - if( recvloc(n,peid).eq.im1jp0(i,j) ) then - n_im1jp0(i,j) = n - p_im1jp0(i,j) = peid - endif - if( recvloc(n,peid).eq.im2jp0(i,j) ) then - n_im2jp0(i,j) = n - p_im2jp0(i,j) = peid - endif - - if( recvloc(n,peid).eq.ip1jm1(i,j) ) then - n_ip1jm1(i,j) = n - p_ip1jm1(i,j) = peid - endif - if( recvloc(n,peid).eq.ip0jm1(i,j) ) then - n_ip0jm1(i,j) = n - p_ip0jm1(i,j) = peid - endif - if( recvloc(n,peid).eq.im1jm1(i,j) ) then - n_im1jm1(i,j) = n - p_im1jm1(i,j) = peid - endif - if( recvloc(n,peid).eq.im2jm1(i,j) ) then - n_im2jm1(i,j) = n - p_im2jm1(i,j) = peid - endif - - if( recvloc(n,peid).eq.ip1jm2(i,j) ) then - n_ip1jm2(i,j) = n - p_ip1jm2(i,j) = peid - endif - if( recvloc(n,peid).eq.ip0jm2(i,j) ) then - n_ip0jm2(i,j) = n - p_ip0jm2(i,j) = peid - endif - if( recvloc(n,peid).eq.im1jm2(i,j) ) then - n_im1jm2(i,j) = n - p_im1jm2(i,j) = peid - endif - if( recvloc(n,peid).eq.im2jm2(i,j) ) then - n_im2jm2(i,j) = n - p_im2jm2(i,j) = peid - endif - enddo - enddo - -c Send and Recv the data length needed for interpolation -c ------------------------------------------------------ - do peid = 0,lattice%nx*lattice%ny-1 - if( lattice%myid.ne.peid ) then - - call mpi_isend ( recvlen(peid),1,mpi_integer,peid,peid,lattice%comm,sendquest(peid),ierror ) - - else - sendquest(peid) = mpi_request_null - endif - enddo - - do peid = 0,lattice%nx*lattice%ny-1 - if( lattice%myid.ne.peid ) then - - call mpi_irecv ( sendlen(peid),1,mpi_integer,peid,lattice%myid,lattice%comm,recvquest(peid),ierror ) - - else - sendlen(peid) = recvlen(peid) - recvquest(peid) = mpi_request_null - endif - enddo - - call mpi_waitall ( lattice%nx*lattice%ny,sendquest(0:lattice%nx*lattice%ny-1),stats(1,0),ierror ) - call mpi_waitall ( lattice%nx*lattice%ny,recvquest(0:lattice%nx*lattice%ny-1),statr(1,0),ierror ) - -c Send and Recv the data locations needed for interpolation -c --------------------------------------------------------- - do peid = 0,lattice%nx*lattice%ny-1 - sendquest(peid) = mpi_request_null - if( lattice%myid.ne.peid ) then - if( recvlen(peid).ne.0 ) then - - call mpi_isend ( recvloc(1,peid),recvlen(peid),mpi_integer,peid,peid,lattice%comm,sendquest(peid),ierror ) - - endif - endif - enddo - - do peid = 0,lattice%nx*lattice%ny-1 - recvquest(peid) = mpi_request_null - if( sendlen(peid).ne.0 ) then - if( lattice%myid.ne.peid ) then - - call mpi_irecv ( sendloc(1,peid),sendlen(peid),mpi_integer,peid,lattice%myid,lattice%comm,recvquest(peid),ierror ) - - else - do n=1,sendlen(peid) - sendloc(n,peid) = recvloc(n,peid) - enddo - endif - endif - enddo - - call mpi_waitall ( lattice%nx*lattice%ny,sendquest(0:lattice%nx*lattice%ny-1),stats(1,0),ierror ) - call mpi_waitall ( lattice%nx*lattice%ny,recvquest(0:lattice%nx*lattice%ny-1),statr(1,0),ierror ) - -c Print Communication Matrix -c -------------------------- - do n=0,lattice%nx*lattice%ny-1 - if( n.eq.lattice%myid ) then - write(6,1001) (sendlen(m),m=0,lattice%nx*lattice%ny-1) - endif - call my_barrier (lattice%comm) - enddo - if( lattice%myid.eq.lattice%nx*lattice%ny-1 ) print * - 1001 format(128(1x,i4)) - - deallocate ( nn,pos,loc,len ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - deallocate ( im2jm2 , im1jm2 , ip0jm2 , ip1jm2 ) - deallocate ( im2jm1 , im1jm1 , ip0jm1 , ip1jm1 ) - deallocate ( im2jp0 , im1jp0 , ip0jp0 , ip1jp0 ) - deallocate ( im2jp1 , im1jp1 , ip0jp1 , ip1jp1 ) - deallocate ( pe_im2jm2 , pe_im1jm2 , pe_ip0jm2 , pe_ip1jm2 ) - deallocate ( pe_im2jm1 , pe_im1jm1 , pe_ip0jm1 , pe_ip1jm1 ) - deallocate ( pe_im2jp0 , pe_im1jp0 , pe_ip0jp0 , pe_ip1jp0 ) - deallocate ( pe_im2jp1 , pe_im1jp1 , pe_ip0jp1 , pe_ip1jp1 ) - - endif ! End compute_weights check - - -C*********************************************************************** -C* Begin Rotate Interpolation * -C*********************************************************************** - -c Send and Recv the data needed for interpolation -c ----------------------------------------------- - allocate ( sendbuf(im*jm*lm ,0:lattice%nx*lattice%ny-1) ) - allocate ( recvbuf(lattice%imax*lattice%jmax*lm,0:lattice%nx*lattice%ny-1) ) - - do peid = 0,lattice%nx*lattice%ny-1 - sendquest(peid) = mpi_request_null - if( sendlen(peid).ne.0 ) then - if( lattice%myid.ne.peid ) then - - m = 0 - do n = 1,sendlen(peid) - j = 1 + (sendloc(n,peid)-1)/lattice%imglobal - i = sendloc(n,peid) - (j-1)*lattice%imglobal - do L = 1,lm - m = m+1 - sendbuf(m,peid) = q_geo( lattice%ilocal(i),lattice%jlocal(j),L ) - enddo - enddo - call mpi_isend ( sendbuf(1,peid),m,mpi_double_precision,peid,peid,lattice%comm, - . sendquest(peid),ierror ) - - else - m = 0 - do n = 1,sendlen(peid) - j = 1 + (sendloc(n,peid)-1)/lattice%imglobal - i = sendloc(n,peid) - (j-1)*lattice%imglobal - do L = 1,lm - m = m+1 - recvbuf(m,peid) = q_geo( lattice%ilocal(i),lattice%jlocal(j),L ) - enddo - enddo - endif - endif - enddo - - do peid = 0,lattice%nx*lattice%ny-1 - recvquest(peid) = mpi_request_null - if( lattice%myid.ne.peid ) then - if( recvlen(peid).ne.0 ) then - - call mpi_irecv ( recvbuf(1,peid),recvlen(peid)*lm,mpi_double_precision,peid,lattice%myid,lattice%comm, - . recvquest(peid),ierror ) - - endif - endif - enddo - - call mpi_waitall ( lattice%nx*lattice%ny,sendquest(0:lattice%nx*lattice%ny-1),stats(1,0),ierror ) - call mpi_waitall ( lattice%nx*lattice%ny,recvquest(0:lattice%nx*lattice%ny-1),statr(1,0),ierror ) - -c Interpolate Geophysical Quantities to Computational Grid Using Bi-Linear -c ------------------------------------------------------------------------ - if( abs(norder).eq.1 ) then - - if( check ) then - do j=1,jm - do i=1,im - do L=1,lm - if( recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ).ne.undef ) then - q_cmp(i,j,L) = wl_im1jm1(i,j) * recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ) - . + wl_ip0jm1(i,j) * recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ) - . + wl_im1jp0(i,j) * recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ) - . + wl_ip0jp0(i,j) * recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ) - else - q_cmp(i,j,L) = undef - endif - enddo - enddo - enddo - endif ! End UNDEF Check - - if( .not.check ) then - do j=1,jm - do i=1,im - do L=1,lm - q_cmp(i,j,L) = wl_im1jm1(i,j) * recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ) - . + wl_ip0jm1(i,j) * recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ) - . + wl_im1jp0(i,j) * recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ) - . + wl_ip0jp0(i,j) * recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ) - enddo - enddo - enddo - endif ! End UNDEF Check - - endif ! End Check for Bi-Linear Interpolation - -c Interpolate Geophysical Quantities to Computational Grid Using Bi-Cubic -c ----------------------------------------------------------------------- - if( abs(norder).eq.3 ) then - - if( check ) then - do j=1,jm - do i=1,im - sgnjp1 = sgn**msgn(i,j) - sgnjm2 = sgn**nsgn(i,j) - do L=1,lm - - if( recvbuf( L+(n_ip1jp1(i,j)-1)*lm,p_ip1jp1(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jp1(i,j)-1)*lm,p_ip0jp1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jp1(i,j)-1)*lm,p_im1jp1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im2jp1(i,j)-1)*lm,p_im2jp1(i,j) ).ne.undef .and. - - . recvbuf( L+(n_ip1jp0(i,j)-1)*lm,p_ip1jp0(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ).ne.undef .and. - . recvbuf( L+(n_im2jp0(i,j)-1)*lm,p_im2jp0(i,j) ).ne.undef .and. - - . recvbuf( L+(n_ip1jm1(i,j)-1)*lm,p_ip1jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im2jm1(i,j)-1)*lm,p_im2jm1(i,j) ).ne.undef .and. - - . recvbuf( L+(n_ip1jm2(i,j)-1)*lm,p_ip1jm2(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jm2(i,j)-1)*lm,p_ip0jm2(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jm2(i,j)-1)*lm,p_im1jm2(i,j) ).ne.undef .and. - . recvbuf( L+(n_im2jm2(i,j)-1)*lm,p_im2jm2(i,j) ).ne.undef ) then - - q_cmp(i,j,L) = wc_ip1jp1(i,j) * recvbuf( L+(n_ip1jp1(i,j)-1)*lm,p_ip1jp1(i,j) )*sgnjp1 - . + wc_ip0jp1(i,j) * recvbuf( L+(n_ip0jp1(i,j)-1)*lm,p_ip0jp1(i,j) )*sgnjp1 - . + wc_im1jp1(i,j) * recvbuf( L+(n_im1jp1(i,j)-1)*lm,p_im1jp1(i,j) )*sgnjp1 - . + wc_im2jp1(i,j) * recvbuf( L+(n_im2jp1(i,j)-1)*lm,p_im2jp1(i,j) )*sgnjp1 - - . + wc_ip1jp0(i,j) * recvbuf( L+(n_ip1jp0(i,j)-1)*lm,p_ip1jp0(i,j) ) - . + wc_ip0jp0(i,j) * recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ) - . + wc_im1jp0(i,j) * recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ) - . + wc_im2jp0(i,j) * recvbuf( L+(n_im2jp0(i,j)-1)*lm,p_im2jp0(i,j) ) - - . + wc_ip1jm1(i,j) * recvbuf( L+(n_ip1jm1(i,j)-1)*lm,p_ip1jm1(i,j) ) - . + wc_ip0jm1(i,j) * recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ) - . + wc_im1jm1(i,j) * recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ) - . + wc_im2jm1(i,j) * recvbuf( L+(n_im2jm1(i,j)-1)*lm,p_im2jm1(i,j) ) - - . + wc_ip1jm2(i,j) * recvbuf( L+(n_ip1jm2(i,j)-1)*lm,p_ip1jm2(i,j) )*sgnjm2 - . + wc_ip0jm2(i,j) * recvbuf( L+(n_ip0jm2(i,j)-1)*lm,p_ip0jm2(i,j) )*sgnjm2 - . + wc_im1jm2(i,j) * recvbuf( L+(n_im1jm2(i,j)-1)*lm,p_im1jm2(i,j) )*sgnjm2 - . + wc_im2jm2(i,j) * recvbuf( L+(n_im2jm2(i,j)-1)*lm,p_im2jm2(i,j) )*sgnjm2 - - elseif( recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ).ne.undef ) then - - q_cmp(i,j,L) = wl_im1jm1(i,j) * recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ) - . + wl_ip0jm1(i,j) * recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ) - . + wl_im1jp0(i,j) * recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ) - . + wl_ip0jp0(i,j) * recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ) - - else - q_cmp(i,j,L) = undef - endif - -c Check for Positive Definite -c --------------------------- - if( norder.lt.0 ) then - if( q_cmp(i,j,L).ne.undef .and. q_cmp(i,j,L).lt.0.0 ) q_cmp(i,j,L) = 0.0 - endif - - enddo ! End L Loop - enddo ! End i Loop - enddo ! End j Loop - - endif ! End UNDEF Check - - if( .not.check ) then - do j=1,jm - do i=1,im - sgnjp1 = sgn**msgn(i,j) - sgnjm2 = sgn**nsgn(i,j) - do L=1,lm - - q_cmp(i,j,L) = wc_ip1jp1(i,j) * recvbuf( L+(n_ip1jp1(i,j)-1)*lm,p_ip1jp1(i,j) )*sgnjp1 - . + wc_ip0jp1(i,j) * recvbuf( L+(n_ip0jp1(i,j)-1)*lm,p_ip0jp1(i,j) )*sgnjp1 - . + wc_im1jp1(i,j) * recvbuf( L+(n_im1jp1(i,j)-1)*lm,p_im1jp1(i,j) )*sgnjp1 - . + wc_im2jp1(i,j) * recvbuf( L+(n_im2jp1(i,j)-1)*lm,p_im2jp1(i,j) )*sgnjp1 - - . + wc_ip1jp0(i,j) * recvbuf( L+(n_ip1jp0(i,j)-1)*lm,p_ip1jp0(i,j) ) - . + wc_ip0jp0(i,j) * recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ) - . + wc_im1jp0(i,j) * recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ) - . + wc_im2jp0(i,j) * recvbuf( L+(n_im2jp0(i,j)-1)*lm,p_im2jp0(i,j) ) - - . + wc_ip1jm1(i,j) * recvbuf( L+(n_ip1jm1(i,j)-1)*lm,p_ip1jm1(i,j) ) - . + wc_ip0jm1(i,j) * recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ) - . + wc_im1jm1(i,j) * recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ) - . + wc_im2jm1(i,j) * recvbuf( L+(n_im2jm1(i,j)-1)*lm,p_im2jm1(i,j) ) - - . + wc_ip1jm2(i,j) * recvbuf( L+(n_ip1jm2(i,j)-1)*lm,p_ip1jm2(i,j) )*sgnjm2 - . + wc_ip0jm2(i,j) * recvbuf( L+(n_ip0jm2(i,j)-1)*lm,p_ip0jm2(i,j) )*sgnjm2 - . + wc_im1jm2(i,j) * recvbuf( L+(n_im1jm2(i,j)-1)*lm,p_im1jm2(i,j) )*sgnjm2 - . + wc_im2jm2(i,j) * recvbuf( L+(n_im2jm2(i,j)-1)*lm,p_im2jm2(i,j) )*sgnjm2 - -c Check for Positive Definite -c --------------------------- - if( norder.lt.0 ) then - if( q_cmp(i,j,L).ne.undef .and. q_cmp(i,j,L).lt.0.0 ) q_cmp(i,j,L) = 0.0 - endif - - enddo ! End L Loop - enddo ! End i Loop - enddo ! End j Loop - - endif ! End UNDEF Check - endif ! End Check for Bi-Cubic Interpolation - - deallocate ( sendbuf ) - deallocate ( recvbuf ) - - return - end - - subroutine rotate_b ( q_cmp,q_geo,im,jm,lm, - . dlam,dphi,rotation,tilt,precession, - . sgn,norder,check,lattice ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Compute a backward transformation from the computational grid to the -C geophysical grid. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C rotation ... Rotation parameter lam_np (Degrees) -C tilt ....... Rotation parameter phi_np (Degrees) -C precession . Rotation parameter lam_0 (Degrees) -C sgn ........ Flag for scalar field ( msgn = 1 ) -C or vector component ( msgn = -1 ) -C norder ..... Order of Interpolation: Bi-Linear => abs(norder) = 1 -C Bi-Cubic => abs(norder) = 3 -C Note: If norder < 0, then check for positive definite -C check ...... Logical Flag to check for Undefined values -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(im,jm,lm) on the geophysical grid -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - include 'mpif.h' - integer status(mpi_status_size) - integer stats(mpi_status_size,0:lattice%nx*lattice%ny-1) - integer statr(mpi_status_size,0:lattice%nx*lattice%ny-1) - - integer sendquest(0:lattice%nx*lattice%ny-1) - integer recvquest(0:lattice%nx*lattice%ny-1) - - integer ierror - integer, allocatable, save :: sendlen(:) ! Number of unique grid-points needed to SEND to other PEs - integer, allocatable, save :: recvlen(:) ! Number of unique grid-points needed to RECV from other PEs - integer, allocatable, save :: sendloc(:,:) ! Global index locations of the grid-points needed to SEND to other PEs - integer, allocatable, save :: recvloc(:,:) ! Global index locations of the grid-points needed to RECV from other PEs - - integer, allocatable :: bucket (:) ! Dummy bucket for array reduction - real(kind=8), allocatable :: sendbuf(:,:) ! Dummy buffer to SEND data - real(kind=8), allocatable :: recvbuf(:,:) ! Dummy buffer to RECV data - -c Input Variables -c --------------- - integer im,jm,lm,norder,sgn - real(kind=8) q_geo(im,jm,lm) - real(kind=8) q_cmp(im,jm,lm) - real(kind=8) dlam(lattice%imglobal) - real(kind=8) dphi(lattice%jmglobal) - real(kind=8) rotation, tilt, precession - logical check - -c Local Variables -c --------------- - integer i,j,l,m,n,sgnjp1 - integer peid, num,sgnjm2 - integer pei_im2 - integer pei_im1 - integer pei_ip0 - integer pei_ip1 - integer pej_jm2 - integer pej_jm1 - integer pej_jp0 - integer pej_jp1 - -c Index Locations -c --------------- - integer, allocatable :: len(:) ! Total number of grid-points needed from other PEs - integer, allocatable :: nn(:,:) ! Mapping from total to unique grid-points - integer, allocatable :: pos(:,:) ! Position index of data to RECV from other PEs - integer, allocatable :: loc(:,:) - - integer, allocatable :: ip1(:,:), ip0(:,:), im1(:,:), im2(:,:) - integer, allocatable :: jp1(:,:), jp0(:,:), jm1(:,:), jm2(:,:) - integer, allocatable :: im2jm2(:,:), im2jm1(:,:), im2jp0(:,:), im2jp1(:,:) - integer, allocatable :: im1jm2(:,:), im1jm1(:,:), im1jp0(:,:), im1jp1(:,:) - integer, allocatable :: ip0jm2(:,:), ip0jm1(:,:), ip0jp0(:,:), ip0jp1(:,:) - integer, allocatable :: ip1jm2(:,:), ip1jm1(:,:), ip1jp0(:,:), ip1jp1(:,:) - integer, allocatable :: pe_im2jm2(:,:), pe_im2jm1(:,:), pe_im2jp0(:,:), pe_im2jp1(:,:) - integer, allocatable :: pe_im1jm2(:,:), pe_im1jm1(:,:), pe_im1jp0(:,:), pe_im1jp1(:,:) - integer, allocatable :: pe_ip0jm2(:,:), pe_ip0jm1(:,:), pe_ip0jp0(:,:), pe_ip0jp1(:,:) - integer, allocatable :: pe_ip1jm2(:,:), pe_ip1jm1(:,:), pe_ip1jp0(:,:), pe_ip1jp1(:,:) - - integer, allocatable, save :: msgn(:,:) - integer, allocatable, save :: nsgn(:,:) - integer, allocatable, save :: n_im2jm2(:,:), n_im2jm1(:,:), n_im2jp0(:,:), n_im2jp1(:,:) - integer, allocatable, save :: n_im1jm2(:,:), n_im1jm1(:,:), n_im1jp0(:,:), n_im1jp1(:,:) - integer, allocatable, save :: n_ip0jm2(:,:), n_ip0jm1(:,:), n_ip0jp0(:,:), n_ip0jp1(:,:) - integer, allocatable, save :: n_ip1jm2(:,:), n_ip1jm1(:,:), n_ip1jp0(:,:), n_ip1jp1(:,:) - integer, allocatable, save :: p_im2jm2(:,:), p_im2jm1(:,:), p_im2jp0(:,:), p_im2jp1(:,:) - integer, allocatable, save :: p_im1jm2(:,:), p_im1jm1(:,:), p_im1jp0(:,:), p_im1jp1(:,:) - integer, allocatable, save :: p_ip0jm2(:,:), p_ip0jm1(:,:), p_ip0jp0(:,:), p_ip0jp1(:,:) - integer, allocatable, save :: p_ip1jm2(:,:), p_ip1jm1(:,:), p_ip1jp0(:,:), p_ip1jp1(:,:) - -c Bi-Linear Weights -c ----------------- - real(kind=8), allocatable, save :: wl_ip0jp0 (:,:) - real(kind=8), allocatable, save :: wl_im1jp0 (:,:) - real(kind=8), allocatable, save :: wl_ip0jm1 (:,:) - real(kind=8), allocatable, save :: wl_im1jm1 (:,:) - -c Bi-Cubic Weights -c ---------------- - real(kind=8), allocatable, save :: wc_ip1jp1 (:,:) - real(kind=8), allocatable, save :: wc_ip0jp1 (:,:) - real(kind=8), allocatable, save :: wc_im1jp1 (:,:) - real(kind=8), allocatable, save :: wc_im2jp1 (:,:) - real(kind=8), allocatable, save :: wc_ip1jp0 (:,:) - real(kind=8), allocatable, save :: wc_ip0jp0 (:,:) - real(kind=8), allocatable, save :: wc_im1jp0 (:,:) - real(kind=8), allocatable, save :: wc_im2jp0 (:,:) - real(kind=8), allocatable, save :: wc_ip1jm1 (:,:) - real(kind=8), allocatable, save :: wc_ip0jm1 (:,:) - real(kind=8), allocatable, save :: wc_im1jm1 (:,:) - real(kind=8), allocatable, save :: wc_im2jm1 (:,:) - real(kind=8), allocatable, save :: wc_ip1jm2 (:,:) - real(kind=8), allocatable, save :: wc_ip0jm2 (:,:) - real(kind=8), allocatable, save :: wc_im1jm2 (:,:) - real(kind=8), allocatable, save :: wc_im2jm2 (:,:) - - real(kind=8), allocatable, save :: old_dlam (:) - real(kind=8), allocatable, save :: old_dphi (:) - - real(kind=8) ux, ap1, ap0, am1, am2 - real(kind=8) uy, bp1, bp0, bm1, bm2 - - real(kind=8) lon_cmp(lattice%imglobal), lon_geo(lattice%imglobal) - real(kind=8) lat_cmp(lattice%jmglobal), lat_geo(lattice%jmglobal) - real(kind=8) pi,cosnp,sinnp,p1,p2,p3,eps,d - real(kind=8) lam,lam_ip1,lam_ip0,lam_im1,lam_im2 - real(kind=8) phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real(kind=8) dl,dp,lam_np,phi_np,lam_0,eps_np - real(kind=8) lam_geo, lam_cmp, dlam_max, dlam_min - real(kind=8) phi_geo, phi_cmp, dphi_max, dphi_min - real(kind=8) undef, getcon - integer im1_cmp,icmp - integer jm1_cmp,jcmp - - logical compute_weights - real(kind=8) old_rotation - real(kind=8) old_tilt - real(kind=8) old_precession - data old_rotation /-999.9/ - data old_tilt /-999.9/ - data old_precession /-999.9/ - - parameter ( eps = 1.e-10 ) - -c Initialization -c -------------- - call my_barrier (lattice%comm) ! Uncomment for more accurate timing - - pi = 4.*atan(1.) - dl = 2*pi/ lattice%imglobal ! Uniform Grid Delta Lambda - dp = pi/(lattice%jmglobal-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - if(.not.allocated(old_dlam)) then - - allocate ( old_dlam(lattice%imglobal) , old_dphi(lattice%jmglobal) ) - allocate ( wl_ip0jp0(im,jm) , wl_im1jp0(im,jm) ) - allocate ( wl_ip0jm1(im,jm) , wl_im1jm1(im,jm) ) - allocate ( wc_ip1jp1(im,jm) , wc_ip0jp1(im,jm) , wc_im1jp1(im,jm) , wc_im2jp1(im,jm) ) - allocate ( wc_ip1jp0(im,jm) , wc_ip0jp0(im,jm) , wc_im1jp0(im,jm) , wc_im2jp0(im,jm) ) - allocate ( wc_ip1jm1(im,jm) , wc_ip0jm1(im,jm) , wc_im1jm1(im,jm) , wc_im2jm1(im,jm) ) - allocate ( wc_ip1jm2(im,jm) , wc_ip0jm2(im,jm) , wc_im1jm2(im,jm) , wc_im2jm2(im,jm) ) - allocate ( msgn(im,jm) , nsgn(im,jm) ) - allocate ( n_im2jm2(im,jm) , n_im1jm2(im,jm) , n_ip0jm2(im,jm) , n_ip1jm2(im,jm) ) - allocate ( n_im2jm1(im,jm) , n_im1jm1(im,jm) , n_ip0jm1(im,jm) , n_ip1jm1(im,jm) ) - allocate ( n_im2jp0(im,jm) , n_im1jp0(im,jm) , n_ip0jp0(im,jm) , n_ip1jp0(im,jm) ) - allocate ( n_im2jp1(im,jm) , n_im1jp1(im,jm) , n_ip0jp1(im,jm) , n_ip1jp1(im,jm) ) - allocate ( p_im2jm2(im,jm) , p_im1jm2(im,jm) , p_ip0jm2(im,jm) , p_ip1jm2(im,jm) ) - allocate ( p_im2jm1(im,jm) , p_im1jm1(im,jm) , p_ip0jm1(im,jm) , p_ip1jm1(im,jm) ) - allocate ( p_im2jp0(im,jm) , p_im1jp0(im,jm) , p_ip0jp0(im,jm) , p_ip1jp0(im,jm) ) - allocate ( p_im2jp1(im,jm) , p_im1jp1(im,jm) , p_ip0jp1(im,jm) , p_ip1jp1(im,jm) ) - allocate ( recvloc(16*im*jm,0:lattice%nx*lattice%ny-1) ) - allocate ( recvlen( 0:lattice%nx*lattice%ny-1) ) - allocate ( sendlen( 0:lattice%nx*lattice%ny-1) ) - allocate ( sendloc( im*jm,0:lattice%nx*lattice%ny-1) ) -c allocate ( sendloc(lattice%imglobal*lattice%jmglobal,0:lattice%nx*lattice%ny-1) ) - - do i=1,lattice%imglobal - old_dlam(i) = 0.0 - enddo - do j=1,lattice%jmglobal - old_dphi(j) = 0.0 - enddo - - else - i = size (old_dlam) - j = size (old_dphi) - if(i.ne.lattice%imglobal .or. j.ne.lattice%jmglobal) then - deallocate ( old_dlam , old_dphi ) - deallocate ( wl_ip0jp0 , wl_im1jp0 ) - deallocate ( wl_ip0jm1 , wl_im1jm1 ) - deallocate ( wc_ip1jp1 , wc_ip0jp1 , wc_im1jp1 , wc_im2jp1 ) - deallocate ( wc_ip1jp0 , wc_ip0jp0 , wc_im1jp0 , wc_im2jp0 ) - deallocate ( wc_ip1jm1 , wc_ip0jm1 , wc_im1jm1 , wc_im2jm1 ) - deallocate ( wc_ip1jm2 , wc_ip0jm2 , wc_im1jm2 , wc_im2jm2 ) - deallocate ( msgn , nsgn ) - deallocate ( n_im2jm2 , n_im1jm2 , n_ip0jm2 , n_ip1jm2 ) - deallocate ( n_im2jm1 , n_im1jm1 , n_ip0jm1 , n_ip1jm1 ) - deallocate ( n_im2jp0 , n_im1jp0 , n_ip0jp0 , n_ip1jp0 ) - deallocate ( n_im2jp1 , n_im1jp1 , n_ip0jp1 , n_ip1jp1 ) - deallocate ( p_im2jm2 , p_im1jm2 , p_ip0jm2 , p_ip1jm2 ) - deallocate ( p_im2jm1 , p_im1jm1 , p_ip0jm1 , p_ip1jm1 ) - deallocate ( p_im2jp0 , p_im1jp0 , p_ip0jp0 , p_ip1jp0 ) - deallocate ( p_im2jp1 , p_im1jp1 , p_ip0jp1 , p_ip1jp1 ) - deallocate ( recvloc,recvlen,sendlen,sendloc ) - - allocate ( old_dlam(lattice%imglobal) , old_dphi(lattice%jmglobal) ) - allocate ( wl_ip0jp0(im,jm) , wl_im1jp0(im,jm) ) - allocate ( wl_ip0jm1(im,jm) , wl_im1jm1(im,jm) ) - allocate ( wc_ip1jp1(im,jm) , wc_ip0jp1(im,jm) , wc_im1jp1(im,jm) , wc_im2jp1(im,jm) ) - allocate ( wc_ip1jp0(im,jm) , wc_ip0jp0(im,jm) , wc_im1jp0(im,jm) , wc_im2jp0(im,jm) ) - allocate ( wc_ip1jm1(im,jm) , wc_ip0jm1(im,jm) , wc_im1jm1(im,jm) , wc_im2jm1(im,jm) ) - allocate ( wc_ip1jm2(im,jm) , wc_ip0jm2(im,jm) , wc_im1jm2(im,jm) , wc_im2jm2(im,jm) ) - allocate ( msgn(im,jm) , nsgn(im,jm) ) - allocate ( n_im2jm2(im,jm) , n_im1jm2(im,jm) , n_ip0jm2(im,jm) , n_ip1jm2(im,jm) ) - allocate ( n_im2jm1(im,jm) , n_im1jm1(im,jm) , n_ip0jm1(im,jm) , n_ip1jm1(im,jm) ) - allocate ( n_im2jp0(im,jm) , n_im1jp0(im,jm) , n_ip0jp0(im,jm) , n_ip1jp0(im,jm) ) - allocate ( n_im2jp1(im,jm) , n_im1jp1(im,jm) , n_ip0jp1(im,jm) , n_ip1jp1(im,jm) ) - allocate ( p_im2jm2(im,jm) , p_im1jm2(im,jm) , p_ip0jm2(im,jm) , p_ip1jm2(im,jm) ) - allocate ( p_im2jm1(im,jm) , p_im1jm1(im,jm) , p_ip0jm1(im,jm) , p_ip1jm1(im,jm) ) - allocate ( p_im2jp0(im,jm) , p_im1jp0(im,jm) , p_ip0jp0(im,jm) , p_ip1jp0(im,jm) ) - allocate ( p_im2jp1(im,jm) , p_im1jp1(im,jm) , p_ip0jp1(im,jm) , p_ip1jp1(im,jm) ) - allocate ( recvloc(16*im*jm,0:lattice%nx*lattice%ny-1) ) - allocate ( recvlen( 0:lattice%nx*lattice%ny-1) ) - allocate ( sendlen( 0:lattice%nx*lattice%ny-1) ) - allocate ( sendloc( im*jm,0:lattice%nx*lattice%ny-1) ) - - do i=1,lattice%imglobal - old_dlam(i) = 0.0 - enddo - do j=1,lattice%jmglobal - old_dphi(j) = 0.0 - enddo - endif - endif - - -c Compute Geophysical and Computational Lambda's and Phi's -c -------------------------------------------------------- - lon_geo(1) = -pi - lon_cmp(1) = -pi - do i=2,lattice%imglobal - lon_geo(i) = lon_geo(i-1) + dl - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_geo(1) = -pi*0.5 - lat_cmp(1) = -pi*0.5 - do j=2,lattice%jmglobal-1 - lat_geo(j) = lat_geo(j-1) + dp - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_geo(lattice%jmglobal) = pi*0.5 - lat_cmp(lattice%jmglobal) = pi*0.5 - -c Check for Co-incident Grid-Point Latitude and Pole Locations -c ------------------------------------------------------------ - eps_np = 0.0 - do j=1,lattice%jmglobal - phi_cmp = lat_cmp(j)*180./pi - if( abs( phi_cmp-tilt ).lt.1.e-3 ) eps_np = 1.e-3 - if( tilt+eps_np .gt. 90. ) eps_np = -1.e-3 - enddo - - lam_np = pi/180.*rotation - phi_np = pi/180.*(tilt+eps_np) - lam_0 = pi/180.*precession - - undef = getcon('UNDEF') - if( tilt.eq.90. ) then - cosnp = 0.0 - sinnp = 1.0 - else if(tilt.eq.-90.0) then - cosnp = 0.0 - sinnp =-1.0 - else - cosnp = cos(phi_np) - sinnp = sin(phi_np) - endif - -c Determine if Weights Need to be Updated -c --------------------------------------- - compute_weights = rotation.ne.old_rotation .or. - . tilt.ne.old_tilt .or. - . precession.ne.old_precession - - i = 1 - do while ( .not.compute_weights .and. i.le.lattice%imglobal ) - compute_weights = dlam(i).ne.old_dlam(i) - i = i+1 - enddo - j = 1 - do while ( .not.compute_weights .and. j.le.lattice%jmglobal-1 ) - compute_weights = dphi(j).ne.old_dphi(j) - j = j+1 - enddo - -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- - if( compute_weights ) then - - old_rotation = rotation - old_tilt = tilt - old_precession = precession - - dlam_min = dlam(1) - dlam_max = dlam(1) - do i=1,lattice%imglobal - old_dlam(i) = dlam(i) - if( dlam(i).lt.dlam_min ) dlam_min = dlam(i) - if( dlam(i).gt.dlam_max ) dlam_max = dlam(i) - enddo - dphi_min = dphi(1) - dphi_max = dphi(1) - do j=1,lattice%jmglobal-1 - old_dphi(j) = dphi(j) - if( dphi(j).lt.dphi_min ) dphi_min = dphi(j) - if( dphi(j).gt.dphi_max ) dphi_max = dphi(j) - enddo - old_dphi(lattice%jmglobal) = dphi(lattice%jmglobal) - - if( lattice%myid.eq.0 ) then - print *, 'Computing Weights for Computational to Geophysical Grid Interpolation' - print *, '---------------------------------------------------------------------' - print *, 'lam_np = ',rotation - print *, 'phi_np = ',tilt,' (eps_np = ',eps_np,')' - print *, 'lam_0 = ',precession - print * - print *, 'Longitudinal Stretching Factor: ',dlam_max/dlam_min - print *, ' Latitudinal Stretching Factor: ',dphi_max/dphi_min - print * - print *, ' Rotate_B Communication Matrix' - print *, ' -----------------------------' - endif - - allocate ( nn(16*im*jm,0:lattice%nx*lattice%ny-1) ) - allocate ( pos(16*im*jm,0:lattice%nx*lattice%ny-1) ) - allocate ( loc(16*im*jm,0:lattice%nx*lattice%ny-1) ) - allocate ( len( 0:lattice%nx*lattice%ny-1) ) - - allocate ( ip1(im,jm) , ip0(im,jm) , im1(im,jm) , im2(im,jm) ) - allocate ( jp1(im,jm) , jp0(im,jm) , jm1(im,jm) , jm2(im,jm) ) - allocate ( im2jm2(im,jm) , im1jm2(im,jm) , ip0jm2(im,jm) , ip1jm2(im,jm) ) - allocate ( im2jm1(im,jm) , im1jm1(im,jm) , ip0jm1(im,jm) , ip1jm1(im,jm) ) - allocate ( im2jp0(im,jm) , im1jp0(im,jm) , ip0jp0(im,jm) , ip1jp0(im,jm) ) - allocate ( im2jp1(im,jm) , im1jp1(im,jm) , ip0jp1(im,jm) , ip1jp1(im,jm) ) - allocate ( pe_im2jm2(im,jm) , pe_im1jm2(im,jm) , pe_ip0jm2(im,jm) , pe_ip1jm2(im,jm) ) - allocate ( pe_im2jm1(im,jm) , pe_im1jm1(im,jm) , pe_ip0jm1(im,jm) , pe_ip1jm1(im,jm) ) - allocate ( pe_im2jp0(im,jm) , pe_im1jp0(im,jm) , pe_ip0jp0(im,jm) , pe_ip1jp0(im,jm) ) - allocate ( pe_im2jp1(im,jm) , pe_im1jp1(im,jm) , pe_ip0jp1(im,jm) , pe_ip1jp1(im,jm) ) - - do j=1,jm - do i=1,im - lam_geo = lon_geo( lattice%iglobal(i) ) - phi_geo = lat_geo( lattice%jglobal(j) ) - - p1 = cosnp*cos(phi_geo)*cos(lam_geo+lam_0-pi) - . + sin(phi_geo)*sinnp - p1 = min(p1, 1.0) - p1 = max(p1,-1.0) - phi_cmp = asin( p1 ) - - if( tilt.eq.90.0 .or. tilt.eq.-90.0 ) then - p2 = sinnp*cos(lam_geo+lam_0-pi) - else - p2 = sinnp*cos(phi_geo)*cos(lam_geo+lam_0-pi) - . - sin(phi_geo)*cosnp - p2 = p2 / max( cos(phi_cmp),eps ) - p2 = min(p2, 1.0) - p2 = max(p2,-1.0) - endif - p2 = acos( p2 ) - - p3 = cos(phi_geo)*sin(lam_geo+lam_0-pi) - if( p3.lt.0.0 ) p2 = -p2 - p2 = p2 + lam_np - pi - lam_cmp = mod( p2+3.0*pi,2.0*pi ) - pi - -c Determine (i,j) Indexing Based on Computational Grid -c ---------------------------------------------------- - im1_cmp = 1 - do icmp = 2,lattice%imglobal - if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp - enddo - jm1_cmp = 1 - do jcmp = 2,lattice%jmglobal - if( lat_cmp(jcmp).lt.phi_cmp ) jm1_cmp = jcmp - enddo - - im1(i,j) = im1_cmp - ip0(i,j) = im1(i,j) + 1 - ip1(i,j) = ip0(i,j) + 1 - im2(i,j) = im1(i,j) - 1 - - jm1(i,j) = jm1_cmp - jp0(i,j) = jm1(i,j) + 1 - jp1(i,j) = jp0(i,j) + 1 - jm2(i,j) = jm1(i,j) - 1 - -c Fix Longitude Index Boundaries -c ------------------------------ - if(im1(i,j).eq.lattice%imglobal) then - ip0(i,j) = 1 - ip1(i,j) = 2 - endif - if(im1(i,j).eq.1) then - im2(i,j) = lattice%imglobal - endif - if(ip0(i,j).eq.lattice%imglobal) then - ip1(i,j) = 1 - endif - -c Compume Immediate Surrounding Coordinates -c ----------------------------------------- - lam = lam_cmp - phi = phi_cmp - -c Compute and Adjust Longitude Weights -c ------------------------------------ - lam_im2 = lon_cmp(im2(i,j)) - lam_im1 = lon_cmp(im1(i,j)) - lam_ip0 = lon_cmp(ip0(i,j)) - lam_ip1 = lon_cmp(ip1(i,j)) - - if( lam_im2.gt.lam_im1 ) lam_im2 = lam_im2 - 2*pi - if( lam_im1.gt.lam_ip0 ) lam_ip0 = lam_ip0 + 2*pi - if( lam_im1.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi - -c Compute and Adjust Latitude Weights -c ------------------------------------------------------------------ - phi_jm2 = lat_cmp(jm2(i,j)) - phi_jm1 = lat_cmp(jm1(i,j)) - phi_jp0 = lat_cmp(jp0(i,j)) - phi_jp1 = lat_cmp(jp1(i,j)) - - if( jm2(i,j).eq.0 ) phi_jm2 = phi_jm1 - dphi(1) - if( jm1(i,j).eq.lattice%jmglobal ) then - phi_jp0 = phi_jm1 + dphi(lattice%jmglobal-1) - phi_jp1 = phi_jp0 + dphi(lattice%jmglobal-2) - endif - if( jp1(i,j).eq.lattice%jmglobal+1 ) phi_jp1 = phi_jp0 + dphi(lattice%jmglobal-1) - -c Compute ij index -c ---------------- - msgn(i,j) = 2 - if( jp0(i,j).eq.lattice%jmglobal ) then - jp1(i,j) = lattice%jmglobal-1 - ip1jp1(i,j) = 1+mod(ip1(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jp1(i,j)-1 )*lattice%imglobal - ip0jp1(i,j) = 1+mod(ip0(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jp1(i,j)-1 )*lattice%imglobal - im1jp1(i,j) = 1+mod(im1(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jp1(i,j)-1 )*lattice%imglobal - im2jp1(i,j) = 1+mod(im2(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jp1(i,j)-1 )*lattice%imglobal - msgn(i,j) = 1 - else - ip1jp1(i,j) = ip1(i,j) + ( jp1(i,j)-1 )*lattice%imglobal - ip0jp1(i,j) = ip0(i,j) + ( jp1(i,j)-1 )*lattice%imglobal - im1jp1(i,j) = im1(i,j) + ( jp1(i,j)-1 )*lattice%imglobal - im2jp1(i,j) = im2(i,j) + ( jp1(i,j)-1 )*lattice%imglobal - endif - - ip1jp0(i,j) = ip1(i,j) + ( jp0(i,j)-1 )*lattice%imglobal - ip0jp0(i,j) = ip0(i,j) + ( jp0(i,j)-1 )*lattice%imglobal - im1jp0(i,j) = im1(i,j) + ( jp0(i,j)-1 )*lattice%imglobal - im2jp0(i,j) = im2(i,j) + ( jp0(i,j)-1 )*lattice%imglobal - - ip1jm1(i,j) = ip1(i,j) + ( jm1(i,j)-1 )*lattice%imglobal - ip0jm1(i,j) = ip0(i,j) + ( jm1(i,j)-1 )*lattice%imglobal - im1jm1(i,j) = im1(i,j) + ( jm1(i,j)-1 )*lattice%imglobal - im2jm1(i,j) = im2(i,j) + ( jm1(i,j)-1 )*lattice%imglobal - - nsgn(i,j) = 2 - if( jm1(i,j).eq.1 ) then - jm2(i,j) = 2 - ip1jm2(i,j) = 1+mod(ip1(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jm2(i,j)-1 )*lattice%imglobal - ip0jm2(i,j) = 1+mod(ip0(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jm2(i,j)-1 )*lattice%imglobal - im1jm2(i,j) = 1+mod(im1(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jm2(i,j)-1 )*lattice%imglobal - im2jm2(i,j) = 1+mod(im2(i,j)+lattice%imglobal/2-1,lattice%imglobal) + ( jm2(i,j)-1 )*lattice%imglobal - nsgn(i,j) = 1 - else - ip1jm2(i,j) = ip1(i,j) + ( jm2(i,j)-1 )*lattice%imglobal - ip0jm2(i,j) = ip0(i,j) + ( jm2(i,j)-1 )*lattice%imglobal - im1jm2(i,j) = im1(i,j) + ( jm2(i,j)-1 )*lattice%imglobal - im2jm2(i,j) = im2(i,j) + ( jm2(i,j)-1 )*lattice%imglobal - endif - -c Determine PE location of Source Data -c ------------------------------------ - pej_jp1 = lattice%pejglobal( jp1(i,j) ) - pej_jp0 = lattice%pejglobal( jp0(i,j) ) - pej_jm1 = lattice%pejglobal( jm1(i,j) ) - pej_jm2 = lattice%pejglobal( jm2(i,j) ) - - pei_ip1 = lattice%peiglobal( ip1(i,j) ) - pei_ip0 = lattice%peiglobal( ip0(i,j) ) - pei_im1 = lattice%peiglobal( im1(i,j) ) - pei_im2 = lattice%peiglobal( im2(i,j) ) - - pe_ip1jp0(i,j) = pei_ip1 + pej_jp0*lattice%nx - pe_ip0jp0(i,j) = pei_ip0 + pej_jp0*lattice%nx - pe_im1jp0(i,j) = pei_im1 + pej_jp0*lattice%nx - pe_im2jp0(i,j) = pei_im2 + pej_jp0*lattice%nx - - pe_ip1jm1(i,j) = pei_ip1 + pej_jm1*lattice%nx - pe_ip0jm1(i,j) = pei_ip0 + pej_jm1*lattice%nx - pe_im1jm1(i,j) = pei_im1 + pej_jm1*lattice%nx - pe_im2jm1(i,j) = pei_im2 + pej_jm1*lattice%nx - - n = 1 + (ip1jp1(i,j)-1)/lattice%imglobal - m = ip1jp1(i,j) - (n-1)*lattice%imglobal - pei_ip1 = lattice%peiglobal( m ) - n = 1 + (ip0jp1(i,j)-1)/lattice%imglobal - m = ip0jp1(i,j) - (n-1)*lattice%imglobal - pei_ip0 = lattice%peiglobal( m ) - n = 1 + (im1jp1(i,j)-1)/lattice%imglobal - m = im1jp1(i,j) - (n-1)*lattice%imglobal - pei_im1 = lattice%peiglobal( m ) - n = 1 + (im2jp1(i,j)-1)/lattice%imglobal - m = im2jp1(i,j) - (n-1)*lattice%imglobal - pei_im2 = lattice%peiglobal( m ) - - pe_ip1jp1(i,j) = pei_ip1 + pej_jp1*lattice%nx - pe_ip0jp1(i,j) = pei_ip0 + pej_jp1*lattice%nx - pe_im1jp1(i,j) = pei_im1 + pej_jp1*lattice%nx - pe_im2jp1(i,j) = pei_im2 + pej_jp1*lattice%nx - - n = 1 + (ip1jm2(i,j)-1)/lattice%imglobal - m = ip1jm2(i,j) - (n-1)*lattice%imglobal - pei_ip1 = lattice%peiglobal( m ) - n = 1 + (ip0jm2(i,j)-1)/lattice%imglobal - m = ip0jm2(i,j) - (n-1)*lattice%imglobal - pei_ip0 = lattice%peiglobal( m ) - n = 1 + (im1jm2(i,j)-1)/lattice%imglobal - m = im1jm2(i,j) - (n-1)*lattice%imglobal - pei_im1 = lattice%peiglobal( m ) - n = 1 + (im2jm2(i,j)-1)/lattice%imglobal - m = im2jm2(i,j) - (n-1)*lattice%imglobal - pei_im2 = lattice%peiglobal( m ) - - pe_ip1jm2(i,j) = pei_ip1 + pej_jm2*lattice%nx - pe_ip0jm2(i,j) = pei_ip0 + pej_jm2*lattice%nx - pe_im1jm2(i,j) = pei_im1 + pej_jm2*lattice%nx - pe_im2jm2(i,j) = pei_im2 + pej_jm2*lattice%nx - -c Bi-Linear Weights -c ----------------- - d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) - wl_im1jm1(i,j) = (lam_ip0-lam )*(phi_jp0-phi )/d - wl_ip0jm1(i,j) = (lam -lam_im1)*(phi_jp0-phi )/d - wl_im1jp0(i,j) = (lam_ip0-lam )*(phi -phi_jm1)/d - wl_ip0jp0(i,j) = (lam -lam_im1)*(phi -phi_jm1)/d - -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) - - wc_ip1jp1(i,j) = bp1*ap1 - wc_ip0jp1(i,j) = bp1*ap0 - wc_im1jp1(i,j) = bp1*am1 - wc_im2jp1(i,j) = bp1*am2 - - wc_ip1jp0(i,j) = bp0*ap1 - wc_ip0jp0(i,j) = bp0*ap0 - wc_im1jp0(i,j) = bp0*am1 - wc_im2jp0(i,j) = bp0*am2 - - wc_ip1jm1(i,j) = bm1*ap1 - wc_ip0jm1(i,j) = bm1*ap0 - wc_im1jm1(i,j) = bm1*am1 - wc_im2jm1(i,j) = bm1*am2 - - wc_ip1jm2(i,j) = bm2*ap1 - wc_ip0jm2(i,j) = bm2*ap0 - wc_im1jm2(i,j) = bm2*am1 - wc_im2jm2(i,j) = bm2*am2 - - enddo - enddo - -c Create Data Index Array for Total and Non-Redundant Data -c Note: recvlen(peid): is the total number of unique grid-points needed from a given peid -c ----- recvloc(m,peid): is a list of the global locations of those points -c ------------------------------------------------------------------------- - allocate ( bucket(16*lattice%imglobal*lattice%jmglobal) ) - do peid = 0,lattice%nx*lattice%ny-1 - num = 0 - do j=1,jm - do i=1,im - if ( pe_im2jm2(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im2jm2(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_im1jm2(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im1jm2(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip0jm2(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip0jm2(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip1jm2(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip1jm2(i,j) - pos(num,peid) = i+(j-1)*im - endif - - if ( pe_im2jm1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im2jm1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_im1jm1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im1jm1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip0jm1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip0jm1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip1jm1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip1jm1(i,j) - pos(num,peid) = i+(j-1)*im - endif - - if ( pe_im2jp0(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im2jp0(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_im1jp0(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im1jp0(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip0jp0(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip0jp0(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip1jp0(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip1jp0(i,j) - pos(num,peid) = i+(j-1)*im - endif - - if ( pe_im2jp1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im2jp1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_im1jp1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = im1jp1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip0jp1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip0jp1(i,j) - pos(num,peid) = i+(j-1)*im - endif - if ( pe_ip1jp1(i,j).eq.peid ) then - num = num + 1 - loc(num,peid) = ip1jp1(i,j) - pos(num,peid) = i+(j-1)*im - endif - enddo - enddo - len(peid) = num - -c Strip redundancies from buffer -c ------------------------------ - m = 0 - if( num.ne.0 ) then - bucket(:) = 0 - do i=1,num - bucket( loc(i,peid) ) = 1 - enddo - do i=1,16*lattice%imglobal*lattice%jmglobal - if( bucket(i).eq.1 ) then - m = m+1 - recvloc(m,peid) = i - bucket (i) = m - endif - enddo - do i=1,num - nn(i,peid) = bucket( loc(i,peid) ) - enddo - endif - - recvlen(peid) = m - enddo - deallocate ( bucket ) - -c Store buffer locations -c ---------------------- - do peid = 0,lattice%nx*lattice%ny-1 - do m = 1,len(peid) - n = nn (m,peid) - j = 1 + (pos(m,peid)-1)/im - i = pos(m,peid) - (j-1)*im - if( recvloc(n,peid).eq.ip1jp1(i,j) ) then - n_ip1jp1(i,j) = n - p_ip1jp1(i,j) = peid - endif - if( recvloc(n,peid).eq.ip0jp1(i,j) ) then - n_ip0jp1(i,j) = n - p_ip0jp1(i,j) = peid - endif - if( recvloc(n,peid).eq.im1jp1(i,j) ) then - n_im1jp1(i,j) = n - p_im1jp1(i,j) = peid - endif - if( recvloc(n,peid).eq.im2jp1(i,j) ) then - n_im2jp1(i,j) = n - p_im2jp1(i,j) = peid - endif - - if( recvloc(n,peid).eq.ip1jp0(i,j) ) then - n_ip1jp0(i,j) = n - p_ip1jp0(i,j) = peid - endif - if( recvloc(n,peid).eq.ip0jp0(i,j) ) then - n_ip0jp0(i,j) = n - p_ip0jp0(i,j) = peid - endif - if( recvloc(n,peid).eq.im1jp0(i,j) ) then - n_im1jp0(i,j) = n - p_im1jp0(i,j) = peid - endif - if( recvloc(n,peid).eq.im2jp0(i,j) ) then - n_im2jp0(i,j) = n - p_im2jp0(i,j) = peid - endif - - if( recvloc(n,peid).eq.ip1jm1(i,j) ) then - n_ip1jm1(i,j) = n - p_ip1jm1(i,j) = peid - endif - if( recvloc(n,peid).eq.ip0jm1(i,j) ) then - n_ip0jm1(i,j) = n - p_ip0jm1(i,j) = peid - endif - if( recvloc(n,peid).eq.im1jm1(i,j) ) then - n_im1jm1(i,j) = n - p_im1jm1(i,j) = peid - endif - if( recvloc(n,peid).eq.im2jm1(i,j) ) then - n_im2jm1(i,j) = n - p_im2jm1(i,j) = peid - endif - - if( recvloc(n,peid).eq.ip1jm2(i,j) ) then - n_ip1jm2(i,j) = n - p_ip1jm2(i,j) = peid - endif - if( recvloc(n,peid).eq.ip0jm2(i,j) ) then - n_ip0jm2(i,j) = n - p_ip0jm2(i,j) = peid - endif - if( recvloc(n,peid).eq.im1jm2(i,j) ) then - n_im1jm2(i,j) = n - p_im1jm2(i,j) = peid - endif - if( recvloc(n,peid).eq.im2jm2(i,j) ) then - n_im2jm2(i,j) = n - p_im2jm2(i,j) = peid - endif - enddo - enddo - - -c Send and Recv the data length needed for interpolation -c ------------------------------------------------------ - do peid = 0,lattice%nx*lattice%ny-1 - if( lattice%myid.ne.peid ) then - - call mpi_isend ( recvlen(peid),1,mpi_integer,peid,peid,lattice%comm,sendquest(peid),ierror ) - - else - sendquest(peid) = mpi_request_null - endif - enddo - - do peid = 0,lattice%nx*lattice%ny-1 - if( lattice%myid.ne.peid ) then - - call mpi_irecv ( sendlen(peid),1,mpi_integer,peid,lattice%myid,lattice%comm,recvquest(peid),ierror ) - - else - sendlen(peid) = recvlen(peid) - recvquest(peid) = mpi_request_null - endif - enddo - - call mpi_waitall ( lattice%nx*lattice%ny,sendquest(0:lattice%nx*lattice%ny-1),stats(1,0),ierror ) - call mpi_waitall ( lattice%nx*lattice%ny,recvquest(0:lattice%nx*lattice%ny-1),statr(1,0),ierror ) - -c Send and Recv the data locations needed for interpolation -c --------------------------------------------------------- - do peid = 0,lattice%nx*lattice%ny-1 - sendquest(peid) = mpi_request_null - if( lattice%myid.ne.peid ) then - if( recvlen(peid).ne.0 ) then - - call mpi_isend ( recvloc(1,peid),recvlen(peid),mpi_integer,peid,peid,lattice%comm,sendquest(peid),ierror ) - - endif - endif - enddo - - do peid = 0,lattice%nx*lattice%ny-1 - recvquest(peid) = mpi_request_null - if( sendlen(peid).ne.0 ) then - if( lattice%myid.ne.peid ) then - - call mpi_irecv ( sendloc(1,peid),sendlen(peid),mpi_integer,peid,lattice%myid,lattice%comm,recvquest(peid),ierror ) - - else - do n=1,sendlen(peid) - sendloc(n,peid) = recvloc(n,peid) - enddo - endif - endif - enddo - - call mpi_waitall ( lattice%nx*lattice%ny,sendquest(0:lattice%nx*lattice%ny-1),stats(1,0),ierror ) - call mpi_waitall ( lattice%nx*lattice%ny,recvquest(0:lattice%nx*lattice%ny-1),statr(1,0),ierror ) - -c Print Communication Matrix -c -------------------------- - do n=0,lattice%nx*lattice%ny-1 - if( n.eq.lattice%myid ) then - write(6,1001) (sendlen(m),m=0,lattice%nx*lattice%ny-1) - endif - call my_barrier (lattice%comm) - enddo - if( lattice%myid.eq.lattice%nx*lattice%ny-1 ) print * - 1001 format(128(1x,i4)) - - deallocate ( nn,pos,loc,len ) - deallocate ( ip1 , ip0 , im1 , im2 ) - deallocate ( jp1 , jp0 , jm1 , jm2 ) - deallocate ( im2jm2 , im1jm2 , ip0jm2 , ip1jm2 ) - deallocate ( im2jm1 , im1jm1 , ip0jm1 , ip1jm1 ) - deallocate ( im2jp0 , im1jp0 , ip0jp0 , ip1jp0 ) - deallocate ( im2jp1 , im1jp1 , ip0jp1 , ip1jp1 ) - deallocate ( pe_im2jm2 , pe_im1jm2 , pe_ip0jm2 , pe_ip1jm2 ) - deallocate ( pe_im2jm1 , pe_im1jm1 , pe_ip0jm1 , pe_ip1jm1 ) - deallocate ( pe_im2jp0 , pe_im1jp0 , pe_ip0jp0 , pe_ip1jp0 ) - deallocate ( pe_im2jp1 , pe_im1jp1 , pe_ip0jp1 , pe_ip1jp1 ) - - endif ! End compute_weights check - - -C*********************************************************************** -C* Begin Rotate Interpolation * -C*********************************************************************** - -c Send and Recv the data needed for interpolation -c ----------------------------------------------- - allocate ( sendbuf(im*jm*lm ,0:lattice%nx*lattice%ny-1) ) - allocate ( recvbuf(lattice%imax*lattice%jmax*lm,0:lattice%nx*lattice%ny-1) ) - - do peid = 0,lattice%nx*lattice%ny-1 - sendquest(peid) = mpi_request_null - if( sendlen(peid).ne.0 ) then - if( lattice%myid.ne.peid ) then - - m = 0 - do n = 1,sendlen(peid) - j = 1 + (sendloc(n,peid)-1)/lattice%imglobal - i = sendloc(n,peid) - (j-1)*lattice%imglobal - do L = 1,lm - m = m+1 - sendbuf(m,peid) = q_cmp( lattice%ilocal(i),lattice%jlocal(j),L ) - enddo - enddo - call mpi_isend ( sendbuf(1,peid),m,mpi_double_precision,peid,peid,lattice%comm, - . sendquest(peid),ierror ) - - else - m = 0 - do n = 1,sendlen(peid) - j = 1 + (sendloc(n,peid)-1)/lattice%imglobal - i = sendloc(n,peid) - (j-1)*lattice%imglobal - do L = 1,lm - m = m+1 - recvbuf(m,peid) = q_cmp( lattice%ilocal(i),lattice%jlocal(j),L ) - enddo - enddo - endif - endif - enddo - - do peid = 0,lattice%nx*lattice%ny-1 - recvquest(peid) = mpi_request_null - if( lattice%myid.ne.peid ) then - if( recvlen(peid).ne.0 ) then - - call mpi_irecv ( recvbuf(1,peid),recvlen(peid)*lm,mpi_double_precision,peid,lattice%myid,lattice%comm, - . recvquest(peid),ierror ) - - endif - endif - enddo - - call mpi_waitall ( lattice%nx*lattice%ny,sendquest(0:lattice%nx*lattice%ny-1),stats(1,0),ierror ) - call mpi_waitall ( lattice%nx*lattice%ny,recvquest(0:lattice%nx*lattice%ny-1),statr(1,0),ierror ) - -c Interpolate Geophysical Quantities to Computational Grid Using Bi-Linear -c ------------------------------------------------------------------------ - if( abs(norder).eq.1 ) then - - if( check ) then - do j=1,jm - do i=1,im - do L=1,lm - if( recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ).ne.undef ) then - q_geo(i,j,L) = wl_im1jm1(i,j) * recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ) - . + wl_ip0jm1(i,j) * recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ) - . + wl_im1jp0(i,j) * recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ) - . + wl_ip0jp0(i,j) * recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ) - else - q_geo(i,j,L) = undef - endif - enddo - enddo - enddo - endif ! End UNDEF Check - - if( .not.check ) then - do j=1,jm - do i=1,im - do L=1,lm - q_geo(i,j,L) = wl_im1jm1(i,j) * recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ) - . + wl_ip0jm1(i,j) * recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ) - . + wl_im1jp0(i,j) * recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ) - . + wl_ip0jp0(i,j) * recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ) - enddo - enddo - enddo - endif ! End UNDEF Check - - endif ! End Check for Bi-Linear Interpolation - -c Interpolate Geophysical Quantities to Computational Grid Using Bi-Cubic -c ----------------------------------------------------------------------- - if( abs(norder).eq.3 ) then - - if( check ) then - do j=1,jm - do i=1,im - sgnjp1 = sgn**msgn(i,j) - sgnjm2 = sgn**nsgn(i,j) - do L=1,lm - - if( recvbuf( L+(n_ip1jp1(i,j)-1)*lm,p_ip1jp1(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jp1(i,j)-1)*lm,p_ip0jp1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jp1(i,j)-1)*lm,p_im1jp1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im2jp1(i,j)-1)*lm,p_im2jp1(i,j) ).ne.undef .and. - - . recvbuf( L+(n_ip1jp0(i,j)-1)*lm,p_ip1jp0(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ).ne.undef .and. - . recvbuf( L+(n_im2jp0(i,j)-1)*lm,p_im2jp0(i,j) ).ne.undef .and. - - . recvbuf( L+(n_ip1jm1(i,j)-1)*lm,p_ip1jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im2jm1(i,j)-1)*lm,p_im2jm1(i,j) ).ne.undef .and. - - . recvbuf( L+(n_ip1jm2(i,j)-1)*lm,p_ip1jm2(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jm2(i,j)-1)*lm,p_ip0jm2(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jm2(i,j)-1)*lm,p_im1jm2(i,j) ).ne.undef .and. - . recvbuf( L+(n_im2jm2(i,j)-1)*lm,p_im2jm2(i,j) ).ne.undef ) then - - q_geo(i,j,L) = wc_ip1jp1(i,j) * recvbuf( L+(n_ip1jp1(i,j)-1)*lm,p_ip1jp1(i,j) )*sgnjp1 - . + wc_ip0jp1(i,j) * recvbuf( L+(n_ip0jp1(i,j)-1)*lm,p_ip0jp1(i,j) )*sgnjp1 - . + wc_im1jp1(i,j) * recvbuf( L+(n_im1jp1(i,j)-1)*lm,p_im1jp1(i,j) )*sgnjp1 - . + wc_im2jp1(i,j) * recvbuf( L+(n_im2jp1(i,j)-1)*lm,p_im2jp1(i,j) )*sgnjp1 - - . + wc_ip1jp0(i,j) * recvbuf( L+(n_ip1jp0(i,j)-1)*lm,p_ip1jp0(i,j) ) - . + wc_ip0jp0(i,j) * recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ) - . + wc_im1jp0(i,j) * recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ) - . + wc_im2jp0(i,j) * recvbuf( L+(n_im2jp0(i,j)-1)*lm,p_im2jp0(i,j) ) - - . + wc_ip1jm1(i,j) * recvbuf( L+(n_ip1jm1(i,j)-1)*lm,p_ip1jm1(i,j) ) - . + wc_ip0jm1(i,j) * recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ) - . + wc_im1jm1(i,j) * recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ) - . + wc_im2jm1(i,j) * recvbuf( L+(n_im2jm1(i,j)-1)*lm,p_im2jm1(i,j) ) - - . + wc_ip1jm2(i,j) * recvbuf( L+(n_ip1jm2(i,j)-1)*lm,p_ip1jm2(i,j) )*sgnjm2 - . + wc_ip0jm2(i,j) * recvbuf( L+(n_ip0jm2(i,j)-1)*lm,p_ip0jm2(i,j) )*sgnjm2 - . + wc_im1jm2(i,j) * recvbuf( L+(n_im1jm2(i,j)-1)*lm,p_im1jm2(i,j) )*sgnjm2 - . + wc_im2jm2(i,j) * recvbuf( L+(n_im2jm2(i,j)-1)*lm,p_im2jm2(i,j) )*sgnjm2 - - elseif( recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ).ne.undef .and. - . recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ).ne.undef .and. - . recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ).ne.undef ) then - - q_geo(i,j,L) = wl_im1jm1(i,j) * recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ) - . + wl_ip0jm1(i,j) * recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ) - . + wl_im1jp0(i,j) * recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ) - . + wl_ip0jp0(i,j) * recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ) - - else - q_geo(i,j,L) = undef - endif - -c Check for Positive Definite -c --------------------------- - if( norder.lt.0 ) then - if( q_geo(i,j,L).ne.undef .and. q_geo(i,j,L).lt.0.0 ) q_geo(i,j,L) = 0.0 - endif - - enddo ! End L Loop - enddo ! End i Loop - enddo ! End j Loop - - endif ! End UNDEF Check - - if( .not.check ) then - do j=1,jm - do i=1,im - sgnjp1 = sgn**msgn(i,j) - sgnjm2 = sgn**nsgn(i,j) - do L=1,lm - - q_geo(i,j,L) = wc_ip1jp1(i,j) * recvbuf( L+(n_ip1jp1(i,j)-1)*lm,p_ip1jp1(i,j) )*sgnjp1 - . + wc_ip0jp1(i,j) * recvbuf( L+(n_ip0jp1(i,j)-1)*lm,p_ip0jp1(i,j) )*sgnjp1 - . + wc_im1jp1(i,j) * recvbuf( L+(n_im1jp1(i,j)-1)*lm,p_im1jp1(i,j) )*sgnjp1 - . + wc_im2jp1(i,j) * recvbuf( L+(n_im2jp1(i,j)-1)*lm,p_im2jp1(i,j) )*sgnjp1 - - . + wc_ip1jp0(i,j) * recvbuf( L+(n_ip1jp0(i,j)-1)*lm,p_ip1jp0(i,j) ) - . + wc_ip0jp0(i,j) * recvbuf( L+(n_ip0jp0(i,j)-1)*lm,p_ip0jp0(i,j) ) - . + wc_im1jp0(i,j) * recvbuf( L+(n_im1jp0(i,j)-1)*lm,p_im1jp0(i,j) ) - . + wc_im2jp0(i,j) * recvbuf( L+(n_im2jp0(i,j)-1)*lm,p_im2jp0(i,j) ) - - . + wc_ip1jm1(i,j) * recvbuf( L+(n_ip1jm1(i,j)-1)*lm,p_ip1jm1(i,j) ) - . + wc_ip0jm1(i,j) * recvbuf( L+(n_ip0jm1(i,j)-1)*lm,p_ip0jm1(i,j) ) - . + wc_im1jm1(i,j) * recvbuf( L+(n_im1jm1(i,j)-1)*lm,p_im1jm1(i,j) ) - . + wc_im2jm1(i,j) * recvbuf( L+(n_im2jm1(i,j)-1)*lm,p_im2jm1(i,j) ) - - . + wc_ip1jm2(i,j) * recvbuf( L+(n_ip1jm2(i,j)-1)*lm,p_ip1jm2(i,j) )*sgnjm2 - . + wc_ip0jm2(i,j) * recvbuf( L+(n_ip0jm2(i,j)-1)*lm,p_ip0jm2(i,j) )*sgnjm2 - . + wc_im1jm2(i,j) * recvbuf( L+(n_im1jm2(i,j)-1)*lm,p_im1jm2(i,j) )*sgnjm2 - . + wc_im2jm2(i,j) * recvbuf( L+(n_im2jm2(i,j)-1)*lm,p_im2jm2(i,j) )*sgnjm2 - -c Check for Positive Definite -c --------------------------- - if( norder.lt.0 ) then - if( q_geo(i,j,L).ne.undef .and. q_geo(i,j,L).lt.0.0 ) q_geo(i,j,L) = 0.0 - endif - - enddo ! End L Loop - enddo ! End i Loop - enddo ! End j Loop - - endif ! End UNDEF Check - endif ! End Check for Bi-Cubic Interpolation - - deallocate ( sendbuf ) - deallocate ( recvbuf ) - - return - end - - subroutine vector ( u,v,im,jm,lm,msgn, - . dlam,dphi,rotation,tilt,precession,lattice ) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Transform wind vectors after rotation to new coordinate system. -C -C INPUT: -C ====== -C u .......... U-Wind u(im,jm,lm) after rotation from old system -C v .......... V-Wind v(im,jm,lm) after rotation from old system -C im ......... Longitudinal dimension of wind -C jm ......... Latitudinal dimension of wind -C lm ......... Vertical dimension of wind -C msgn ....... Flag for a forward transformation ( msgn = 1 ) -C or a backward transformation ( msgn = -1 ) -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C rotation ... Rotation parameter lam_np (Degrees) -C tilt ....... Rotation parameter phi_np (Degrees) -C precession . Rotation parameter lam_0 (Degrees) -C -C OUTPUT: -C ======= -C u .......... U-Wind u(im,jm,lm) after rotation in new system -C v .......... V-Wind v(im,jm,lm) after rotation in new system -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - -c Input Variables -c --------------- - integer im,jm,lm,msgn - real(kind=8) u(im,jm,lm) - real(kind=8) v(im,jm,lm) - real(kind=8) dlam(lattice%imglobal) - real(kind=8) dphi(lattice%jmglobal) - real(kind=8) rotation, tilt, precession - -c Local Variables -c --------------- - integer i,j,l,m,n - -c Tranformation Functions -c ----------------------- - real(kind=8), allocatable, save :: cos_chi_f (:,:) - real(kind=8), allocatable, save :: sin_chi_f (:,:) - real(kind=8), allocatable, save :: cos_chi_b (:,:) - real(kind=8), allocatable, save :: sin_chi_b (:,:) - - real(kind=8), allocatable, save :: old_dlam (:) - real(kind=8), allocatable, save :: old_dphi (:) - - real(kind=8) lon_cmp(lattice%imglobal), lon_geo(lattice%imglobal) - real(kind=8) lat_cmp(lattice%jmglobal), lat_geo(lattice%jmglobal) - real(kind=8) pi,cosnp,sinnp,p1,p2,p3,eps - real(kind=8) dl,dp,lam_np,phi_np,lam_0,eps_np - real(kind=8) utmp,vtmp - real(kind=8) lam_geo, lam_cmp - real(kind=8) phi_geo, phi_cmp - real(kind=8) undef, getcon - - logical compute_weights - real(kind=8) old_rotation - real(kind=8) old_tilt - real(kind=8) old_precession - data old_rotation /-999.9/ - data old_tilt /-999.9/ - data old_precession /-999.9/ - - parameter ( eps = 1.e-10 ) - -c Initialization -c -------------- - pi = 4.*atan(1.) - dl = 2*pi/ lattice%imglobal ! Uniform Grid Delta Lambda - dp = pi/(lattice%jmglobal-1) ! Uniform Grid Delta Phi - -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- - if(.not.allocated(old_dlam)) then - - allocate ( old_dlam(lattice%imglobal) , old_dphi(lattice%jmglobal) ) - allocate ( cos_chi_f(im,jm) , sin_chi_f(im,jm) ) - allocate ( cos_chi_b(im,jm) , sin_chi_b(im,jm) ) - do i=1,lattice%imglobal - old_dlam(i) = 0.0 - enddo - do j=1,lattice%jmglobal - old_dphi(j) = 0.0 - enddo - - else - i = size (old_dlam) - j = size (old_dphi) - if(i.ne.lattice%imglobal .or. j.ne.lattice%jmglobal) then - deallocate ( old_dlam , old_dphi ) - deallocate ( cos_chi_f , sin_chi_f ) - deallocate ( cos_chi_b , sin_chi_b ) - allocate ( old_dlam(lattice%imglobal) , old_dphi(lattice%jmglobal) ) - allocate ( cos_chi_f(im,jm) , sin_chi_f(im,jm) ) - allocate ( cos_chi_b(im,jm) , sin_chi_b(im,jm) ) - do i=1,lattice%imglobal - old_dlam(i) = 0.0 - enddo - do j=1,lattice%jmglobal - old_dphi(j) = 0.0 - enddo - endif - endif - - -c Compute Geophysical and Computational Lambda's and Phi's -c -------------------------------------------------------- - lon_geo(1) = -pi - lon_cmp(1) = -pi - do i=2,lattice%imglobal - lon_geo(i) = lon_geo(i-1) + dl - lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) - enddo - lat_geo(1) = -pi*0.5 - lat_cmp(1) = -pi*0.5 - do j=2,lattice%jmglobal-1 - lat_geo(j) = lat_geo(j-1) + dp - lat_cmp(j) = lat_cmp(j-1) + dphi(j-1) - enddo - lat_geo(lattice%jmglobal) = pi*0.5 - lat_cmp(lattice%jmglobal) = pi*0.5 - - -c Check for Co-incident Grid-Point Latitude and Pole Locations -c ------------------------------------------------------------ - eps_np = 0.0 - do j=1,lattice%jmglobal - phi_cmp = lat_cmp(j)*180./pi - if( abs( phi_cmp-tilt ).lt.1.e-3 ) eps_np = 1.e-3 - if( tilt+eps_np .gt. 90. ) eps_np = -1.e-3 - enddo - - lam_np = pi/180.*rotation - phi_np = pi/180.*(tilt+eps_np) - lam_0 = pi/180.*precession - - undef = getcon('UNDEF') - if( tilt.eq.90. ) then - cosnp = 0.0 - sinnp = 1.0 - else if(tilt.eq.-90.0) then - cosnp = 0.0 - sinnp =-1.0 - else - cosnp = cos(phi_np) - sinnp = sin(phi_np) - endif - -c Determine if Weights Need to be Updated -c --------------------------------------- - compute_weights = rotation.ne.old_rotation .or. - . tilt.ne.old_tilt .or. - . precession.ne.old_precession - - i = 1 - do while ( .not.compute_weights .and. i.le.lattice%imglobal ) - compute_weights = dlam(i).ne.old_dlam(i) - i = i+1 - enddo - j = 1 - do while ( .not.compute_weights .and. j.le.lattice%jmglobal-1 ) - compute_weights = dphi(j).ne.old_dphi(j) - j = j+1 - enddo - -c Computing Rotational Transformations for Vector Wind Field -c ---------------------------------------------------------- - if( compute_weights ) then - - old_rotation = rotation - old_tilt = tilt - old_precession = precession - - do i=1,lattice%imglobal - old_dlam(i) = dlam(i) - enddo - do j=1,lattice%jmglobal-1 - old_dphi(j) = dphi(j) - enddo - old_dphi(lattice%jmglobal) = dphi(lattice%jmglobal) - - do j=1,jm - do i=1,im - - if( tilt.eq.90 .or. tilt.eq.-90 ) then - - cos_chi_f(i,j) = sinnp - sin_chi_f(i,j) = 0.0 - cos_chi_b(i,j) = sinnp - sin_chi_b(i,j) = 0.0 - - else - -c Forward Rotation -c ---------------- - lam_cmp = lon_cmp( lattice%iglobal(i) ) - phi_cmp = lat_cmp( lattice%jglobal(j) ) - - p1 = cosnp*cos(phi_cmp)*cos(lam_cmp-lam_np) - . + sin(phi_cmp)*sinnp - p1 = min(p1, 1.0) - p1 = max(p1,-1.0) - phi_geo = asin( p1 ) - - p2 = sinnp*cos(phi_cmp)*cos(lam_cmp-lam_np) - . - sin(phi_cmp)*cosnp - p2 = p2 / max( cos(phi_geo),eps ) - p2 = min(p2, 1.0) - p2 = max(p2,-1.0) - p2 = acos( p2 ) - - p3 = cos(phi_cmp)*sin(lam_cmp-lam_np) - if( p3.lt.0.0 ) p2 = -p2 - p2 = p2 - lam_0 - lam_geo = mod( p2+3.0*pi,2.0*pi ) - pi - - cos_chi_f(i,j) = (sinnp*cos(phi_cmp) - . -cosnp*sin(phi_cmp)*cos(lam_cmp-lam_np)) - . / max( cos(phi_geo),eps ) - sin_chi_f(i,j) = (cosnp*sin(lam_cmp-lam_np)) - . / max( cos(phi_geo),eps ) - - -c Backward Rotation -c ----------------- - lam_geo = lon_geo( lattice%iglobal(i) ) - phi_geo = lat_geo( lattice%jglobal(j) ) - - p1 = cosnp*cos(phi_geo)*cos(lam_geo+lam_0-pi) - . + sin(phi_geo)*sinnp - p1 = min(p1, 1.0) - p1 = max(p1,-1.0) - phi_cmp = asin( p1 ) - - p2 = sinnp*cos(phi_geo)*cos(lam_geo+lam_0-pi) - . - sin(phi_geo)*cosnp - p2 = p2 / max( cos(phi_cmp),eps ) - p2 = min(p2, 1.0) - p2 = max(p2,-1.0) - p2 = acos( p2 ) - - p3 = cos(phi_geo)*sin(lam_geo+lam_0-pi) - if( p3.lt.0.0 ) p2 = -p2 - p2 = p2 + lam_np - pi - lam_cmp = mod( p2+3.0*pi,2.0*pi ) - pi - - cos_chi_b(i,j) = (sinnp*cos(phi_geo) - . -cosnp*sin(phi_geo)*cos(lam_geo-pi+lam_0)) - . / max( cos(phi_cmp),eps ) - sin_chi_b(i,j) = (cosnp*sin(lam_geo-pi+lam_0)) - . / max( cos(phi_cmp),eps ) - - endif - enddo - enddo - - endif - -c Compute New Vector Wind Field -c ----------------------------- - if( msgn.eq.1 ) then - do L=1,lm - j=1 - do i=1,im*jm - if( u(i,j,L).ne.undef .and. v(i,j,L).ne.undef ) then - utmp = cos_chi_f(i,j)*u(i,j,L) - sin_chi_f(i,j)*v(i,j,L) - vtmp = cos_chi_f(i,j)*v(i,j,L) + sin_chi_f(i,j)*u(i,j,L) - else - utmp = undef - vtmp = undef - endif - u(i,j,L) = utmp - v(i,j,L) = vtmp - enddo - enddo - endif - - if( msgn.eq.-1 ) then - do L=1,lm - j=1 - do i=1,im*jm - if( u(i,j,L).ne.undef .and. v(i,j,L).ne.undef ) then - utmp = cos_chi_b(i,j)*u(i,j,L) - sin_chi_b(i,j)*v(i,j,L) - vtmp = cos_chi_b(i,j)*v(i,j,L) + sin_chi_b(i,j)*u(i,j,L) - else - utmp = undef - vtmp = undef - endif - u(i,j,L) = utmp - v(i,j,L) = vtmp - enddo - enddo - endif - - return - end - - subroutine atoc ( qa,qc,dlam,dphi,im,jm,km,itype,lattice ) - -C ****************************************************************** -C **** **** -C **** This program converts 'A' gridded data **** -C **** to 'C' gridded data. **** -C **** **** -C **** A direct transfer is made for itype = 0 **** -C **** Cubic Interpolation is made in x for itype = 1 **** -C **** Cubic Interpolation is made in y for itype = 2 **** -C **** **** -C ****************************************************************** - - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,km,itype - integer im1,im2,ip1,ip2 - integer jm1,jm2,jp1,jp2,jmx - - real(kind=8) dlam(lattice%imglobal) - real(kind=8) dphi(lattice%jmglobal) - real(kind=8) qa (im,jm,km) - real(kind=8) qc (im,jm,km) - - integer i,j,k - real(kind=8) qxg (-1:im+2,1:jm), dxg(-1:im+2) - real(kind=8) qyg (1:im,-1:jm+2), dyg(-1:jm+2) - - real(kind=8) ap2(im), ap1(im), ap0(im), am1(im) - real(kind=8) bp2(jm), bp1(jm), bp0(jm), bm1(jm) - -C ********************************************************* -C **** mass points **** -C ********************************************************* - - if (itype.eq.0) then - - do k = 1,km - do j = 1,jm - do i = 1,im - qc(i,j,k) = qa(i,j,k) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** stagger in x-direction **** -C ********************************************************* - - if (itype.eq.1) then - -c Ghost the variable lon-grid increments -c -------------------------------------- - do i=1,im - dxg(i) = dlam( lattice%iglobal(i) ) - enddo - - im1 = lattice%iglobal(1) -1 - im2 = lattice%iglobal(1) -2 - ip1 = lattice%iglobal(im)+1 - ip2 = lattice%iglobal(im)+2 - - if( im1.eq.0 ) then - im1 = lattice%imglobal - im2 = lattice%imglobal-1 - endif - if( im2.eq.0 ) then - im2 = lattice%imglobal - endif - if( ip1.eq.lattice%imglobal+1 ) then - ip1 = 1 - ip2 = 2 - endif - if( ip2.eq.lattice%imglobal+1 ) then - ip2 = 1 - endif - - dxg( 0) = dlam( im1 ) - dxg(-1) = dlam( im2 ) - dxg(im+1) = dlam( ip1 ) - dxg(im+2) = dlam( ip2 ) - - - do i=1,im - ap2(i) = ( -0.5*dxg(i)*0.5*dxg(i)*(0.5*dxg(i)+dxg(i-1)) ) - . / ( dxg(i+1)*(dxg(i+1)+dxg(i))*(dxg(i+1)+dxg(i)+dxg(i-1)) ) - ap1(i) = ( (dxg(i+1)+0.5*dxg(i))*0.5*dxg(i)*(0.5*dxg(i)+dxg(i-1)) ) - . / ( dxg(i+1)*dxg(i)*(dxg(i)+dxg(i-1)) ) - ap0(i) = ( (dxg(i+1)+0.5*dxg(i))*0.5*dxg(i)*(0.5*dxg(i)+dxg(i-1)) ) - . / ( dxg(i-1)*dxg(i)*(dxg(i)+dxg(i+1)) ) - am1(i) = ( -0.5*dxg(i)*0.5*dxg(i)*(0.5*dxg(i)+dxg(i+1)) ) - . / ( dxg(i-1)*(dxg(i-1)+dxg(i))*(dxg(i+1)+dxg(i)+dxg(i-1)) ) - enddo - - do k=1,km - call ghostx ( qa(1,1,k),qxg,im,jm,1,2,lattice,'both' ) - do j=1,jm - do i=1,im - qc(i,j,k) = ap2(i)*qxg(i+2,j) + ap1(i)*qxg(i+1,j) - . + ap0(i)*qxg(i ,j) + am1(i)*qxg(i-1,j) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** stagger in y-direction **** -C ********************************************************* - - if (itype.eq.2) then - -c Ghost the variable lat-grid increments -c -------------------------------------- - jmx = jm - if( lattice%pej.eq.lattice%ny-1 ) jmx = jm-1 - - do j=1,jmx - dyg(j) = dphi( lattice%jglobal(j) ) - enddo - - jm1 = lattice%jglobal(1) -1 - jm2 = lattice%jglobal(1) -2 - jp1 = lattice%jglobal(jmx)+1 - jp2 = lattice%jglobal(jmx)+2 - - if( jm1.eq.0 ) then - jm1 = 1 - jm2 = 2 - endif - if( jm2.eq.0 ) then - jm2 = 1 - endif - if( jp1.eq.lattice%jmglobal ) then - jp1 = lattice%jmglobal-1 - jp2 = lattice%jmglobal-2 - endif - if( jp2.eq.lattice%jmglobal ) then - jp2 = lattice%jmglobal-1 - endif - - dyg( 0) = dphi( jm1 ) - dyg(-1) = dphi( jm2 ) - dyg(jmx+1) = dphi( jp1 ) - dyg(jmx+2) = dphi( jp2 ) - - do j=1,jmx - bp2(j) = ( -0.5*dyg(j)*0.5*dyg(j)*(0.5*dyg(j)+dyg(j-1)) ) - . / ( dyg(j+1)*(dyg(j+1)+dyg(j))*(dyg(j+1)+dyg(j)+dyg(j-1)) ) - bp1(j) = ( (dyg(j+1)+0.5*dyg(j))*0.5*dyg(j)*(0.5*dyg(j)+dyg(j-1)) ) - . / ( dyg(j+1)*dyg(j)*(dyg(j)+dyg(j-1)) ) - bp0(j) = ( (dyg(j+1)+0.5*dyg(j))*0.5*dyg(j)*(0.5*dyg(j)+dyg(j-1)) ) - . / ( dyg(j-1)*dyg(j)*(dyg(j)+dyg(j+1)) ) - bm1(j) = ( -0.5*dyg(j)*0.5*dyg(j)*(0.5*dyg(j)+dyg(j+1)) ) - . / ( dyg(j-1)*(dyg(j-1)+dyg(j))*(dyg(j+1)+dyg(j)+dyg(j-1)) ) - enddo - - do k=1,km - call ghosty ( qa(1,1,k),qyg,im,jm,1,0,-1,2,lattice,'both' ) - do j=1,jmx - do i=1,im - qc(i,j,k) = bp2(j)*qyg(i,j+2) + bp1(j)*qyg(i,j+1) - . + bp0(j)*qyg(i,j ) + bm1(j)*qyg(i,j-1) - enddo - enddo - enddo - - endif - - return - end - - subroutine ctoa ( qc,qa,dlam,dphi,im,jm,km,itype,lattice ) - -C ****************************************************************** -C **** **** -C **** This program converts 'C' gridded data **** -C **** to 'A' gridded data. **** -C **** **** -C **** A pos.definite transfer is made for itype = 0 **** -C **** A Cubic Interpolation is made in x for itype = 1 **** -C **** A Cubic Interpolation is made in y for itype = 2 **** -C **** A direct transfer is made for itype = 3 **** -C **** A direct transfer with undef check for itype = 4 **** -C **** **** -C ****************************************************************** - - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - integer im,jm,km,itype - integer im1,im2,ip1,ip2 - integer jm1,jm2,jp1,jp2,jmx - - real(kind=8) dlam(lattice%imglobal) - real(kind=8) dphi(lattice%jmglobal) - real(kind=8) qa (im,jm,km) - real(kind=8) qc (im,jm,km) - - real(kind=8) cnp1,cnp2 - real(kind=8) csp1,csp2 - - integer i,j,k - real(kind=8) qnp,qsp,getcon,undef - real(kind=8) qxg (-1:im+2,1:jm), dxg(-1:im+2) - real(kind=8) qyg (1:im,-1:jm+2), dyg(-1:jm+2) - - real(kind=8) ap1(im), ap0(im), am1(im), am2(im) - real(kind=8) bp1(jm), bp0(jm), bm1(jm), bm2(jm) - - undef = getcon('UNDEF') - -C ********************************************************* -C **** mass points **** -C ********************************************************* - - if (itype.eq.0 .or. itype.eq.3 .or. itype.eq.4) then - - cnp1 = ( dphi(lattice%jmglobal-1)+ dphi(lattice%jmglobal-2) )**2 - . / ( dphi(lattice%jmglobal-2)*(dphi(lattice%jmglobal-2)+2*dphi(lattice%jmglobal-1)) ) - cnp2 = 1.0-cnp1 - cnp1 = 0.5*cnp1 - cnp2 = 0.5*cnp2 - - csp1 = ( dphi(1)+ dphi(2) )**2 - . / ( dphi(2)*(dphi(2)+2*dphi(1)) ) - csp2 = 1.0-csp1 - csp1 = 0.5*csp1 - csp2 = 0.5*csp2 - - - do k = 1,km - -c Direct Transfer of Interior Points -c ---------------------------------- - do j = 1,jm - do i = 1,im - qa(i,j,k) = qc(i,j,k) - enddo - enddo - -c North Pole Point -c ---------------- - if( lattice%pej.eq.lattice%ny-1 ) then - - call ghosty ( qc(1,1,k),qyg,im,jm,1,0,1,2,lattice,'pole' ) - -c Interpolate to Pole Value (4th-order) w/o UNDEF check -c ----------------------------------------------------- - if (itype.eq.0 .or. itype.eq.3) then - do i=1,im - qa(i,jm,k) = cnp1*( qc(i,jm-1,k) + qyg(i,jm+1) ) - . + cnp2*( qc(i,jm-2,k) + qyg(i,jm+2) ) - enddo - call zmean ( qa(1,jm,k),qnp,dlam,im,1,0,.false.,lattice ) - endif - -c Interpolate to Pole Value (4th-order) w/UNDEF check -c --------------------------------------------------- - if (itype.eq.4) then - do i=1,im - if( qc(i,jm-1,k).eq.undef .or. qyg(i,jm+1).eq.undef .or. - . qc(i,jm-2,k).eq.undef .or. qyg(i,jm+2).eq.undef ) then - qa(i,jm,k) = undef - else - qa(i,jm,k) = cnp1*( qc(i,jm-1,k) + qyg(i,jm+1) ) - . + cnp2*( qc(i,jm-2,k) + qyg(i,jm+2) ) - endif - enddo - call zmean ( qa(1,jm,k),qnp,dlam,im,1,0,.true.,lattice ) - endif - -c Unify Pole Values -c ----------------- - if( itype.eq.0 ) qnp = max( qnp,0.0 ) ! Do not allow Constituents < 0 - do i=1,im - qa(i,jm,k) = qnp - enddo - - endif ! End North Pole Check - -c South Pole Point -c ---------------- - if( lattice%pej.eq.0 ) then - - call ghosty ( qc(1,1,k),qyg,im,jm,1,0,1,2,lattice,'pole' ) - -c Interpolate to Pole Value (4th-order) w/o UNDEF check -c ----------------------------------------------------- - if (itype.eq.0 .or. itype.eq.3) then - do i=1,im - qa(i,1,k) = cnp1*( qc(i,2,k) + qyg(i, 0) ) - . + cnp2*( qc(i,3,k) + qyg(i,-1) ) - enddo - call zmean ( qa(1,1,k),qsp,dlam,im,1,0,.false.,lattice ) - endif - -c Interpolate to Pole Value (4th-order) w/UNDEF check -c --------------------------------------------------- - if (itype.eq.4) then - do i=1,im - if( qc(i,2,k).eq.undef .or. qyg(i, 0).eq.undef .or. - . qc(i,3,k).eq.undef .or. qyg(i,-1).eq.undef ) then - qa(i,1,k) = undef - else - qa(i,1,k) = cnp1*( qc(i,2,k) + qyg(i, 0) ) - . + cnp2*( qc(i,3,k) + qyg(i,-1) ) - endif - enddo - call zmean ( qa(1,1,k),qsp,dlam,im,1,0,.true.,lattice ) - endif - -c Unify Pole Values -c ----------------- - if( itype.eq.0 ) qsp = max( qsp,0.0 ) ! Do not allow Constituents < 0 - do i=1,im - qa(i,1 ,k) = qsp - enddo - - endif ! End South Pole Check - - enddo ! End K-Loop - endif - -C ********************************************************* -C **** stagger in x-direction **** -C ********************************************************* - - if (itype.eq.1) then - -c Ghost the variable lon-grid increments -c -------------------------------------- - do i=1,im - dxg(i) = dlam( lattice%iglobal(i) ) - enddo - - im1 = lattice%iglobal(1) -1 - im2 = lattice%iglobal(1) -2 - ip1 = lattice%iglobal(im)+1 - ip2 = lattice%iglobal(im)+2 - - if( im1.eq.0 ) then - im1 = lattice%imglobal - im2 = lattice%imglobal-1 - endif - if( im2.eq.0 ) then - im2 = lattice%imglobal - endif - if( ip1.eq.lattice%imglobal+1 ) then - ip1 = 1 - ip2 = 2 - endif - if( ip2.eq.lattice%imglobal+1 ) then - ip2 = 1 - endif - - dxg( 0) = dlam( im1 ) - dxg(-1) = dlam( im2 ) - dxg(im+1) = dlam( ip1 ) - dxg(im+2) = dlam( ip2 ) - - - do i=1,im - ap1(i) = ( -0.5*dxg(i-1)*0.5*dxg(i-1)*(0.5*dxg(i-1)+dxg(i-2)) ) - . / ( dxg(i)*(dxg(i)+dxg(i-1))*(dxg(i)+dxg(i-1)+dxg(i-2)) ) - ap0(i) = ( (dxg(i)+0.5*dxg(i-1))*0.5*dxg(i-1)*(0.5*dxg(i-1)+dxg(i-2)) ) - . / ( dxg(i)*dxg(i-1)*(dxg(i-1)+dxg(i-2)) ) - am1(i) = ( (dxg(i)+0.5*dxg(i-1))*0.5*dxg(i-1)*(0.5*dxg(i-1)+dxg(i-2)) ) - . / ( dxg(i-2)*dxg(i-1)*(dxg(i-1)+dxg(i)) ) - am2(i) = ( -0.5*dxg(i-1)*0.5*dxg(i-1)*(0.5*dxg(i-1)+dxg(i)) ) - . / ( dxg(i-2)*(dxg(i-2)+dxg(i-1))*(dxg(i)+dxg(i-1)+dxg(i-2)) ) - enddo - - - do k=1,km - call ghostx ( qc(1,1,k),qxg,im,jm,1,2,lattice,'both' ) - do j=1,jm - do i=1,im - qa(i,j,k) = ap1(i)*qxg(i+1,j) + ap0(i)*qxg(i ,j) - . + am1(i)*qxg(i-1,j) + am2(i)*qxg(i-2,j) - enddo - enddo - enddo - - endif - -C ********************************************************* -C **** stagger in y-direction **** -C ********************************************************* - - if (itype.eq.2) then - -c Ghost the variable lat-grid increments -c -------------------------------------- - jmx = jm - if( lattice%pej.eq.lattice%ny-1 ) jmx = jm-1 - - do j=1,jmx - dyg(j) = dphi( lattice%jglobal(j) ) - enddo - - jm1 = lattice%jglobal(1) -1 - jm2 = lattice%jglobal(1) -2 - jp1 = lattice%jglobal(jmx)+1 - jp2 = lattice%jglobal(jmx)+2 - - if( jm1.eq.0 ) then - jm1 = 1 - jm2 = 2 - endif - if( jm2.eq.0 ) then - jm2 = 1 - endif - if( jp1.eq.lattice%jmglobal ) then - jp1 = lattice%jmglobal-1 - jp2 = lattice%jmglobal-2 - endif - if( jp2.eq.lattice%jmglobal ) then - jp2 = lattice%jmglobal-1 - endif - - dyg( 0) = dphi( jm1 ) - dyg(-1) = dphi( jm2 ) - dyg(jmx+1) = dphi( jp1 ) - dyg(jmx+2) = dphi( jp2 ) - - - do j=1,jm - bp1(j) = ( -0.5*dyg(j-1)*0.5*dyg(j-1)*(0.5*dyg(j-1)+dyg(j-2)) ) - . / ( dyg(j)*(dyg(j)+dyg(j-1))*(dyg(j)+dyg(j-1)+dyg(j-2)) ) - bp0(j) = ( (dyg(j)+0.5*dyg(j-1))*0.5*dyg(j-1)*(0.5*dyg(j-1)+dyg(j-2)) ) - . / ( dyg(j)*dyg(j-1)*(dyg(j-1)+dyg(j-2)) ) - bm1(j) = ( (dyg(j)+0.5*dyg(j-1))*0.5*dyg(j-1)*(0.5*dyg(j-1)+dyg(j-2)) ) - . / ( dyg(j-2)*dyg(j-1)*(dyg(j-1)+dyg(j)) ) - bm2(j) = ( -0.5*dyg(j-1)*0.5*dyg(j-1)*(0.5*dyg(j-1)+dyg(j)) ) - . / ( dyg(j-2)*(dyg(j-2)+dyg(j-1))*(dyg(j)+dyg(j-1)+dyg(j-2)) ) - enddo - - - do k=1,km - call ghosty ( qc(1,1,k),qyg,im,jm,1,1,-1,2,lattice,'both' ) - do j=1,jm - do i=1,im - qa(i,j,k) = bp1(j)*qyg(i,j+1) + bp0(j)*qyg(i ,j) - . + bm1(j)*qyg(i,j-1) + bm2(j)*qyg(i,j-2) - enddo - enddo - enddo - - endif - - return - end - - subroutine polewnd (uz,vz,ustr,vstr,dlam,dphi,im,jm,lattice) -C*********************************************************************** -C PURPOSE To compute fictitious winds at and near the pole -C ARGUMENTS DESCRIPTION -C Uz ..... U-WIND on C-Grid -C Vz ..... V-WIND on C-Grid -C Ustr ... U-WIND on C-Grid at pole -C Vstr ... V-WIND on C-Grid near pole -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - integer im,jm - - real(kind=8) Uz (im,jm) - real(kind=8) Vz (im,jm) - real(kind=8) ustr (im,jm) - real(kind=8) vstr (im,jm) - - real(kind=8) dlam (lattice%imglobal) - real(kind=8) dphi (lattice%jmglobal) - -c Local Dynamic Space -c ------------------- - real(kind=8) cosu (lattice%imglobal) - real(kind=8) cosv (lattice%imglobal) - real(kind=8) sinu (lattice%imglobal) - real(kind=8) sinv (lattice%imglobal) - real(kind=8) lamu (lattice%imglobal) - real(kind=8) lamv (lattice%imglobal) - real(kind=8) up (im) - real(kind=8) upc (im) - real(kind=8) ups (im) - real(kind=8) vp (im) - - real(kind=8) pi,a1,a2,a3,uc,us,vc,vs - integer i,j,jmg - - real(kind=8), allocatable :: ug(:,:) - real(kind=8), allocatable :: vg(:,:) - - pi = 4.0*atan(1.0) - jmg = lattice%jmglobal - -C ********************************************************************** -C **** Initialize Winds **** -C ********************************************************************** - - do j=1,jm - do i=1,im - ustr(i,j) = uz(i,j) - vstr(i,j) = vz(i,j) - enddo - enddo - -C ********************************************************************** -C **** Compute Winds at and near the Pole **** -C ********************************************************************** - - if( lattice%pej.eq.0 .or. lattice%pej.eq.lattice%ny-1 ) then - -c Compute Computational Lambda's at U & V points -c ---------------------------------------------- - lamv(1) = -pi - lamu(1) = lamv(1) + dlam(1)*0.5 - do i=2,lattice%imglobal - lamv(i) = lamv(i-1) + dlam(i-1) - lamu(i) = lamv(i) + dlam(i)*0.5 - enddo - - do i=1,lattice%imglobal - cosu(i) = cos( lamu(i) ) - sinu(i) = sin( lamu(i) ) - cosv(i) = cos( lamv(i) ) - sinv(i) = sin( lamv(i) ) - enddo - - endif - -c North Pole -c ---------- - if( lattice%pej.eq.lattice%ny-1 ) then - - allocate ( ug(1:im,-1:jm+2) ) - allocate ( vg(1:im,-1:jm+2) ) - call ghosty ( uz,ug,im,jm,1,0,-1,2,lattice,'pole' ) - call ghosty ( vz,vg,im,jm,1,1,-1,2,lattice,'pole' ) - - a1 = ( dphi(jmg-1)+ dphi(jmg-2) )**2 - . / ( dphi(jmg-2)*(dphi(jmg-2)+2*dphi(jmg-1)) ) - a2 = 1.0-a1 - a1 = a1*0.5 - a2 = a2*0.5 - - do i=1,im - up (i) = a1*( ug(i,jm-1)+ug(i,jm+1) ) - . + a2*( ug(i,jm-2)+ug(i,jm+2) ) - upc(i) = up(i)*cosu( lattice%iglobal(i) ) - ups(i) = up(i)*sinu( lattice%iglobal(i) ) - enddo - - call zmean ( upc,uc,dlam,im,1,1,.false.,lattice ) - call zmean ( ups,us,dlam,im,1,1,.false.,lattice ) - - uc = 2.0*uc - us = 2.0*us - vc = us - vs = -uc - - a3 = - dphi(jmg-1)* (dphi(jmg-1)+dphi(jmg-2))*0.5 - . / ( dphi(jmg-2)+2*dphi(jmg-1) )**2 - a2 = ( dphi(jmg-1) + a3*(2*dphi(jmg-1)+dphi(jmg-2)) ) - . / ( dphi(jmg-2) + 2*dphi(jmg-1) ) - a1 = 1.0-a2-a3 - - do i=1,im - ustr(i,jm) = uc*cosu( lattice%iglobal(i) ) + us*sinu( lattice%iglobal(i) ) - vp(i) = vc*cosv( lattice%iglobal(i) ) + vs*sinv( lattice%iglobal(i) ) - enddo - - do i=1,im - vstr(i,jm-1) = a1*vp(i) + a2*vg(i,jm-2) + a3*vg(i,jm+1) - enddo - - deallocate ( ug,vg ) - endif - - -c South Pole -c ---------- - if( lattice%pej.eq.0 ) then - - allocate ( ug(1:im,-1:jm+2) ) - allocate ( vg(1:im,-1:jm+2) ) - call ghosty ( uz,ug,im,jm,1,0,-1,2,lattice,'pole' ) - call ghosty ( vz,vg,im,jm,1,1,-1,2,lattice,'pole' ) - - a1 = ( dphi(1)+ dphi(2) )**2 - . / ( dphi(2)*(dphi(2)+2*dphi(1)) ) - a2 = 1.0-a1 - a1 = a1*0.5 - a2 = a2*0.5 - - do i=1,im - up (i) = a1*( ug(i,2)+ug(i, 0) ) - . + a2*( ug(i,3)+ug(i,-1) ) - upc(i) = up(i)*cosu( lattice%iglobal(i) ) - ups(i) = up(i)*sinu( lattice%iglobal(i) ) - enddo - - call zmean ( upc,uc,dlam,im,1,1,.false.,lattice ) - call zmean ( ups,us,dlam,im,1,1,.false.,lattice ) - - uc = 2.0*uc - us = 2.0*us - vc = -us - vs = uc - - a3 = - dphi(1)* (dphi(1)+dphi(2))*0.5 - . / ( dphi(2)+2*dphi(1) )**2 - a2 = ( dphi(1) + a3*(2*dphi(1)+dphi(2)) ) - . / ( dphi(2) + 2*dphi(1) ) - a1 = 1.0-a2-a3 - - do i=1,im - ustr(i,1) = uc*cosu( lattice%iglobal(i) ) + us*sinu( lattice%iglobal(i) ) - vp(i) = vc*cosv( lattice%iglobal(i) ) + vs*sinv( lattice%iglobal(i) ) - enddo - - do i=1,im - vstr(i,1) = a1*vp(i) + a2*vg(i,2) + a3*vg(i,-1) - enddo - - deallocate ( ug,vg ) - endif - - return - end - - subroutine ctoa_winds ( uc,vc,ua,va,dlam,dphi,im,jm,lm,lattice ) -C*********************************************************************** -C PURPOSE -C Driver to convert C-Grid wind data to A-Grid wind data -C ARGUMENTS DESCRIPTION -C uc ..... U-WIND on C-Grid -C vc ..... V-WIND on C-Grid -C ua ..... U-WIND on A-Grid -C va ..... V-WIND on A-Grid -C im ..... x-dimension -C jm ..... y-dimension -C lm ..... z-dimension -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - -c Input Variables -c --------------- - integer im,jm,lm - real(kind=8) uc(im,jm,lm) - real(kind=8) vc(im,jm,lm) - real(kind=8) ua(im,jm,lm) - real(kind=8) va(im,jm,lm) - - real(kind=8) dlam(im) - real(kind=8) dphi(jm) - -c Local Variables -c --------------- - integer L - real(kind=8) ut(im,jm,lm) - real(kind=8) vt(im,jm,lm) - - do L=1,lm - call polewnd ( uc(1,1,L),vc(1,1,L), - . ut(1,1,L),vt(1,1,L),dlam,dphi,im,jm,lattice ) - enddo - call ctoa ( ut(1,1,1),ua(1,1,1),dlam,dphi,im,jm,lm,1,lattice ) - call ctoa ( vt(1,1,1),va(1,1,1),dlam,dphi,im,jm,lm,2,lattice ) - - return - end - - subroutine ctoaset ( vars,grid ) -C*********************************************************************** -C PURPOSE -C Converts C-Grid Dynamics Variables to A-Grid Dynamics Variables -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - -c Declare Modules and Data Structures -c ----------------------------------- - use g3_dynamics_state_module - type ( dynamics_vars_type ) vars - type ( dynamics_grid_type ) grid - - call ctoa_winds ( vars%u,vars%v, vars%u,vars%v, - . grid%dlam,grid%dphi,grid%im,grid%jm,grid%lm,grid%lattice ) - - call ctoa ( vars%p ,vars%p ,grid%dlam,grid%dphi,grid%im,grid%jm,1 ,0,grid%lattice ) - call ctoa ( vars%t ,vars%t ,grid%dlam,grid%dphi,grid%im,grid%jm,grid%lm,0,grid%lattice ) - - do m=1,grid%ntracer - call ctoa ( vars%q(1,1,1,m),vars%q(1,1,1,m),grid%dlam,grid%dphi,grid%im,grid%jm,grid%lm,0,grid%lattice ) - enddo - - return - end - - subroutine atocset ( vars,grid ) -C*********************************************************************** -C PURPOSE -C Converts A-Grid Dynamics Variables to C-Grid Dynamics Variables -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - -c Declare Modules and Data Structures -c ----------------------------------- - use g3_dynamics_state_module - type ( dynamics_vars_type ) vars - type ( dynamics_grid_type ) grid - - call atoc ( vars%p, vars%p ,grid%dlam,grid%dphi,grid%im,grid%jm,1 ,0,grid%lattice ) - call atoc ( vars%u, vars%u ,grid%dlam,grid%dphi,grid%im,grid%jm,grid%lm,1,grid%lattice ) - call atoc ( vars%v, vars%v ,grid%dlam,grid%dphi,grid%im,grid%jm,grid%lm,2,grid%lattice ) - call atoc ( vars%t, vars%t ,grid%dlam,grid%dphi,grid%im,grid%jm,grid%lm,0,grid%lattice ) - - do m=1,grid%ntracer - call atoc ( vars%q(1,1,1,m),vars%q(1,1,1,m),grid%dlam,grid%dphi,grid%im,grid%jm,grid%lm,0,grid%lattice ) - enddo - - return - end diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mpi_util.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mpi_util.F deleted file mode 100644 index 85b62e06a..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mpi_util.F +++ /dev/null @@ -1,45 +0,0 @@ - subroutine init_dynamics_grid (grid,imglobal,jmglobal,lm,nt,ak,bk) - use g3_dynamics_state_module - type ( dynamics_grid_type ) grid - - integer imglobal,jmglobal,lm,nt - real(kind=8) ak(lm+1), bk(lm+1) - - integer im,jm,L - real(kind=8) pi,dl,dp - - im = grid%lattice%im( grid%lattice%pei ) - jm = grid%lattice%jm( grid%lattice%pej ) - - pi = 4.0*atan(1.0) - dl = 2.0*pi/ imglobal - dp = pi/(jmglobal-1) - - grid%n = 1 - grid%im = im - grid%jm = jm - grid%lm = lm - grid%ptracer = nt - grid%ntracer = nt - - grid%lam_np = 0.0 - grid%phi_np = 90.0 - grid%lam_0 = 0.0 - - grid%dl = dl - grid%dp = dp - grid%dlam(:) = dl - grid%dphi(:) = dp - - grid%ptop = ak(1) - grid%alf (:) = ak(:) - grid%bet (:) = bk(:) - grid%sige(:) = grid%bet(:) - do L=1,lm - grid%dsig(L) = grid%sige(L+1) - grid%sige(L) - grid% sig(L) = (grid%sige(L+1) + grid%sige(L))*0.5 - enddo - - return - end - diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc.F deleted file mode 100644 index 621608c79..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc.F +++ /dev/null @@ -1,262 +0,0 @@ - subroutine malloc_1d_r (a,im) - implicit none - real(kind=8), dimension(:), pointer :: a - integer i,im,m - if(.not.associated(a)) then - allocate(a(im)) - do i=1,im - a(i) = 0.0 - enddo - else - m=size(a) - if(m.ne.im) then - print *, 'Allocated Array Size (',m,') does not match request (',im,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_2d_r (a,im,jm) - implicit none - real(kind=8), dimension(:,:), pointer :: a - integer i,j,m,im,jm - if(.not.associated(a)) then - allocate(a(im,jm)) - do j=1,jm - do i=1,im - a(i,j) = 0.0 - enddo - enddo - else - m=size(a) - if(m.ne.im*jm) then - print *, 'Allocated Array Size (',m,') does not match request (',im*jm,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_3d_r (a,im,jm,lm) - implicit none - real(kind=8), dimension(:,:,:), pointer :: a - integer i,j,l,im,jm,lm,m - if(.not.associated(a)) then - allocate(a(im,jm,lm)) - do l=1,lm - do j=1,jm - do i=1,im - a(i,j,l) = 0.0 - enddo - enddo - enddo - else - m=size(a) - if(m.ne.im*jm*lm) then - print *, 'Allocated Array Size (',m,') does not match request (',im*jm*lm,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_4d_r (a,im,jm,lm,nm) - implicit none - real(kind=8), dimension(:,:,:,:), pointer :: a - integer i,j,l,n,im,jm,lm,nm,m - if(.not.associated(a)) then - allocate(a(im,jm,lm,nm)) - do n=1,nm - do l=1,lm - do j=1,jm - do i=1,im - a(i,j,l,n) = 0.0 - enddo - enddo - enddo - enddo - else - m=size(a) - if(m.ne.im*jm*lm*nm) then - print *, 'Allocated Array Size (',m,') does not match request (',im*jm*lm*nm,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_1d_i (a,im) - implicit none - integer, dimension(:), pointer :: a - integer i,im,m - if(.not.associated(a)) then - allocate(a(im)) - do i=1,im - a(i) = 0 - enddo - else - m=size(a) - if(m.ne.im) then - print *, 'Allocated Array Size (',m,') does not match request (',im,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_2d_i (a,im,jm) - implicit none - integer, dimension(:,:), pointer :: a - integer i,j,m,im,jm - if(.not.associated(a)) then - allocate(a(im,jm)) - do j=1,jm - do i=1,im - a(i,j) = 0 - enddo - enddo - else - m=size(a) - if(m.ne.im*jm) then - print *, 'Allocated Array Size (',m,') does not match request (',im*jm,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_3d_i (a,im,jm,lm) - implicit none - integer, dimension(:,:,:), pointer :: a - integer i,j,l,im,jm,lm,m - if(.not.associated(a)) then - allocate(a(im,jm,lm)) - do l=1,lm - do j=1,jm - do i=1,im - a(i,j,l) = 0 - enddo - enddo - enddo - else - m=size(a) - if(m.ne.im*jm*lm) then - print *, 'Allocated Array Size (',m,') does not match request (',im*jm*lm,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_4d_i (a,im,jm,lm,nm) - implicit none - integer, dimension(:,:,:,:), pointer :: a - integer i,j,l,n,im,jm,lm,nm,m - if(.not.associated(a)) then - allocate(a(im,jm,lm,nm)) - do n=1,nm - do l=1,lm - do j=1,jm - do i=1,im - a(i,j,l,n) = 0 - enddo - enddo - enddo - enddo - else - m=size(a) - if(m.ne.im*jm*lm*nm) then - print *, 'Allocated Array Size (',m,') does not match request (',im*jm*lm*nm,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_1d_c8 (a,i) - implicit none - character*8, dimension(:), pointer :: a - integer i,m - if(.not.associated(a)) then - allocate(a(i)) - else - m=size(a) - if(m.ne.i) then - print *, 'Allocated Array Size (',m,') does not match request (',i,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_2d_c8 (a,i,j) - implicit none - character*8, dimension(:,:), pointer :: a - integer i,j,m - if(.not.associated(a)) then - allocate(a(i,j)) - else - m=size(a) - if(m.ne.i*j) then - print *, 'Allocated Array Size (',m,') does not match request (',i*j,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_3d_c8 (a,i,j,k) - implicit none - character*8, dimension(:,:,:), pointer :: a - integer i,j,k,m - if(.not.associated(a)) then - allocate(a(i,j,k)) - else - m=size(a) - if(m.ne.i*j*k) then - print *, 'Allocated Array Size (',m,') does not match request (',i*j*k,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end - - - subroutine malloc_4d_c8 (a,i,j,k,l) - implicit none - character*8, dimension(:,:,:,:), pointer :: a - integer i,j,k,l,m - if(.not.associated(a)) then - allocate(a(i,j,k,l)) - else - m=size(a) - if(m.ne.i*j*k*l) then - print *, 'Allocated Array Size (',m,') does not match request (',i*j*k*l,')!' - call my_finalize - call my_exit (101) - endif - endif - return - end diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc_interface b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc_interface deleted file mode 100644 index b2672a85d..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_mymalloc_interface +++ /dev/null @@ -1,69 +0,0 @@ - interface mymalloc - -c Reals -c ----- - subroutine malloc_1d_r (a,i) - real(kind=8), dimension(:), pointer :: a - integer :: i - end subroutine malloc_1d_r - - subroutine malloc_2d_r (a,i,j) - real(kind=8), dimension(:,:), pointer :: a - integer :: i,j - end subroutine malloc_2d_r - - subroutine malloc_3d_r (a,i,j,k) - real(kind=8), dimension(:,:,:), pointer :: a - integer :: i,j,k - end subroutine malloc_3d_r - - subroutine malloc_4d_r (a,i,j,k,l) - real(kind=8), dimension(:,:,:,:), pointer :: a - integer :: i,j,k,l - end subroutine malloc_4d_r - -c Integers -c -------- - subroutine malloc_1d_i (a,i) - integer, dimension(:), pointer :: a - integer :: i - end subroutine malloc_1d_i - - subroutine malloc_2d_i (a,i,j) - integer, dimension(:,:), pointer :: a - integer :: i,j - end subroutine malloc_2d_i - - subroutine malloc_3d_i (a,i,j,k) - integer, dimension(:,:,:), pointer :: a - integer :: i,j,k - end subroutine malloc_3d_i - - subroutine malloc_4d_i (a,i,j,k,l) - integer, dimension(:,:,:,:), pointer :: a - integer :: i,j,k,l - end subroutine malloc_4d_i - -c Character*8 -c ----------- - subroutine malloc_1d_c8 (a,i) - character*8, dimension(:), pointer :: a - integer :: i - end subroutine malloc_1d_c8 - - subroutine malloc_2d_c8 (a,i,j) - character*8, dimension(:,:), pointer :: a - integer :: i,j - end subroutine malloc_2d_c8 - - subroutine malloc_3d_c8 (a,i,j,k) - character*8, dimension(:,:,:), pointer :: a - integer :: i,j,k - end subroutine malloc_3d_c8 - - subroutine malloc_4d_c8 (a,i,j,k,l) - character*8, dimension(:,:,:,:), pointer :: a - integer :: i,j,k,l - end subroutine malloc_4d_c8 - - end interface diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_wrapper.F b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_wrapper.F deleted file mode 100644 index 18e641f6b..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/g3_wrapper.F +++ /dev/null @@ -1,1041 +0,0 @@ - subroutine g3_wrapper (dynamics,phis,scheme,dtphy,nsplit,alpha,omega) - -C*********************************************************************** -C Purpose -C ------- -C Driver for the C-Grid Atmospheric GEOS GCM (Aires Dynamical Core) -C -C Arguments Description -C ---------------------- -C dynamics.. Dynamics State Data Structure -C scheme ... Character Description of Time-Scheme (MATS or LEAP) -C dtphy .... Time-Step in seconds for PHYSICS -C nsplit ... Ratio of Time-Step in seconds for PHYSICS/DYNAMICS -C alpha .... Time Filter Coefficient -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - -c Declare Modules and Data Structures -c ----------------------------------- - use g3_dynamics_state_module - implicit none - -c Declare Data Structures -c ----------------------- - type ( dynamics_state_type ), target :: dynamics - -c Input Parameters -c ---------------- - real(kind=8) phis(dynamics%grid%im,dynamics%grid%jm) - real(kind=8) omega(dynamics%grid%im,dynamics%grid%jm,dynamics%grid%lm) - real(kind=8) dtphy - real*4 alpha - integer nsplit - character*4 scheme - -c Local Variables -c --------------- - real(kind=8) dtdyn - integer im,jm,lm,nq - - character*4 leapfrog, matsuno - logical alarm - logical first - data first /.true./ - data leapfrog /'LEAP'/ - data matsuno /'MATS'/ - - logical brown_campana - real(kind=8) tcoef - -c Local Reference to Dynamics Grid -c -------------------------------- -c integer, pointer :: n - integer n, nm1 - -c Temporary Variables for NP1 State -c --------------------------------- - type ( dynamics_vars_type ) dynamics_vars_np1 - -c Temporary Variables for Total Tendency -c -------------------------------------- - real(kind=8), allocatable :: dpdt(:,:) - real(kind=8), allocatable :: dudt(:,:,:) - real(kind=8), allocatable :: dvdt(:,:,:) - real(kind=8), allocatable :: dtdt(:,:,:) - real(kind=8), allocatable :: dqdt(:,:,:,:) - -c Miscellanious Temporary Variables -c --------------------------------- - integer i,k - real(kind=8) getcon, timestep - -C ********************************************************************* -C ***** Allocate Temporary Work Space **** -C ********************************************************************* - - im = dynamics%grid%im - jm = dynamics%grid%jm - lm = dynamics%grid%lm - nq = dynamics%grid%ntracer - - call create_dynamics_vars ( dynamics_vars_np1,im,jm,lm,nq ) - - allocate ( dpdt(im,jm) ) - allocate ( dudt(im,jm,lm) ) - allocate ( dvdt(im,jm,lm) ) - allocate ( dtdt(im,jm,lm) ) - allocate ( dqdt(im,jm,lm,nq) ) - -C ********************************************************************** -C **** Perform Inner Dynamics Loop **** -C ********************************************************************** - - dtdyn = dtphy/nsplit - - do i=1,nsplit - - n = dynamics%grid%n - nm1 = mod(n,2)+1 - -C ********************************************************************** -C **** Initialize Tendencies **** -C ********************************************************************** - - dpdt(:,:) = 0.0 - dudt(:,:,:) = 0.0 - dvdt(:,:,:) = 0.0 - dtdt(:,:,:) = 0.0 - dqdt(:,:,:,:) = 0.0 - -C ********************************************************************** -C **** Matsuno Predictor Time Scheme **** -C ********************************************************************** - - if(i.eq.1 .or. scheme.eq.matsuno) then - tcoef = 0.0 - timestep = dtdyn - brown_campana = .false. - -c Predictor -c --------- - call g3_dyndrv( dynamics%vars(n),dynamics%vars(n),dynamics%grid,omega, - . dpdt,dudt,dvdt,dtdt,dqdt, - . phis,tcoef,timestep,brown_campana ) - - call shapij ( dynamics%vars(n)%p,dynamics%vars(n)%u,dynamics%vars(n)%v, - . dynamics%vars(n)%t,dynamics%vars(n)%q, - . dudt,dvdt,dtdt,dqdt, - . im,jm,lm,nq,dynamics%grid ) - - call g3_step ( dynamics%vars(n),dynamics%vars(n),dynamics_vars_np1, - . dynamics%grid,dpdt,dudt,dvdt,dtdt,dqdt, - . tcoef,timestep ) - -c Corrector -c --------- - dpdt(:,:) = 0.0 - dudt(:,:,:) = 0.0 - dvdt(:,:,:) = 0.0 - dtdt(:,:,:) = 0.0 - dqdt(:,:,:,:) = 0.0 - - call g3_dyndrv( dynamics%vars(n),dynamics_vars_np1,dynamics%grid,omega, - . dpdt,dudt,dvdt,dtdt,dqdt, - . phis,tcoef,timestep,brown_campana ) - - call shapij ( dynamics%vars(n)%p,dynamics%vars(n)%u,dynamics%vars(n)%v, - . dynamics%vars(n)%t,dynamics%vars(n)%q, - . dudt,dvdt,dtdt,dqdt, - . im,jm,lm,nq,dynamics%grid ) - - call g3_step ( dynamics%vars(n),dynamics_vars_np1,dynamics_vars_np1, - . dynamics%grid,dpdt,dudt,dvdt,dtdt,dqdt, - . tcoef,timestep ) - - endif - -C ********************************************************************** -C **** Leapfrog Time Scheme **** -C ********************************************************************** - - if(i.ne.1 .and. scheme.eq.leapfrog) then - tcoef = alpha - timestep = 2*dtdyn - brown_campana = .true. - - call g3_dyndrv( dynamics%vars(nm1),dynamics%vars(n),dynamics%grid,omega, - . dpdt,dudt,dvdt,dtdt,dqdt, - . phis,tcoef,timestep,brown_campana ) - - call shapij ( dynamics%vars(nm1)%p,dynamics%vars(nm1)%u,dynamics%vars(nm1)%v, - . dynamics%vars(nm1)%t,dynamics%vars(nm1)%q, - . dudt,dvdt,dtdt,dqdt, - . im,jm,lm,nq,dynamics%grid ) - - call g3_step ( dynamics%vars(nm1),dynamics%vars(n),dynamics_vars_np1, - . dynamics%grid,dpdt,dudt,dvdt,dtdt,dqdt, - . tcoef,timestep ) - endif - -C ********************************************************************** -C **** Move Updated Fields into Current Arrays **** -C ********************************************************************** - - if(scheme.eq.leapfrog) dynamics%grid%n = mod(n,2)+1 - n = dynamics%grid%n - - dynamics%vars(n)%p(:,:) = dynamics_vars_np1%p(:,:) - dynamics%vars(n)%u(:,:,:) = dynamics_vars_np1%u(:,:,:) - dynamics%vars(n)%v(:,:,:) = dynamics_vars_np1%v(:,:,:) - dynamics%vars(n)%t(:,:,:) = dynamics_vars_np1%t(:,:,:) - dynamics%vars(n)%q(:,:,:,:) = dynamics_vars_np1%q(:,:,:,:) - -C ********************************************************************** -C **** Update Counter **** -C ********************************************************************** - - enddo - -C ********************************************************************** -C **** Fill Pole Values for Scalars **** -C ********************************************************************** - - call ctoa ( dynamics%vars(n)%p,dynamics%vars(n)%p, - . dynamics%grid%dlam,dynamics%grid%dphi, im,jm,1 ,0,dynamics%grid%lattice ) - call ctoa ( dynamics%vars(n)%t,dynamics%vars(n)%t, - . dynamics%grid%dlam,dynamics%grid%dphi, im,jm,lm,0,dynamics%grid%lattice ) - call ctoa ( omega,omega, - . dynamics%grid%dlam,dynamics%grid%dphi, im,jm,lm,0,dynamics%grid%lattice ) - do k=1,nq - call ctoa ( dynamics%vars(n)%q(1,1,1,k),dynamics%vars(n)%q(1,1,1,k), - . dynamics%grid%dlam,dynamics%grid%dphi, im,jm,lm,0,dynamics%grid%lattice ) - enddo - -C ********************************************************************** -C **** De-Allocate Workspace **** -C ********************************************************************** - - call destroy_dynamics_vars ( dynamics_vars_np1 ) - - deallocate ( dpdt ) - deallocate ( dudt ) - deallocate ( dvdt ) - deallocate ( dtdt ) - deallocate ( dqdt ) - - RETURN - END - - subroutine g3_dyndrv( prev,curr,grid,omega, - . dpdt,dudt,dvdt,dtdt,dqdt, - . phis,alpha,delt,brown_campana ) - -C*********************************************************************** -C PURPOSE -C Driver for the GEOS GCM Dynamics -C -C prev ..... Dynamics State Variable Data Structure (Previous Timestep) -C curr ..... Dynamics State Variable Data Structure (Current Timestep) -C grid ..... Dynamics Grid Data Structure -C omega..... Dynamics Omega Coupling -C pke ...... Dynamics PKE Coupling (Current Timestep) -C dpdt ..... Dynamics Tendency -C dudt ..... Dynamics Tendency -C dvdt ..... Dynamics Tendency -C dtdt ..... Dynamics Tendency -C dqdt ..... Dynamics Tendency -C ALPHA .... Time Filter Coefficient -C DELT ..... Time-Step in seconds -C -C BROWN_CAMPANA ... Logical for Brown-Campana Split Explicit Scheme -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - -c Declare Modules and Data Structures -c ----------------------------------- - use g3_dynamics_state_module - implicit none - type ( dynamics_vars_type ) prev ! Previous Timestep - type ( dynamics_vars_type ) curr ! Current Timestep - type ( dynamics_grid_type ) grid - -c Input Variables -c --------------- - real(kind=8) alpha,delt - logical brown_campana - - real(kind=8) dpdt(grid%im,grid%jm) ! Dynamics Tendency - real(kind=8) dudt(grid%im,grid%jm,grid%lm) ! Dynamics Tendency - real(kind=8) dvdt(grid%im,grid%jm,grid%lm) ! Dynamics Tendency - real(kind=8) dtdt(grid%im,grid%jm,grid%lm) ! Dynamics Tendency - real(kind=8) dqdt(grid%im,grid%jm,grid%lm,grid%ntracer) ! Dynamics Tendency - - real(kind=8) phis(grid%im,grid%jm) ! Earth Coupling - real(kind=8) omega(grid%im,grid%jm,grid%lm) ! Dynamics Coupling - -c Local Copy of Dynamics Grid -c --------------------------- - real(kind=8) ptop, lam_np,phi_np,lam_0 - -c Local Variables -c --------------- - integer i,j,l,m - integer im,jm,lm,nq - real(kind=8) rotation - parameter ( rotation = 86164.09 ) - - real(kind=8) getcon - real(kind=8) timestep, akap, pi, om - real(kind=8) cp, ae, rgas - real(kind=8), allocatable :: pke(:,:,:) - real(kind=8), allocatable :: psigdot(:,:,:) - real(kind=8), allocatable :: vort(:,:,:) - -C ********************************************************************* -C ***** Allocate Temporary Work Space **** -C ********************************************************************* - - im = grid%im - jm = grid%jm - lm = grid%lm - nq = grid%ntracer - - allocate ( pke(im,jm,lm+1) ) - allocate ( psigdot(im,jm,lm) ) - allocate ( vort(im,jm,lm) ) - - ptop = grid%ptop - lam_np = grid%lam_np - phi_np = grid%phi_np - lam_0 = grid%lam_0 - -C ********************************************************************** -C **** Begin Executable Code **** -C ********************************************************************** - - timestep = 0.0 - if( brown_campana ) timestep = delt - - akap = getcon('KAPPA') - pi = 4.*atan(1.) - om = 2.*pi/rotation - cp = getcon('CP') - ae = getcon('EARTH RADIUS') - rgas = getcon('RGAS') - - call getpke ( curr%p,pke,grid,im,jm ) - - call dycore ( im,jm,lm,grid%sige,ptop,nq,timestep, - . om,cp,rgas,ae,lam_np,phi_np,grid%dlam,grid%dphi, - . phis,pke, - . curr%p, curr%u, curr%v, curr%t, curr%q, - . prev%p, prev%u, prev%v, prev%t, prev%q, - . dpdt, dudt, dvdt, dtdt, dqdt, - . omega, vort, psigdot,alpha, grid%lattice ) - -C ********************************************************************** -C **** De-Allocate Workspace **** -C ********************************************************************** - - deallocate ( pke ) - deallocate ( psigdot ) - deallocate ( vort ) - - return - end - - subroutine g3_step ( prev,curr,updt,grid, - . dpdt,dudt,dvdt,dtdt,dqdt, - . alpha,delt ) -C*********************************************************************** -C PURPOSE -C Updates prognostic fields one time-step -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - -c Declare Modules and Data Structures -c ----------------------------------- - use g3_dynamics_state_module - implicit none - type ( dynamics_vars_type ) prev ! Previous Timestep - type ( dynamics_vars_type ) curr ! Current Timestep - type ( dynamics_vars_type ) updt ! Updated Timestep - type ( dynamics_grid_type ) grid ! Dynamics Grid - -c Input Variables -c --------------- - real(kind=8) alpha,delt - - real(kind=8) dpdt(grid%im,grid%jm) ! Dynamics Tendency - real(kind=8) dudt(grid%im,grid%jm,grid%lm) ! Dynamics Tendency - real(kind=8) dvdt(grid%im,grid%jm,grid%lm) ! Dynamics Tendency - real(kind=8) dtdt(grid%im,grid%jm,grid%lm) ! Dynamics Tendency - real(kind=8) dqdt(grid%im,grid%jm,grid%lm,grid%ntracer) ! Dynamics Tendency - -c Local Variables -c --------------- - real(kind=8) pinv (grid%im,grid%jm) - real(kind=8) ple (grid%im,grid%jm,grid%lm+1) - - integer i,j,L,m,im,jm,lm,nq - real(kind=8) ptmp1, ptmp2 - real(kind=8) akap, getcon - - akap = getcon('KAPPA') - - im = grid%im - jm = grid%jm - lm = grid%lm - nq = grid%ntracer - - call ctoa ( curr%p,curr%p,grid%dlam,grid%dphi,im,jm,1 ,0,grid%lattice ) - -C ********************************************************************** -C **** Compute Total Time Tendencies and Update Fields **** -C ********************************************************************** - - do j=1,jm - do i=1,im - updt%p(i,j) = prev%p(i,j) + delt*dpdt(i,j) - pinv(i,j) = 1.0 / updt%p(i,j) - enddo - enddo - -c Mass, Momentum, and Thermodynamic Fields -c ---------------------------------------- - do L=1,lm - do j=1,jm - do i=1,im - updt%u(i,j,L) = prev%u(i,j,L) + delt*dudt(i,j,L) - updt%v(i,j,L) = prev%v(i,j,L) + delt*dvdt(i,j,L) - updt%t(i,j,L) = prev%p(i,j)*prev%t(i,j,L) + delt*dtdt(i,j,L) - enddo - enddo - enddo - -c Active and Passive Tracers -c -------------------------- - do m=1,nq - do L=1,lm - do j=1,jm - do i=1,im - updt%q(i,j,L,m) = prev%p(i,j)*prev%q(i,j,L,m) + delt*dqdt(i,j,L,m) - enddo - enddo - enddo - enddo - -c Fill Negative Values of Specific Humidity -c ----------------------------------------- - call pqcheck ( updt%q,updt%p,grid,im,jm,lm,delt ) - -C ********************************************************************** -C **** Apply Asselin Time Filter **** -C ********************************************************************** - - if( alpha.ne.0.0 ) then - call tmfilt ( prev%p,prev%u,prev%v,prev%t,prev%q, - . curr%p,curr%u,curr%v,curr%t,curr%q, - . updt%p,updt%u,updt%v,updt%t,updt%q, - . im,jm,lm,nq,alpha ) - endif - -C ********************************************************************** -C **** Unscale Variables **** -C ********************************************************************** - - do L=1,lm - do j=1,jm - do i=1,im - updt%t(i,j,L) = updt%t(i,j,L) * pinv(i,j) - enddo - enddo - do m=1,nq - do j=1,jm - do i=1,im - updt%q(i,j,L,m) = updt%q(i,j,L,m) * pinv(i,j) - enddo - enddo - enddo - enddo - - return - end - - subroutine tmfilt ( pnm1,unm1,vnm1,tnm1,qnm1, - . pn ,un ,vn ,tn ,qn , - . pnp1,unp1,vnp1,tnp1,qnp1, - . im,jm,lm,nq,alpha ) - -C*********************************************************************** -C PURPOSE -C Perform asselin time filter -C ARGUMENTS -C ALPHA .. Time filter coefficient -C -C Note: tnp1 and qnp1 variables are mass-weighted -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - implicit none - -c Input Variables -c --------------- - real(kind=8) alpha - integer im,jm,lm,nq ! Dynamics Grid - - real(kind=8) pnm1(im,jm) ! Dynamics State at time-level n-1 - real(kind=8) unm1(im,jm,lm) ! Dynamics State at time-level n-1 - real(kind=8) vnm1(im,jm,lm) ! Dynamics State at time-level n-1 - real(kind=8) tnm1(im,jm,lm) ! Dynamics State at time-level n-1 - real(kind=8) qnm1(im,jm,lm,nq) ! Dynamics State at time-level n-1 - - real(kind=8) pn (im,jm) ! Dynamics State at time-level n - real(kind=8) un (im,jm,lm) ! Dynamics State at time-level n - real(kind=8) vn (im,jm,lm) ! Dynamics State at time-level n - real(kind=8) tn (im,jm,lm) ! Dynamics State at time-level n - real(kind=8) qn (im,jm,lm,nq) ! Dynamics State at time-level n - - real(kind=8) pnp1(im,jm) ! Dynamics State at time-level n+1 - real(kind=8) unp1(im,jm,lm) ! Dynamics State at time-level n+1 - real(kind=8) vnp1(im,jm,lm) ! Dynamics State at time-level n+1 - real(kind=8) tnp1(im,jm,lm) ! Dynamics State at time-level n+1 - real(kind=8) qnp1(im,jm,lm,nq) ! Dynamics State at time-level n+1 - - -c Local Variables -c --------------- - integer i,j,L,m - real(kind=8) one,ahalf, a1,a2 - - PARAMETER ( ONE = 1.0 ) - PARAMETER ( AHALF = 0.5 ) - -c Local Dynamic Space -c ------------------- - real(kind=8) pinv(im,jm) - - A1 = ONE - ALPHA - A2 = AHALF * ALPHA - -C ********************************************************************** -C **** PI-WEIGHT TIME-LEVEL N FOR MASS FIELDS **** -C ********************************************************************** - - DO 10 L=1,lm - - do j = 1,jm - do i = 1,im - tn(i,j,L) = pn(i,j)*tn(i,j,L) - enddo - enddo - - do m=1,nq - do j = 1,jm - do i = 1,im - qn(i,j,L,m) = pn(i,j)*qn(i,j,L,m) - enddo - enddo - enddo - -C ********************************************************************** -C **** APPLY ASSELIN TIME FILTER **** -C ********************************************************************** - - do j = 1,jm - do i = 1,im - un(i,j,L) = A1*un(i,j,L) + A2*( unm1(i,j,L) + unp1(i,j,L) ) - vn(i,j,L) = A1*vn(i,j,L) + A2*( vnm1(i,j,L) + vnp1(i,j,L) ) - tn(i,j,L) = A1*tn(i,j,L) + A2*( tnm1(i,j,L) * pnm1(i,j) + tnp1(i,j,L) ) - enddo - enddo - - do m=1,nq - do j = 1,jm - do i = 1,im - qn(i,j,L,m) = A1*qn(i,j,L,m) + A2*( qnm1(i,j,L,m)*pnm1(i,j) + qnp1(i,j,L,m) ) - enddo - enddo - enddo - - 10 CONTINUE - -C ********************************************************************** -C **** APPLY ASSELIN TIME FILTER ON PRESSURE **** -C **** UNSCALE TIME-LEVEL N2 **** -C ********************************************************************** - - do j = 1,jm - do i = 1,im - pn (i,j) = A1*pn(i,j) + A2*( pnm1(i,j) + pnp1(i,j) ) - pinv(i,j) = ONE / pn(i,j) - enddo - enddo - - DO 20 L=1,lm - do j = 1,jm - do i = 1,im - tn(i,j,L) = tn(i,j,L)*pinv(i,j) - enddo - enddo - do m=1,nq - do j = 1,jm - do i = 1,im - qn(i,j,L,m) = qn(i,j,L,m)*pinv(i,j) - enddo - enddo - enddo - 20 CONTINUE - - RETURN - END - - subroutine pqcheck ( PQZ,PZ,grid,IM,JM,LM,delt ) -C*********************************************************************** -C Purpose -C Check Specific Humidity Field for Negative values -C -C Argument Description -C PQZ ........ (ps-ptop)*Specific Humidity (mb g/g) -C PZ ......... Pi = ps-ptop (mb) -C grid ....... Dynamics Grid Structure -C IM ......... Zonal Dimension -C JM ......... Meridional Dimension -C LM ......... Vertical Dimension -C DELT ....... Timestep (Seconds) -C -C Note: The Diagnostics are divided by 2 because: -C a) The Timestep = 2*DT for Leapfrog, or -C b) The Routine is called twice for Matsuno -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use g3_dynamics_state_module - implicit none - type ( dynamics_grid_type ) grid - - integer im,jm,lm,nd - real(kind=8) delt - - real(kind=8) PQZ(IM,JM,LM) - real(kind=8) PZ(IM,JM) - real(kind=8) ple(im,jm,lm+1) - - integer i,j,L - real(kind=8) getcon,grav,fact - real(kind=8) tmp(im,jm) - real(kind=8), allocatable :: q(:,:,:) - - grav = getcon('GRAVITY') - fact = 86400/delt/2 - - call getple ( pz,ple,grid,im,jm ) - - allocate ( q(im,jm,lm) ) - do L=1,lm - do j=1,jm - do i=1,im - q(i,j,L) = pqz(i,j,L)/pz(i,j) - enddo - enddo - enddo - -c Fill Negative Specific Humidities -c --------------------------------- - do L=2,lm - do j=1,jm - do i=1,im - if( q(i,j,L-1).lt.0.0 ) THEN - q(i,j,L ) = q(i,j,L) + q(i,j,L-1)*( ple(i,j,L )-ple(i,j,L-1) ) - . /( ple(i,j,L+1)-ple(i,j,L ) ) - q(i,j,L-1) = 0.0 - endif - enddo - enddo - enddo - - do j=1,jm - do i=1,im - if( q(i,j,lm).lt.0.0 ) q(i,j,lm) = 0.0 - enddo - enddo - - do L=1,lm - do j=1,jm - do i=1,im - pqz(i,j,L) = pz(i,j)*q(i,j,L) - enddo - enddo - enddo - - deallocate ( q ) - return - end - - subroutine shapij ( PZ,UZ,VZ,TZ,QZ,DUDT,DVDT,DTDT,dqdt, - . im,jm,lm,nq,grid ) -C*********************************************************************** -C PURPOSE -C Used to globally filter U-wind, V-wind, Temperature and Moisture -C to damp small scale dispersive waves. -C -C ARGUMENTS DESCRIPTION -C PZ ..... SURFACE PRESSURE FIELD (PS-PTOP) -C UZ ..... U-WIND -C VZ ..... V-WIND -C TZ ..... POTENTIAL TEMPERATURE -C QZ ..... Tracers -C DUDT ... U-Wind Tendency -C DVDT ... V-Wind Tendency -C DTDT ... Mass weighted Theta Tendency -C dqdt ... Mass weighted Tracer Tendencies -C im ..... X-DIMENSION OF FIELDS -C jm ..... Y-DIMENSION OF FIELDS -C lm ..... Z-DIMENSION OF FIELDS -C nq ..... Number of Tracers -C GRID ... Dynamics Grid Structure -C -C REMARKS: -C 1) Full Shapiro Filter is assumed to have a time-scale of TAU -C 2) SHAPT Diagnostic is approximate in Leapfrog Mode since PK -C is defined for Timestep N (or N*), while SHAPT is defined for -C Timestep NM1 -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - - use g3_dynamics_state_module - implicit none - type ( dynamics_grid_type ) grid - - integer im,jm,lm,nd - real(kind=8) tau,df - integer i,j,L,m,nq - - PARAMETER ( TAU = 5400.0 ) - PARAMETER ( DF = 1.0/TAU ) - - real(kind=8) PZ(im,jm) - real(kind=8) UZ(im,jm,lm) - real(kind=8) VZ(im,jm,lm) - real(kind=8) TZ(im,jm,lm) - real(kind=8) QZ(im,jm,lm,nq) - - real(kind=8) DUDT(im,jm,lm) - real(kind=8) DVDT(im,jm,lm) - real(kind=8) DTDT(im,jm,lm) - real(kind=8) dqdt(im,jm,lm,nq) - -c Local Dynamic Space -c ------------------- - real(kind=8) SHAPU (im,jm) - real(kind=8) SHAPV (im,jm) - real(kind=8) SHAPT (im,jm) - real(kind=8) SHAPQ (im,jm) - real(kind=8) pinv (im,jm) - real(kind=8) pk (im,jm,lm) - real(kind=8) pref (lm) - - logical first - data first /.true./ - - real(kind=8) dlam_min,pi - integer, allocatable, save :: nshap(:) - -c Determine Order of Shapiro Filter -c --------------------------------- - if(first) then - - allocate ( nshap(lm) ) - - pi = 4.0*atan(1.0) - dlam_min = 1.0e15 - do i=1,grid%lattice%imglobal - if( grid%dlam(i).lt.dlam_min ) dlam_min = grid%dlam(i) - enddo - dlam_min = dlam_min*180./pi - -#if 0 - if( grid%lattice%myid.eq.0 ) then - print * - print *, 'DLAM_min = ',dlam_min - print * - endif -#endif - - call getpl ( 100000.0-grid%ptop,pref,grid,1,1 ) - pref = pref*0.01 - do L=1,lm - -c Zonal Dimension >= 5 Degrees -c ---------------------------- - if( dlam_min.ge.4.9 ) then - if(pref(L).ge.7.) nshap(L) = 16 - if(pref(L).lt.7. .and. - . pref(L).ge.1.) nshap(L) = 8 - if(pref(L).lt.1.) nshap(L) = 4 - endif - -c Zonal Dimension >= 2.5 Degrees and < 5 Degrees -c ---------------------------------------------- - if( dlam_min.ge.2.4 .and. dlam_min.lt.4.9 ) then - if(pref(L).ge.7.) nshap(L) = 8 - if(pref(L).lt.7. .and. - . pref(L).ge.1.) nshap(L) = 8 - if(pref(L).lt.1.) nshap(L) = 4 - endif - -c Zonal Dimension < 2.5 Degrees -c ----------------------------- - if( dlam_min.lt.2.4 ) then - nshap(L) = 4 - endif - -#if 0 - if( grid%lattice%myid.eq.0 ) write(6,6001) L,pref(L),nshap(L) - 6001 format(' SHAPIJ: Level ',i3,' Pref: ',f8.3,' using Shapiro filter of order',i3) -#endif - enddo -c if( grid%lattice%myid.eq.0 ) print * - first = .false. - endif - -C ********************************************************************** -C **** Prepare Pole and Near-Pole Values for Shapiro **** -C ********************************************************************** - - call ctoa ( tz,tz,grid%dlam,grid%dphi,im,jm,lm,0,grid%lattice ) - do m = 1,nq - call ctoa ( qz(1,1,1,m),qz(1,1,1,m),grid%dlam,grid%dphi,im,jm,lm,0,grid%lattice ) - enddo - do L=1,lm - call polewnd ( uz(1,1,L),vz(1,1,L), - . uz(1,1,L),vz(1,1,L),grid%dlam,grid%dphi,im,jm,grid%lattice ) - enddo - -C ********************************************************************** -C **** FRACTIONAL FILTER ON FIELDS U, V, T AND Q **** -C ********************************************************************** - - do 1000 L=1,lm - call shap ( uz(1,1,L),shapu,im,jm,1,-1,nshap(L),grid%lattice ) - call shap ( vz(1,1,L),shapv,im,jm,1,-2,nshap(L),grid%lattice ) - call shap ( tz(1,1,L),shapt,im,jm,1, 1,nshap(L),grid%lattice ) - -C ********************************************************************** -C **** MASS-WEIGHT SHAPIRO ADJUSTMENTS **** -C ********************************************************************** - - do j=1,jm - do I=1,im - SHAPU(I,j) = SHAPU(I,j) * DF - SHAPV(I,j) = SHAPV(I,j) * DF - SHAPT(I,j) = PZ(I,j) * SHAPT(I,j) * DF - enddo - enddo - -C ********************************************************************** -C **** UPDATE MASS-WEIGHTED TENDENCIES **** -C ********************************************************************** - - do j=1,jm - do I=1,im - DUDT(I,j,L) = DUDT(I,j,L) - SHAPU(I,j) - DVDT(I,j,L) = DVDT(I,j,L) - SHAPV(I,j) - DTDT(I,j,L) = DTDT(I,j,L) - SHAPT(I,j) - enddo - enddo - -c Do Tracers -c ---------- - do m = 1,nq - call shap ( qz(1,1,L,m),shapq,im,jm,1,1,nshap(L),grid%lattice ) - do j=1,jm - do I=1,im - shapq(i,j) = pz(i,j) * shapq(i,j)*df - dqdt(i,j,l,m) = dqdt(i,j,l,m) - shapq(i,j) - enddo - enddo - enddo - - 1000 continue - - return - end - - subroutine shap ( q,dq,im,jm,lm,msgn,n,lattice ) -C*********************************************************************** -C Purpose: -C Apply Shapiro Filter to a General Field -C Description of Parameters -C q ....... Input Field -C dq ...... Output Increment: q-filter(q) -C im ...... Zonal Dimension -C jm ...... Meridional Dimension -C lm ...... Vertical Dimension -C msgn .... Set msgn = +1 For Scalar Field -C msgn = -1 For U_Wind Field -C msgn = -2 For V-Wind Field -C n ....... Shapiro Filter Order -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** - use g3_dynamics_lattice_module - implicit none - type ( dynamics_lattice_type ) lattice - - integer im,jm,lm,msgn,n - real(kind=8) q(im,jm,lm), dq(im,jm,lm) - - integer i,j,k,L,m - real(kind=8) fac - real(kind=8), allocatable :: d1(:,:,:) - real(kind=8), allocatable :: d2(:,:,:) - - m = n/2 - fac = (-0.25)**m - -C ********************************************************************** -C **** Filter Mass or U-Wind Points **** -C ********************************************************************** - - if ( msgn.eq.1 .or. msgn.eq.-1 ) then - -c Zonal Direction -c --------------- - allocate( d1(1-m:im+m,jm,lm) ) - allocate( d2(1-m:im+m,jm,lm) ) - - d2 = 0.0 - call ghostx ( q,d1,im,jm,lm,m,lattice,'both' ) - - do L=1,lm - do j=1,jm - do k=1,m - do i=2-m,im+m - d2(i,j,L) = d1(i,j,L)-d1(i-1,j,L) - enddo - do i=1-m,im+m-1 - d1(i,j,L) = d2(i+1,j,L)-d2(i,j,L) - enddo - enddo - do i=1,im - dq(i,j,L) = q(i,j,L)-d1(i,j,L)*fac ! Filtered Field in X - enddo - enddo - enddo - - deallocate ( d1,d2 ) - -c Meridional Direction -c -------------------- - allocate( d1(im,1-m:jm+m,lm) ) - allocate( d2(im,1-m:jm+m,lm) ) - - d2 = 0.0 - call ghosty ( dq,d1,im,jm,lm,0,msgn,m,lattice,'both' ) - - do L=1,lm - do k=1,m - do j=2-m,jm+m - do i=1,im - d2(i,j,L) = d1(i,j,L)-d1(i,j-1,L) - enddo - enddo - do j=1-m,jm+m-1 - do i=1,im - d1(i,j,L) = d2(i,j+1,L)-d2(i,j,L) - enddo - enddo - enddo - enddo - - endif - -C ********************************************************************** -C **** Filter V-Wind Points **** -C ********************************************************************** - - if ( msgn.eq.-2 ) then - -c Zonal Direction -c --------------- - allocate( d1(1-m:im+m,jm,lm) ) - allocate( d2(1-m:im+m,jm,lm) ) - - d2 = 0.0 - call ghostx ( q,d1,im,jm,lm,m,lattice,'both' ) - - do L=1,lm - do j=1,jm - do k=1,m - do i=2-m,im+m - d2(i,j,L) = d1(i,j,L)-d1(i-1,j,L) - enddo - do i=1-m,im+m-1 - d1(i,j,L) = d2(i+1,j,L)-d2(i,j,L) - enddo - enddo - do i=1,im - dq(i,j,L) = q(i,j,L)-d1(i,j,L)*fac ! Filtered Field in X - enddo - enddo - enddo - - deallocate ( d1,d2 ) - -c Meridional Direction -c -------------------- - allocate( d1(im,1-m:jm+m,lm) ) - allocate( d2(im,1-m:jm+m,lm) ) - - d2 = 0.0 - call ghosty ( dq,d1,im,jm,lm,1,-1,m,lattice,'both' ) - - do L=1,lm - do k=1,m - do j=2-m,jm+m - do i=1,im - d2(i,j,L) = d1(i,j,L)-d1(i,j-1,L) - enddo - enddo - do j=1-m,jm+m-1 - do i=1,im - d1(i,j,L) = d2(i,j+1,L)-d2(i,j,L) - enddo - enddo - enddo - enddo - - endif - -C ********************************************************************** -C **** Compute Full Field Filter and Increment **** -C ********************************************************************** - - do L=1,lm - do j=1,jm - do i=1,im - dq(i,j,L) = dq(i,j,L)-d1(i,j,L)*fac ! Filtered Field in X and Y - dq(i,j,L) = q(i,j,L)-dq(i,j,L) ! Shapiro Filter Increment - enddo - enddo - enddo - - deallocate ( d1,d2 ) - - return - end diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/gmap.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/gmap.F90 deleted file mode 100644 index 0cab9746b..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/gmap.F90 +++ /dev/null @@ -1,516 +0,0 @@ -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine gmap(im, jm, nq, akap, & - km, pk3d_m, pe3d_m, u_m, v_m, pt_m, q_m, & - kn, pk3d_n, pe3d_n, u_n, v_n, pt_n, q_n ) -!****6***0*********0*********0*********0*********0*********0**********72 - - implicit none - - integer im, jm - integer km, kn, nq - -! Input: -! original data km-level - - real*8 u_m(im,jm,km) - real*8 v_m(im,jm,km) - real*8 pt_m(im,jm,km) - real*8 q_m(im,jm,km,nq) - real*8 pk3d_m(im,jm,km+1) - real*8 pe3d_m(im,jm,km+1) - - real*8 pk3d_n(im,jm,kn+1) - real*8 pe3d_n(im,jm,kn+1) - -! Output: -! New data (kn-level) - real*8 u_n(im,jm,kn) - real*8 v_n(im,jm,kn) - real*8 pt_n(im,jm,kn) - real*8 q_n(im,jm,kn,nq) - -! local (private) - integer i, j, k, n, ic - - real*8 pe1(im,km+1) ,pe2(im,kn+1) - real*8 pk1(im,km+1) ,pk2(im,kn+1) - real*8 dp1(im,km) ,dp2(im,kn) - real*8 u1(im,km) , u2(im,kn) - real*8 v1(im,km) , v2(im,kn) - real*8 t1(im,km) , t2(im,kn) - real*8 q1(im,km,nq), q2(im,kn,nq) - - real*8 ptop - real*8 akap - real*8 ple, pek, dak, bkh - real*8 undef - real*8 big - parameter ( undef = 1.e15 ) - parameter ( big = 1.e10 ) - - do 2000 j=1,jm - -! Copy original data to local 2D arrays. - - do k=1,km+1 - do i=1,im - pe1(i,k) = pe3d_m(i,j,k) - pk1(i,k) = pk3d_m(i,j,k) - enddo - enddo - - do k=1,kn+1 - do i=1,im - pe2(i,k) = pe3d_n(i,j,k) - pk2(i,k) = pk3d_n(i,j,k) - enddo - enddo - - do k=1,km - do i=1,im - dp1(i,k) = pk1(i,k+1)-pk1(i,k) - u1(i,k) = u_m(i,j,k) - v1(i,k) = v_m(i,j,k) - t1(i,k) = pt_m(i,j,k) - enddo - enddo - do n=1,nq - do k=1,km - do i=1,im - q1(i,k,n) = q_m(i,j,k,n) - enddo - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pk2(i,k+1)-pk2(i,k) - enddo - enddo - -! map pt -! ------ - call mappm ( km, pk1, dp1, t1, kn, pk2, dp2, t2, im, 1, 7 ) - - do k=1,km - do i=1,im - dp1(i,k) = pe1(i,k+1)-pe1(i,k) - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pe2(i,k+1)-pe2(i,k) - enddo - enddo - -! map u,v,q,oz -! ------------ - do n=1,nq - call mappm ( km, pe1, dp1, q1(1,1,n), kn, pe2, dp2, q2(1,1,n), im, 0, 7 ) - enddo - call mappm ( km, pe1, dp1, u1, kn, pe2, dp2, u2, im, -1, 7 ) - call mappm ( km, pe1, dp1, v1, kn, pe2, dp2, v2, im, -1, 7 ) - - do k=1,kn - do i=1,im - u_n(i,j,k) = u2(i,k) - v_n(i,j,k) = v2(i,k) - pt_n(i,j,k) = t2(i,k) - enddo - enddo - do n=1,nq - do k=1,kn - do i=1,im - q_n(i,j,k,n) = q2(i,k,n) - enddo - enddo - enddo - -2000 continue - - return - end - - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine mappm(km, pe1, dp1, q1, kn, pe2, dp2, q2, im, iv, kord) -!****6***0*********0*********0*********0*********0*********0**********72 -! IV = 0: constituents -! IV = 1: potential temp -! IV =-1: winds -! -! Mass flux preserving mapping: q1(im,km) -> q2(im,kn) -! -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate - - parameter (kmax = 200) - parameter (R3 = 1./3., R23 = 2./3.) - - real*8 dp1(im,km), dp2(im,kn), & - q1(im,km), q2(im,kn), & - pe1(im,km+1), pe2(im,kn+1) - integer kord - -! local work arrays - real*8 a4(4,im,km) - - do k=1,km - do i=1,im - a4(1,i,k) = q1(i,k) - enddo - enddo - - call ppm2m(a4, dp1, im, km, iv, kord) - -! Lowest layer: constant distribution - do i=1, im - a4(2,i,km) = q1(i,km) - a4(3,i,km) = q1(i,km) - a4(4,i,km) = 0. - enddo - - do 5555 i=1,im - k0 = 1 - do 555 k=1,kn - - if(pe2(i,k+1) .le. pe1(i,1)) then -! Entire grid above old ptop - q2(i,k) = a4(2,i,1) - elseif(pe2(i,k) .ge. pe1(i,km+1)) then -! Entire grid below old ps - q2(i,k) = a4(3,i,km) - elseif(pe2(i,k ) .lt. pe1(i,1) .and. & - pe2(i,k+1) .gt. pe1(i,1)) then -! Part of the grid above ptop - q2(i,k) = a4(1,i,1) - else - - do 45 L=k0,km -! locate the top edge at pe2(i,k) - if( pe2(i,k) .ge. pe1(i,L) .and. & - pe2(i,k) .le. pe1(i,L+1) ) then - k0 = L - PL = (pe2(i,k)-pe1(i,L)) / dp1(i,L) - if(pe2(i,k+1) .le. pe1(i,L+1)) then - -! entire new grid is within the original grid - PR = (pe2(i,k+1)-pe1(i,L)) / dp1(i,L) - TT = R3*(PR*(PR+PL)+PL**2) - q2(i,k) = a4(2,i,L) + 0.5*(a4(4,i,L)+a4(3,i,L) & - - a4(2,i,L))*(PR+PL) - a4(4,i,L)*TT - goto 555 - else -! Fractional area... - delp = pe1(i,L+1) - pe2(i,k) - TT = R3*(1.+PL*(1.+PL)) - qsum = delp*(a4(2,i,L)+0.5*(a4(4,i,L)+ & - a4(3,i,L)-a4(2,i,L))*(1.+PL)-a4(4,i,L)*TT) - dpsum = delp - k1 = L + 1 - goto 111 - endif - endif -45 continue - -111 continue - do 55 L=k1,km - if( pe2(i,k+1) .gt. pe1(i,L+1) ) then - -! Whole layer.. - - qsum = qsum + dp1(i,L)*q1(i,L) - dpsum = dpsum + dp1(i,L) - else - delp = pe2(i,k+1)-pe1(i,L) - esl = delp / dp1(i,L) - qsum = qsum + delp * (a4(2,i,L)+0.5*esl* & - (a4(3,i,L)-a4(2,i,L)+a4(4,i,L)*(1.-r23*esl)) ) - dpsum = dpsum + delp - k0 = L - goto 123 - endif -55 continue - delp = pe2(i,k+1) - pe1(i,km+1) - if(delp .gt. 0.) then -! Extended below old ps - qsum = qsum + delp * a4(3,i,km) - dpsum = dpsum + delp - endif -123 q2(i,k) = qsum / dpsum - endif -555 continue -5555 continue - - return - end - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine ppm2m(a4,delp,im,km,iv,kord) -!****6***0*********0*********0*********0*********0*********0**********72 -! iv = 0: positive definite scalars -! iv = 1: others -! iv =-1: winds - - implicit none - - integer im, km, lmt, iv - integer kord - integer i, k, km1 - real*8 a4(4,im,km), delp(im,km) - -! local arrays. - real*8 dc(im,km),delq(im,km) - real*8 h2(im,km) - real*8 a1, a2, a3, b2, c1, c2, c3, d1, d2, f1, f2, f3, f4 - real*8 s1, s2, s3, s4, ss3, s32, s34, s42, sc - real*8 qmax, qmin, cmax, cmin - real*8 dm, qm, dq, tmp - -! Local scalars: - real*8 qmp - real*8 lac - - km1 = km - 1 - - do 500 k=2,km - do 500 i=1,im - delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) -500 a4(4,i,k ) = delp(i,k-1) + delp(i,k) - - do 1220 k=2,km1 - do 1220 i=1,im - c1 = (delp(i,k-1)+0.5*delp(i,k))/a4(4,i,k+1) - c2 = (delp(i,k+1)+0.5*delp(i,k))/a4(4,i,k) - tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / & - (a4(4,i,k)+delp(i,k+1)) - qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k) - qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp) -1220 continue - -!****6***0*********0*********0*********0*********0*********0**********72 -! 4th order interpolation of the provisional cell edge value -!****6***0*********0*********0*********0*********0*********0**********72 - - do 12 k=3,km1 - do 12 i=1,im - c1 = delq(i,k-1)*delp(i,k-1) / a4(4,i,k) - a1 = a4(4,i,k-1) / (a4(4,i,k) + delp(i,k-1)) - a2 = a4(4,i,k+1) / (a4(4,i,k) + delp(i,k)) - a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(a4(4,i,k-1)+a4(4,i,k+1)) * & - ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - & - delp(i,k-1)*a1*dc(i,k ) ) -12 continue - -! Area preserving cubic with 2nd deriv. = 0 at the boundaries -! Top - do i=1,im - d1 = delp(i,1) - d2 = delp(i,2) - qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) - dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) - c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) - c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1) - a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2) - dc(i,1) = a4(1,i,1) - a4(2,i,1) -! No over- and undershoot condition - cmax = max(a4(1,i,1), a4(1,i,2)) - cmin = min(a4(1,i,1), a4(1,i,2)) - a4(2,i,2) = max(cmin,a4(2,i,2)) - a4(2,i,2) = min(cmax,a4(2,i,2)) - enddo - - if(iv == 0) then - do i=1,im - a4(2,i,1) = max(0.,a4(2,i,1)) - a4(2,i,2) = max(0.,a4(2,i,2)) - enddo - elseif(iv == -1) then - do i=1,im - if( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. - enddo - endif - -!****6***0*********0*********0*********0*********0*********0**********72 - -! Bottom -! Area preserving cubic with 2nd deriv. = 0 at the surface - do 15 i=1,im - d1 = delp(i,km) - d2 = delp(i,km1) - qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) - dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) - c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) - c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1) - a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km) - dc(i,km) = a4(3,i,km) - a4(1,i,km) -!****6***0*********0*********0*********0*********0*********0**********72 -! No over- and undershoot condition - cmax = max(a4(1,i,km), a4(1,i,km1)) - cmin = min(a4(1,i,km), a4(1,i,km1)) - a4(2,i,km) = max(cmin,a4(2,i,km)) - a4(2,i,km) = min(cmax,a4(2,i,km)) -!****6***0*********0*********0*********0*********0*********0**********72 -15 continue - - if(iv .eq. 0) then - do i=1,im - a4(2,i,km) = max(0.,a4(2,i,km)) - a4(3,i,km) = max(0.,a4(3,i,km)) - enddo - endif - - do 20 k=1,km1 - do 20 i=1,im - a4(3,i,k) = a4(2,i,k+1) -20 continue -! -! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) -! - -! Top 2 and bottom 2 layers always use monotonic mapping - - do k=1,2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) - enddo - - if(kord == 7) then -!****6***0*********0*********0*********0*********0*********0**********72 -! Huynh's 2nd constraint -!****6***0*********0*********0*********0*********0*********0**********72 - do k=2, km1 - do i=1,im - h2(i,k) = delq(i,k) - delq(i,k-1) - enddo - enddo - - do 4000 k=3, km-2 - do 3000 i=1, im -! Right edges - qmp = a4(1,i,k) + 2.0*delq(i,k-1) - lac = a4(1,i,k) + 1.5*h2(i,k-1) + 0.5*delq(i,k-1) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax) -! Left edges - qmp = a4(1,i,k) - 2.0*delq(i,k) - lac = a4(1,i,k) + 1.5*h2(i,k+1) - 0.5*delq(i,k) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax) -! Recompute A6 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) -3000 continue -! Additional constraint to prevent negatives - if (iv == 0) then - call kmppm(dc(1,k),a4(1,1,k),im, 2) - endif -4000 continue - - else - - lmt = kord - 3 - lmt = max(0, lmt) - if (iv .eq. 0) lmt = min(2, lmt) - - do k=3, km-2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, lmt) - enddo - endif - - do 5000 k=km1,km - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) -5000 continue - - return - end - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine kmppm(dm, a4, km, lmt) -!****6***0*********0*********0*********0*********0*********0**********72 - implicit none - - real*8 r12 - parameter (r12 = 1./12.) - - integer km, lmt - integer i - real*8 a4(4,km),dm(km) - real*8 da1, da2, a6da - real*8 fmin - real*8 qmp - - if (lmt .eq. 3) return -! Full constraint - - if(lmt .eq. 0) then - do 100 i=1,km - if(dm(i) .eq. 0.) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da .lt. -da2) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da .gt. da2) then - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif -100 continue - elseif (lmt .eq. 2) then -! Positive definite - -! Positive definite constraint - do 250 i=1,km - if(abs(a4(3,i)-a4(2,i)) .ge. -a4(4,i)) go to 250 - fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 - if(fmin.ge.0.) go to 250 - if(a4(1,i).lt.a4(3,i) .and. a4(1,i).lt.a4(2,i)) then - a4(3,i) = a4(1,i) - a4(2,i) = a4(1,i) - a4(4,i) = 0. - elseif(a4(3,i) .gt. a4(2,i)) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - else - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif -250 continue - - elseif (lmt == 1) then - -! Improved full monotonicity constraint (Lin) -! Note: no need to provide first guess of A6 <-- a4(4,i) - - do i=1, km - qmp = 2.*dm(i) - a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) - a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) - a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) ) - enddo - endif - - return - end - diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/par_xsum.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/par_xsum.F90 deleted file mode 100644 index f5625927f..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/par_xsum.F90 +++ /dev/null @@ -1,167 +0,0 @@ -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: par_xsum --- Calculate x-sum bit-wise consistently -! -! !INTERFACE: -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine par_xsum(grid, a, ltot, xsum) -!****6***0*********0*********0*********0*********0*********0**********72 -! -! !USES: -#if defined ( SPMD ) - use parutilitiesmodule, only : parcollective, SUMOP -#endif - use dynamics_vars, only : T_FVDYCORE_GRID - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - integer, intent(in) :: ltot ! number of quantities to be summed - real (r8) a(grid%ifirstxy:grid%ilastxy,ltot) ! input vector to be summed - -! !OUTPUT PARAMETERS: - real (r8) xsum(ltot) ! sum of all vector entries - -! !DESCRIPTION: -! This subroutine calculates the sum of "a" in a reproducible -! (sequentialized) fashion which should give bit-wise identical -! results irrespective of the number of MPI processes. -! -! !REVISION HISTORY: -! -! AAM 00.11.01 : Created -! WS 03.10.22 : pmgrid removed (now spmd_dyn) -! WS 04.10.04 : added grid as an argument; removed spmd_dyn -! WS 05.05.25 : removed ifirst, ilast, im as arguments (in grid) -! WS 06.12.24 : rewritten to use collective communication call -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! !Local - real(r8), parameter :: D0_0 = 0.0_r8 - real (r8) quan_all(grid%im,ltot) - integer i,l,ifirst,ilast,im - - quan_all = D0_0 - ifirst = grid%ifirstxy - ilast = grid%ilastxy - im = grid%im - do i=ifirst,ilast - do l=1,ltot - quan_all(i,l)=a(i,l) - enddo - enddo - -#if defined ( SPMD ) - if ( grid%nprxy_x > 1 ) then - call parcollective( grid%commxy_x, SUMOP, im, ltot, quan_all ) - endif -#endif - - do l=1,ltot - xsum(l) = D0_0 - do i=1,im - xsum(l) = xsum(l) + quan_all(i,l) - enddo - enddo - - return -!EOC - end subroutine par_xsum -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: par_xsum_r4 --- Calculate x-sum bit-wise consistently (real4) -! -! !INTERFACE: -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine par_xsum_r4(grid, a, ltot, sum) -!****6***0*********0*********0*********0*********0*********0**********72 -! -! !USES: -#if defined ( SPMD ) - use parutilitiesmodule, only : parexchangevector -#endif - use dynamics_vars, only : T_FVDYCORE_GRID - use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 - - implicit none - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - integer, intent(in) :: ltot ! number of quantities to be summed - real (r4) a(grid%ifirstxy:grid%ilastxy,ltot) ! input vector to be summed - -! !OUTPUT PARAMETERS: - real (r8) sum(ltot) ! sum of all vector entries - -! !DESCRIPTION: -! This subroutine calculates the sum of "a" in a reproducible -! (sequentialized) fashion which should give bit-wise identical -! results irrespective of the number of MPI processes. -! -! !REVISION HISTORY: -! -! WS 05.04.08 : Created from par_xsum -! WS 05.05.25 : removed ifirst, ilast, im as arguments (in grid) -! WS 06.06.28 : Fixed bug in sequential version -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! !Local - real(r4), parameter :: E0_0 = 0.0_r4 - integer :: nprxy_x, commxy_x - real (r4) quan_all(grid%im*ltot) - integer i,l,icount,ipe, ifirst,ilast,im - -#if defined ( SPMD ) - real (r4) quan_send(grid%nprxy_x*ltot*(grid%ilastxy-grid%ifirstxy+1)) - integer sendcount(grid%nprxy_x) - integer recvcount(grid%nprxy_x) -#endif - - ifirst = grid%ifirstxy - ilast = grid%ilastxy - im = grid%im -#if defined ( SPMD ) - nprxy_x = grid%nprxy_x - commxy_x = grid%commxy_x - - icount=0 - do ipe=1,nprxy_x - sendcount(ipe) = ltot*(ilast-ifirst+1) - do i=ifirst,ilast - do l=1,ltot - icount=icount+1 - quan_send(icount)=a(i,l) - enddo - enddo - enddo - call parexchangevector( commxy_x, sendcount, quan_send, & - recvcount, quan_all ) -#else - do l=1,ltot - do i=1,im - quan_all((i-1)*ltot+l)=a(i,l) - enddo - enddo -#endif - - do l=1,ltot - sum(l) = E0_0 - do i=1,im - sum(l) = sum(l) + quan_all((i-1)*ltot+l) - enddo - enddo - - return -!EOC - end subroutine par_xsum_r4 -!----------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/pft_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/pft_module.F90 deleted file mode 100644 index c65a99bfe..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/pft_module.F90 +++ /dev/null @@ -1,467 +0,0 @@ -module pft_module_ -!BOP -! -! !MODULE: pft_module --- polar filters -! -! !USES: - - use shr_kind_mod, only: r8 => shr_kind_r8 - -#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 - -! -! !PUBLIC MEMBER FUNCTIONS: - public pft2d, pft_cf, fftfax, pftinit, fftrans -! -! !DESCRIPTION: -! -! This module provides fast-Fourier transforms -! -! \begin{tabular}{|l|l|} \hline \hline -! pftinit & \\ \hline -! pft2d & \\ \hline -! pft\_cf & \\ \hline -! fftfax & \\ \hline -! fftrans & \\ \hline -! \hline -! \end{tabular} -! -! !REVISION HISTORY: -! 01.01.30 Lin Integrated into this module -! 01.03.26 Sawyer Added ProTeX documentation -! 05.05.25 Sawyer Merged CAM and GEOS5 versions (CAM vectorization) -! 05.07.26 Worley Revised module using for Cray X1 version -! 06.09.08 Sawyer Magic numbers isolated in F90 parameters -! -!EOP -!----------------------------------------------------------------------- - private - real(r8), parameter :: D0_0 = 0.0_r8 - real(r8), parameter :: D1EM20 = 1.0e-20_r8 - real(r8), parameter :: D0_5 = 0.5_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D1_01 = 1.01_r8 - real(r8), parameter :: D2_0 = 2.0_r8 - real(r8), parameter :: D4_0 = 4.0_r8 - real(r8), parameter :: D8_0 = 8.0_r8 - real(r8), parameter :: D180_0 =180.0_r8 - - integer, save :: ifax(13) !ECMWF fft - real(r8), allocatable, save :: trigs(:) ! reentrant code?? - -CONTAINS - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: pftinit --- Two-dimensional FFT initialization -! -! !INTERFACE: - subroutine pftinit(im) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im ! Total X dimension - -! !DESCRIPTION: -! -! Perform a two-dimensional FFT initialization -! -! !REVISION HISTORY: -! 05.05.15 Mirin Put into this module -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer icffta - real(r8) rcffta - -#if defined( LIBSCI_FFT ) - allocate( trigs(2*im+100) ) - icffta = 0 - rcffta = D0_0 - call dzfftm(0, im, icffta, rcffta, rcffta, icffta, & - rcffta, icffta, trigs, rcffta, icffta) -#else - allocate( trigs(3*im/2+1) ) - call fftfax(im, ifax, trigs) -#endif - - return -!EOC - end subroutine pftinit -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: pft2d --- Two-dimensional fast Fourier transform -! -! !INTERFACE: - subroutine pft2d(p, s, damp, im, jp, q1, q2) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im ! Total X dimension - integer jp ! Total Y dimension - real(r8) s(jp) ! 3-point algebraic filter - real(r8) damp(im,jp) ! FFT damping coefficients - -! !INPUT/OUTPUT PARAMETERS: - real(r8) q1( im+2, *) ! Work array - real(r8) q2(*) ! Work array - real(r8) p(im,jp) ! Array to be polar filtered - -! !DESCRIPTION: -! -! Perform a two-dimensional fast Fourier transformation. -! -! !REVISION HISTORY: -! 01.01.30 Lin Put into this module -! 01.03.26 Sawyer Added ProTeX documentation -! 02.04.05 Sawyer Integrated newest FVGCM version -! 05.05.17 Sawyer Merged CAM and GEOS-5 -! 05.07.26 Worley Removed ifax, trigs from arg list -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real(r8) rsc, bt - integer i, j, n, nj - -!Local Auto arrays: - real(r8) ptmp(0:im+1) -!!! real(r8) q1( im+2, jp) -!!! real(r8) q2( (im+1)*jp ) - integer jf(jp) - - nj = 0 - - do 200 j=1,jp - -#if !defined ( ALGEBRAIC_FILTER ) - if(s(j) > D1_01) then -#else - if(s(j) > D1_01 .and. s(j) <= D4_0) then - - rsc = D1_0/s(j) - bt = D0_5*(s(j)-D1_0) - - do i=1,im - ptmp(i) = p(i,j) - enddo - ptmp( 0) = p(im,j) - ptmp(im+1) = p(1 ,j) - - do i=1,im - p(i,j) = rsc * ( ptmp(i) + bt*(ptmp(i-1)+ptmp(i+1)) ) - enddo - - elseif(s(j) > D4_0) then -#endif - -! Packing for FFT - nj = nj + 1 - jf(nj) = j - - do i=1,im - q1(i,nj) = p(i,j) - enddo - q1(im+1,nj) = D0_0 - q1(im+2,nj) = D0_0 - - endif -200 continue - - if( nj == 0) return - - call fftrans(damp, im, jp, nj, jf, q1, q2) - - do n=1,nj - do i=1,im - p(i,jf(n)) = q1(i,n) - enddo - enddo - - return -!EOC - end subroutine pft2d -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: fftrans --- Two-dimensional fast Fourier transform -! -! !INTERFACE: - subroutine fftrans(damp, im, jp, nj, jf, q1, q2) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im ! Total X dimension - integer jp ! Total Y dimension - integer nj ! Number of transforms - integer jf(jp) ! J index versus transform number - real(r8) damp(im,jp) ! FFT damping coefficients - -! !INPUT/OUTPUT PARAMETERS: - real(r8) q1( im+2, *) ! Work array - real(r8) q2(*) ! Work array - -! !DESCRIPTION: -! -! Perform a two-dimensional fast Fourier transformation. -! -! !REVISION HISTORY: -! 05.05.15 Mirin Initial combined version -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i, n - real (r8) ooim - -!Local Auto arrays: - -#if defined( LIBSCI_FFT ) - real (r8) qwk(2*im+4, jp) - complex(r8) cqf(im/2+1, jp) - integer imo2p -#elif defined( SGI_FFT ) - integer*4 im_4, nj_4, imp2_4 -#endif - -#if defined( LIBSCI_FFT ) - imo2p = im/2 + 1 - ooim = D1_0/real(im,r8) - - call dzfftm(-1, im, nj, D1_0, q1, im+2, cqf, imo2p, & - trigs, qwk, 0) - - do n=1,nj - do i=3,imo2p - cqf(i,n) = cqf(i,n) * damp(2*i-2,jf(n)) - enddo - enddo - - call zdfftm( 1, im, nj, ooim, cqf, imo2p, q1, im+2, & - trigs, qwk, 0) -#elif defined( SGI_FFT ) - im_4 = im - nj_4 = nj - imp2_4 = im+2 - call dzfftm1du (-1, im_4, nj_4, q1, 1, imp2_4, trigs) - do n=1,nj - do i=5,im+2 - q1(i,n) = q1(i,n) * damp(i-2,jf(n)) - enddo - enddo - call dzfftm1du (1, im_4, nj_4, q1, 1, imp2_4, trigs) - ooim = D1_0/real(im,r8) - do n=1,nj - do i=1,im+2 - q1(i,n) = ooim*q1(i,n) - enddo - enddo -#else - call fft991 (q1, q2, trigs, ifax, 1, im+2, im, nj, -1) - do n=1,nj - do i=5,im+2 - q1(i,n) = q1(i,n) * damp(i-2,jf(n)) - enddo - enddo - call fft991 (q1, q2, trigs, ifax, 1, im+2, im, nj, 1) -#endif - - return -!EOC - end subroutine fftrans -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: pft_cf --- Calculate algebraic and FFT polar filters -! -! !INTERFACE: - subroutine pft_cf(im, jm, js2g0, jn2g0, jn1g1, sc, se, dc, de, & - cosp, cose, ycrit) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im ! Total X dimension - integer jm ! Total Y dimension - integer js2g0 ! j south limit ghosted 0 (SP: from 2) - integer jn2g0 ! j north limit ghosted 0 (NP: from jm-1) - integer jn1g1 ! j north limit ghosted 1 (starts jm) - real (r8) cosp(jm) ! cosine array - real (r8) cose(jm) ! cosine array - real (r8) ycrit ! critical value - -! !OUTPUT PARAMETERS: - real (r8) sc(js2g0:jn2g0) ! Algebric filter at center - real (r8) se(js2g0:jn1g1) ! Algebric filter at edge - real (r8) dc(im,js2g0:jn2g0) ! FFT filter at center - real (r8) de(im,js2g0:jn1g1) ! FFT filter at edge - -! !DESCRIPTION: -! -! Compute coefficients for the 3-point algebraic and the FFT -! polar filters. -! -! !REVISION HISTORY: -! -! 99.01.01 Lin Creation -! 99.08.20 Sawyer/Lin Changes for SPMD mode -! 01.01.30 Lin Put into this module -! 01.03.26 Sawyer Added ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real (r8), parameter :: pi = 3.14159265358979323846_R8 - integer i, j - real (r8) dl, coszc, cutoff, phi, damp - - coszc = cos(ycrit*pi/D180_0) - -! INIT fft polar coefficients: - dl = pi/real(im,r8) - cutoff = D1EM20 - - do j=js2g0,jn2g0 - do i=1,im - dc(i,j) = D1_0 - enddo - enddo - - do j=js2g0,jn1g1 - do i=1,im - de(i,j) = D1_0 - enddo - enddo - -! write(6,*) '3-point polar filter coefficients:' - -!************ -! Cell center -!************ - do j=js2g0,jn2g0 - sc(j) = (coszc/cosp(j))**2 - -#if !defined ( ALGEBRAIC_FILTER ) - if( sc(j) > D1_0 ) then -#else - if(sc(j) > D1_0 .and. sc(j) <= D2_0) then - sc(j) = D1_0 + (sc(j)-D1_0)/(sc(j)+D1_0) - elseif(sc(j) > D2_0 .and. sc(j) <= D4_0) then - sc(j) = D1_0 + sc(j)/(D8_0-sc(j)) - elseif(sc(j) > D4_0 ) then -#endif - -! FFT filter - do i=1,im/2 - phi = dl * i - damp = min((cosp(j)/coszc)/sin(phi),D1_0)**2 - if(damp < cutoff) damp = D0_0 - dc(2*i-1,j) = damp - dc(2*i ,j) = damp - enddo - - endif - enddo - -!************ -! Cell edges -!************ - do j=js2g0,jn1g1 - se(j) = (coszc/cose(j))**2 - -#if !defined ( ALGEBRAIC_FILTER ) - if( se(j) > D1_0 ) then -#else - if(se(j) > D1_0 .and. se(j) <= D2_0 ) then - se(j) = D1_0 + (se(j)-D1_0)/(se(j)+D1_0) - elseif(se(j) > D2_0 .and. se(j) <= D4_0) then - se(j) = D1_0 + se(j)/(D8_0-se(j)) - elseif(se(j) > D4_0 ) then -#endif -! FFT - do i=1,im/2 - phi = dl * i - damp = min((cose(j)/coszc)/sin(phi), D1_0)**2 - if(damp < cutoff) damp = D0_0 - de(2*i-1,j) = damp - de(2*i ,j) = damp - enddo - endif - enddo - return -!EOC - end subroutine pft_cf -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: fftfax --- Initialize FFT -! -! !INTERFACE: - subroutine fftfax (n, ifaxx, trigss) - -! !USES: - implicit none - -! !DESCRIPTION: -! -! Initialize the fast Fourier transform. If CPP token SGI_FFT is -! set, SGI libraries will be used. Otherwise the Fortran code -! is inlined. -! -! !REVISION HISTORY: -! -! 99.11.24 Sawyer Added wrappers for SGI -! 01.03.26 Sawyer Added ProTeX documentation -! 05.07.26 Worley Modified version for Cray X1 -! -!EOP -!----------------------------------------------------------------------- -!BOC - - integer n - -#if defined( SGI_FFT ) - real(r8) trigss(1) - integer ifaxx(*) -! local - integer*4 nn - - nn=n - call dzfftm1dui (nn,trigss) -#else - integer ifaxx(13) - real(r8) trigss(3*n/2+1) - call set99(trigss,ifaxx,n) -#endif - return -!EOC - end subroutine fftfax -!----------------------------------------------------------------------- - -end module pft_module_ diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/remap.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/remap.F90 deleted file mode 100644 index e25260941..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/remap.F90 +++ /dev/null @@ -1,158 +0,0 @@ - subroutine remap ( ple,u,v,thv,qtr,phis_in,phis_out,ak,bk,im,jm,lm,km ) - -!*********************************************************************** -! -! Purpose -! Driver for remapping fields to new topography -! -! Argument Description -! ple ...... model edge pressure -! u ....... model zonal wind -! v ....... model meridional wind -! thv ..... model virtual potential temperature -! q ....... model specific humidity -! o3 ...... model ozone -! phis_in... model surface geopotential (input) -! phis_out.. model surface geopotential (output) -! ak ....... model vertical dimension -! bk ....... model vertical dimension -! -! im ....... zonal dimension -! jm ....... meridional dimension -! lm ....... meridional dimension -! -!*********************************************************************** - - use MAPL - use dynamics_vars, only : T_TRACERS - - implicit none - integer im,jm,lm,km - -! Input variables -! --------------- - type(T_TRACERS) qtr(km) - real*8 ple(im,jm,lm+1) - real*8 u(im,jm,lm) - real*8 v(im,jm,lm) - real*8 thv(im,jm,lm) - real*8 q(im,jm,lm) - real*8 o3(im,jm,lm) - real*8 phis_in (im,jm) - real*8 phis_out(im,jm) - - real*8 ak(lm+1) - real*8 bk(lm+1) - -! Local variables -! --------------- - real*8, allocatable :: ps (:,:) - real*8, allocatable :: phi (:,:,:) - real*8, allocatable :: pke (:,:,:) - real*8, allocatable :: ple_out(:,:,:) - real*8, allocatable :: pke_out(:,:,:) - - real*8, allocatable :: delp(:,:,:) - real*8, allocatable :: u_out(:,:,:) - real*8, allocatable :: v_out(:,:,:) - real*8, allocatable :: thv_out(:,:,:) - real*8, allocatable :: q_in (:,:,:,:) - real*8, allocatable :: q_out(:,:,:,:) - - real*8 kappa,cp,rgas,eps,rvap - integer i,j,L,n,k - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - eps = rvap/rgas-1.0 - cp = rgas/kappa - - allocate( ps (im,jm) ) - allocate( phi (im,jm,lm+1) ) - allocate( pke (im,jm,lm+1) ) - allocate( ple_out(im,jm,lm+1) ) - allocate( pke_out(im,jm,lm+1) ) - - allocate( delp(im,jm,lm) ) - allocate( u_out(im,jm,lm) ) - allocate( v_out(im,jm,lm) ) - allocate( thv_out(im,jm,lm) ) - allocate( q_in (im,jm,lm,km)) - allocate( q_out(im,jm,lm,km)) - -! Construct Input Heights -! ----------------------- - pke(:,:,:) = ple(:,:,:)**kappa - - phi(:,:,lm+1) = phis_in(:,:) - do L=lm,1,-1 - phi(:,:,L) = phi(:,:,L+1) + cp*thv(:,:,L)*( pke(:,:,L+1)-pke(:,:,L) ) - enddo - -! Compute new surface pressure consistent with output topography -! -------------------------------------------------------------- - do j=1,jm - do i=1,im - L = lm - do while ( phi(i,j,L).lt.phis_out(i,j) ) - L = L-1 - enddo - ps(i,j) = ple(i,j,L+1)*( 1+(phi(i,j,L+1)-phis_out(i,j))/(cp*thv(i,j,L)*pke(i,j,L+1)) )**(1.0/kappa) - enddo - enddo - -! Construct fv pressure variables using new surface pressure -! ---------------------------------------------------------- - do L=1,lm+1 - do j=1,jm - do i=1,im - ple_out(i,j,L) = ak(L) + bk(L)*ps(i,j) - enddo - enddo - enddo - pke_out(:,:,:) = ple_out(:,:,:)**kappa - -! Map original fv state onto new eta grid -! --------------------------------------- - - do k=1,size(qtr) - if(qtr(k)%is_r4) then - q_in(:,:,:,k) = qtr(k)%content_r4 - else - q_in(:,:,:,k) = qtr(k)%content - end if - enddo - - call gmap ( im,jm,km, kappa, & - lm, pke ,ple ,u ,v ,thv ,q_in , & - lm, pke_out,ple_out,u_out,v_out,thv_out,q_out) - - do k=1,size(qtr) - if(qtr(k)%is_r4) then - qtr(k)%content_r4 = q_out(:,:,:,k) - else - qtr(k)%content = q_out(:,:,:,k) - end if - enddo - - ple(:,:,:) = ple_out(:,:,:) - u(:,:,:) = u_out(:,:,:) - v(:,:,:) = v_out(:,:,:) - thv(:,:,:) = thv_out(:,:,:) - - deallocate( ps ) - deallocate( phi ) - deallocate( pke ) - deallocate( ple_out ) - deallocate( pke_out ) - - deallocate( delp ) - deallocate( u_out ) - deallocate( v_out ) - deallocate( thv_out ) - deallocate( q_in ) - deallocate( q_out ) - - return - end diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/shr_kind_mod.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/shr_kind_mod.F90 deleted file mode 100644 index 6e17ed3eb..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/ARIESg3_GridComp/shr_kind_mod.F90 +++ /dev/null @@ -1,27 +0,0 @@ -!=============================================================================== -! CVS: $Id$ -! CVS: $Source$ -! CVS: $Name$ -!=============================================================================== - -MODULE shr_kind_mod - - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - public -#ifdef NO_R16 - integer,parameter :: SHR_KIND_R16= selected_real_kind(12) ! 8 byte real -#else - integer,parameter :: SHR_KIND_R16= selected_real_kind(24) ! 16 byte real -#endif - integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real - integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real - integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real - integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer - integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer - integer,parameter :: SHR_KIND_IN = kind(1) ! native integer - integer,parameter :: SHR_KIND_CL = 256 ! long char - integer,parameter :: SHR_KIND_CS = 80 ! short char - -END MODULE shr_kind_mod diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/CMakeLists.txt index c59826405..c0f011ceb 100644 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/CMakeLists.txt @@ -2,9 +2,7 @@ esma_set_this () set (alldirs FVdycoreCubed_GridComp - FVdycore_GridComp GEOSdatmodyn_GridComp - ARIESg3_GridComp ) if (NOT EXISTS ${CMAKE_CURRENT_SOURCE_DIR}/GEOSdatmodyn_GridComp) diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/BlendingMod.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/BlendingMod.F90 deleted file mode 100644 index 577f02288..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/BlendingMod.F90 +++ /dev/null @@ -1,195 +0,0 @@ -!------------------------------------------------------------------------- -! NASA/GSFC, Global Modeling & Assimilation Office, Code 610.1 ! -!------------------------------------------------------------------------- -!BOP -! -! !MODULE: BlendingMod.F90 --- Blend forecast and analysis wind and -! virtual potential temperature. -! -! !INTERFACE: -! - -module BlendingMod - - -! !USES: - - use MAPL, only : MAPL_CP, MAPL_KAPPA - - - implicit none - - private - -! -! !PUBLIC MEMBER FUNCTIONS: -! - public blend_wind_height - -! -! !DESCRIPTION: This module implements blending of forecast and analysis -! fields. -! -! -! !REVISION HISTORY: -! -! 12Aug2010 Darmenov Initial code. -! -!EOP -!------------------------------------------------------------------------- - - integer, parameter :: r8 = 8 - integer, parameter :: r4 = 4 - - real(r8), parameter :: c_p = MAPL_CP - real(r8), parameter :: kappa = MAPL_KAPPA - - -contains - -!------------------------------------------------------------------------- -! NASA/GSFC Global Modeling & Assimilation Office, Code 610.1 ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: blend_wind_height --- Blend wind and scaled virtual potential -! temperature by tampering wind and geopotential height. -! -! !INTERFACE: -! -subroutine blend_wind_height(u_f, v_f, thv_f, pe_f, & - u_a, v_a, thv_a, pe_a, & - p_below, p_above, & - ims, ime, jms, jme, km) -! -! !USES: -! - implicit none -! -! !INPUT PARAMETERS: -! - real(r8), dimension(ims:ime, jms:jme, km), intent(in) :: u_f ! forecast wind u-component - real(r8), dimension(ims:ime, jms:jme, km), intent(in) :: v_f ! forecast wind v-component - real(r8), dimension(ims:ime, jms:jme, km), intent(in) :: thv_f ! forecast scaled virtual potential temperature - real(r8), dimension(ims:ime, jms:jme, km+1), intent(in) :: pe_f ! forecast pressure at edge levels - real(r8), dimension(ims:ime, jms:jme, km), intent(inout) :: u_a ! analysis wind u-component - real(r8), dimension(ims:ime, jms:jme, km), intent(inout) :: v_a ! analysis wind v-component - real(r8), dimension(ims:ime, jms:jme, km), intent(inout) :: thv_a ! analysis scaled virtual potential temperature - real(r8), dimension(ims:ime, jms:jme, km+1), intent(in) :: pe_a ! analysis pressure at edge levels - - real(r8), intent(in) :: p_below ! blending zone - bottom pressure - real(r8), intent(in) :: p_above ! blending zone - top pressure - - integer, intent(in) :: ims ! tile indices - integer, intent(in) :: ime ! - integer, intent(in) :: jms ! - integer, intent(in) :: jme ! - integer, intent(in) :: km ! global vertical dimension - -! -! !OUTPUT PARAMETERS: -! - -! -! !DESCRIPTION: -! -! !REVISION HISTORY: -! -! 12Aug2010 Darmenov Initial code -! -!EOP -!------------------------------------------------------------------------- - -! !LOCAL VARIABLES: - - character(len=*), parameter :: myname = 'blend_wind_height' - - integer, parameter :: k1 = 1 - integer, parameter :: k2 = 2 - - integer :: k - - real(r8), dimension (:,:,:), allocatable :: pl_a - - real(r8), dimension (:,:,:), allocatable :: dz_pe_f_kappa - real(r8), dimension (:,:,:), allocatable :: dz_pe_a_kappa - - real(r8), dimension (:,:,:), allocatable :: phi_f - real(r8), dimension (:,:,:), allocatable :: phi_a - - real(r8), dimension (:,:,:), allocatable :: alpha - real(r8), dimension (:,:,:), allocatable :: alpha_delta_phi - real(r8), dimension (:,:,:), allocatable :: dz_alpha_delta_phi - - real(r8), dimension (:,:,:), allocatable :: delta_thv - - - allocate(dz_pe_f_kappa(ims:ime,jms:jme,km)) - allocate(dz_pe_a_kappa(ims:ime,jms:jme,km)) - - allocate(phi_f(ims:ime,jms:jme,km+1)) - allocate(phi_a(ims:ime,jms:jme,km+1)) - - allocate(alpha_delta_phi(ims:ime,jms:jme,km+1)) - allocate(dz_alpha_delta_phi(ims:ime,jms:jme,km)) - - - ! d/dz(p^kappa) = p^kappa(:,:,k+1) - p^kappa(:,:,k) - dz_pe_f_kappa(:,:,k1:km) = pe_f(:,:,k2:km+1)**kappa - pe_f(:,:,k1:km)**kappa - dz_pe_a_kappa(:,:,k1:km) = pe_a(:,:,k2:km+1)**kappa - pe_a(:,:,k1:km)**kappa - - - ! forecast and analysis geopotentials - phi_f(:,:,km+1) = 0.0 - phi_a(:,:,km+1) = 0.0 - - do k = km, k1, -1 - phi_f(:,:,k) = phi_f(:,:,k+1) - c_p * thv_f(:,:,k) * dz_pe_f_kappa(:,:,k) - phi_a(:,:,k) = phi_a(:,:,k+1) - c_p * thv_a(:,:,k) * dz_pe_a_kappa(:,:,k) - end do - - - ! d/dz(blending factor * geopotential increment) - alpha_delta_phi = (pe_a - p_above)/(p_below - p_above) * (phi_a - phi_f) - dz_alpha_delta_phi(:,:,k1:km) = alpha_delta_phi(:,:,k2:km+1) - alpha_delta_phi(:,:,k1:km) - - ! not needed past this point - deallocate(alpha_delta_phi) - deallocate(phi_f) - deallocate(phi_a) - - - ! blending factor used to tamper wind and geopotential increments - allocate(alpha(ims:ime,jms:jme,km)) - allocate(delta_thv(ims:ime,jms:jme,km)) - allocate(pl_a(ims:ime,jms:jme,km)) - - pl_a(:,:,k1:km) = 0.5 * (pe_a(:,:,k1:km) + pe_a(:,:,k2:km+1)) - - ! calculate the blending factor (alpha) and temperature increment - where (pl_a <= p_above) - alpha = 0.0 - delta_thv = 0.0 - elsewhere (pl_a < p_below) - alpha = (pl_a - p_above)/(p_below - p_above) - delta_thv = (-1/c_p) * dz_alpha_delta_phi * dz_pe_a_kappa - elsewhere - alpha = 1.0 - delta_thv = thv_a - thv_f - end where - - - ! increment wind and temperature - where (pl_a < p_below) - u_a = u_f + alpha*(u_a - u_f) - v_a = v_f + alpha*(v_a - v_f) - - thv_a = thv_f + delta_thv - end where - - return -end subroutine blend_wind_height - - -end module BlendingMod - diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/CMakeLists.txt deleted file mode 100644 index 9493c0cd3..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/CMakeLists.txt +++ /dev/null @@ -1,22 +0,0 @@ -esma_set_this () - -set (srcs - shr_kind_mod.F90 FVperf_module.F90 dynamics_vars.F90 diag_module.F90 FVdycore_wrapper.F90 - FVdycore_GridCompMod.F90 fill_module.F90 pft_module.F90 mapz_module.F90 fft99.F90 - tp_core.F90 par_vecsum.F90 par_xsum.F90 pmaxmin.F90 sw_core.F90 - benergy.F90 cd_core.F90 geopk.F90 pkez.F90 te_map.F90 trac2d.F90 - epvd.F90 mfz_comp.F90 remap.F90 gmap.F90 glosum.F90 BlendingMod.F90 G3_AVRX.F90 - ) - -add_definitions(-DSPMD -DMAPL_MODE -DTWOD_YZ -DrFV=r4) - - -esma_add_library (${this} SRCS ${srcs} DEPENDENCIES GEOS_Shared GMAO_pilgrim MAPL) -target_include_directories (${this} PUBLIC ${INC_ESMF} ${INC_NETCDF}) - -if (CRAY_POINTER) - set_target_properties (${this} PROPERTIES COMPILE_FLAGS ${CRAY_POINTER}) -endif() - -file (GLOB rc_files *.rc) -install(FILES ${rc_files} DESTINATION etc) diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_GridCompMod.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_GridCompMod.F90 deleted file mode 100644 index e7ccabe6a..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_GridCompMod.F90 +++ /dev/null @@ -1,6242 +0,0 @@ -! $Id: FVdycore_GridCompMod.F90,v 1.268.106.1.2.1 2019/07/23 15:32:49 mmanyin Exp $ - -#include "MAPL_Generic.h" - - - -!----------------------------------------------------------------------- -! ESMA - Earth System Modeling Applications -!----------------------------------------------------------------------- - - Module FVdycore_GridCompMod - -!BOP -! -! !MODULE: FVdycore_GridCompMod --- FVCAM Dynamical Core Grid Component - - !DESCRIPTION: -! This module implements the FVCAM Dynamical Core as -! an ESMF gridded component. -! -! \paragraph*{Overview} -! -! This module contains an ESMF wrapper for the Finite-Volume -! Dynamical Core used in the Community Atmospheric Model -! (FVCAM). This component will hereafter be referred -! to as the ``FVdycore'' ESMF gridded component. FVdycore -! consists of four sub-components, -! -! \begin{itemize} -! \item {\tt cd\_core:} The C/D-grid dycore component -! \item {\tt te\_map:} Vertical remapping algorithm -! \item {\tt trac2d:} Tracer advection -! \item {\tt benergy:} Energy balance -! \end{itemize} -! -! Subsequently the ESMF component design for FV dycore -! will be described. -! -! \paragraph*{Internal State} -! -! FVdycore maintains an internal state consisting of the -! following fields: control variables -! -! \begin{itemize} -! \item {\tt U}: U winds on a D-grid (m/s) -! \item {\tt V}: V winds on a D-grid (m/s) -! \item {\tt PT}: Scaled Virtual Potential Temperature(T$_v$/PKZ) -! \item {\tt PE}: Edge pressures -! \item {\tt Q}: Tracers -! \item {\tt PKZ}: Consistent mean for p$^\kappa$ -! \end{itemize} -! -! as well as a GRID (to be mentioned later) -! and same additional run-specific variables -! (dt, iord, jord, nsplit -- to be mentioned later) -! -! Note: {\tt PT} is not updated if the flag {\tt CONVT} is true. -! -! The internal state is updated each time FVdycore is called. -! -! \paragraph*{Import State} -! -! The import state consists of the tendencies of the -! control variables plus the surface geopotential heights: -! -! \begin{itemize} -! \item {\tt DUDT}: U wind tendency on a A-grid (m/s) -! \item {\tt DVDT}: V wind tendency on a A-grid (m/s) -! \item {\tt DTDT}: Delta-pressure-weighted temperature tendency -! \item {\tt DPEDT}: Edge pressure tendency -! \item {\tt PHIS}: Surface Geopotential Heights -! \end{itemize} -! -! These are by definition on an A-grid and have an XY -! domain decomposition. -! -! \paragraph*{Export State} -! -! The export state can provide the following variables: -! -! \begin{itemize} -! \item {\tt U}: U winds on a A-grid (m/s) -! \item {\tt V}: V winds on a A-grid (m/s) -! \item {\tt U\_CGRID}: U winds on a C-grid (m/s) -! \item {\tt V\_CGRID}: V winds on a C-grid (m/s) -! \item {\tt U\_DGRID}: U winds on a D-grid (m/s) -! \item {\tt V\_DGRID}: V winds on a D-grid (m/s) -! \item {\tt T}: Temperature (K) -! \item {\tt Q}: Tracers -! \item {\tt TH}: Potential Temperature (K) -! \item {\tt ZL}: Mid-Layer Heights (m) -! \item {\tt ZLE}: Edge Heights (m) -! \item {\tt PLE}: Edge pressures (Pa) -! \item {\tt PLK}: $P^\kappa$ at Mid-Layers -! \item {\tt OMEGA}: Vertical pressure velocity (pa/s) -! \item {\tt PTFX}: Mass-Weighted PT flux on C-Grid (K Pa m$^2$/s) -! \item {\tt PTFY}: Mass-Weighted PT flux on C-Grid (K Pa m$^2$/s) -! \item {\tt MFX\_UR}: Mass-Weighted U-Wind on C-Grid (Pa m$^2$/s) -! \item {\tt MFY\_UR}: Mass-Weighted V-wind on C-Grid (Pa m$^2$/s) -! \item {\tt MFX}: Remapped Mass-Weighted U-Wind on C-Grid (Pa m$^2$/s) -! \item {\tt MFY}: Remapped Mass-Weighted V-wind on C-Grid (Pa m$^2$/s) -! \item {\tt MFZ}: Remapped Vertical mass flux (kg/(m$^2$*s)) -! \item {\tt MFX\_A}: Remapped Mass-Weighted U-Wind on A-Grid (Pa m$^2$/s) -! \item {\tt MFY\_A}: Remapped Mass-Weighted V-wind on A-Grid (Pa m$^2$/s) -! \item {\tt PV}: Ertel's Potential Vorticity (m$^2$ / kg*s) -! \item {\tt DUDT}: U-wind Tendency (m/s/s) -! \item {\tt DVDT}: V-wind Tendency (m/s/s) -! \item {\tt DTDT}: Mass-Weighted Temperature Tendency (Pa K/s) -! \item {\tt AREA}: Cell areas on the A-Grid (m$^2$, polar caps at J=1, J=JM) -! \end{itemize} -! -! All variables are on an A-grid with points at the poles, and have an XY decomposition. -! -! \paragraph*{Grids and Decompositions} -! -! The current version supports only a 1D latitude-based -! decomposition of the domain (with OMP task-parallelism -! in the vertical, resulting in reasonable scalability -! on large PE configurations). In the near future it will -! support a 2D domain decomposition, in which import and -! export state are decomposed in longitude and latitude, -! while the internal state (for the most part) is -! decomposed in latitude and level. When needed, -! the data is redistributed (``transposed'') internally. -! -! There are two fundamental ESMF grids in use; -! \begin{itemize} -! \item {GRIDXY}: longitude-latitude ESMF grid (public) -! \item {GRIDYZ}: A latitude-level cross-sectional -! decomposition (private to this module) -! \end{itemize} -! -! PILGRIM will be used for communication until ESMF has -! sufficient functionality and performance to take over -! the task. The use of pilgrim requires a call to -! {\tt INIT\_SPMD} to set SPMD parameters, decompositions, -! etc. -! -! Currently, only a 1D decomposition in latitude is employed. -! Thus GRIDXY and GRIDYZ actually represent the same -! decomposition and no transposes are employed. -! -! \paragraph*{Required Files} -! -! The following files are needed for a standard restart run: -! -! \begin{itemize} -! \item Layout file -! \begin{itemize} -! \item {\tt nprxy\_x, nprxy\_y, npryz\_y, npryz\_z}: -! process dimensions in XY and YZ. -! \item {\tt imxy, jmxy, jmyz, kmyz}: distributions for XY and YZ -! \item {\tt iord, jord}: the order of the lon. and lat. algorithms -! \item {\tt dtime}: The large (advection) time step -! \item {\tt nsplit}: the ratio between the large and small time step -! (possibly zero for automatic determination), -! \end{itemize} -! \item Restart file -! \begin{itemize} -! \item date in standard format yy, mm, dd, hh, mm, ss -! \item dimensions im, jm, km, nq -! \item control variables {\tt U, V, PT, PE, Q} -! \end{itemize} -! \item Topography file -! -! \end{itemize} -! -! \paragraph*{Future Additions} -! -! \begin{itemize} -! \item Conservation of energy (CONSV == .TRUE. ) -! \item 2D decomposition (requires transposes in the coupler) -! \item Use r8 instead of r4 (currently supported in StopGap) -! \end{itemize} -! - -! !USES: - - use ESMF ! ESMF base class - use MAPL ! GEOS base class - use G3_MPI_Util_Mod - use dynamics_vars, only : T_TRACERS, T_FVDYCORE_VARS, & - T_FVDYCORE_GRID, T_FVDYCORE_STATE - - implicit none - private - -! !PUBLIC MEMBER FUNCTIONS: - - public SetServices ! Register component methods -!EOP - -! !REVISION HISTORY: -! -! 11Jul2003 Sawyer From Trayanov/da Silva EVAC -! 23Jul2003 Sawyer First informal tiptoe-through -! 29Jul2003 Sawyer Modifications based on comments from 23Jul2003 -! 28Aug2003 Sawyer First check-in; Internal state to D-grid -! 15Sep2003 Sawyer Extensive bug fixes, revisions -! 24Sep2003 Sawyer Modified names; corrected weighting of T, Q -! 22Oct2003 Sawyer pmgrid removed (data now in spmd_dyn) -! 25Nov2003 Sawyer Optimization for 1D decomposition (as in FVCAM) -! 03Dec2003 Sawyer Switched over to specified decompositions -! 04Dec2003 Sawyer Moved T_FVDYCORE_GRID to dynamics_vars -! 21Jan2004 Takacs Modified Import/Export, Added Generic State, Added TOPO utility -! 20Sep2004 Sawyer Revised cd_core, trac2d interfaces, refactoring -! 06Oct2004 Sawyer More refactoring, removed spmd_dyn -! 17Feb2005 Sawyer Added Ertel's potential vorticity to diagnostics -! 20Mar2005 Sawyer Tracers are now pointers into import state -! 12Apr2005 Sawyer Extensive changes to minimize tracer memory -! 18May2005 Sawyer Put FVdycore_wrapper in separate file; CAM/GEOS5 merge -! 16Nov2005 Takacs Added option for DCADJ, Merge with Daedalus_p5 -! 18Jan2006 Putman Added mass fluxes to export state -! 01Apr2009 Sawyer Upgraded to PILGRIM from cam3_6_33 -! -!---------------------------------------------------------------------- - - integer, parameter :: r8 = 8 - integer, parameter :: r4 = 4 - - real(r8), parameter :: RADIUS = MAPL_RADIUS - real(r8), parameter :: CP = MAPL_CP - real(r8), parameter :: PI = MAPL_PI_R8 - real(r8), parameter :: OMEGA = MAPL_OMEGA - real(r8), parameter :: KAPPA = MAPL_KAPPA - real(r8), parameter :: P00 = MAPL_P00 - real(r8), parameter :: GRAV = MAPL_GRAV - real(r8), parameter :: RGAS = MAPL_RGAS - real(r8), parameter :: RVAP = MAPL_RVAP - real(r8), parameter :: EPS = RVAP/RGAS-1.0 - - integer, parameter :: TIME_TO_RUN = 1 - integer, parameter :: CHECK_MAXMIN = 2 - - integer :: I, J, K ! Default declaration for loops. - -! Wrapper for extracting internal state -! ------------------------------------- - - type DYN_wrap - type (T_FVDYCORE_STATE), pointer :: DYN_STATE - end type DYN_wrap - -contains - -!---------------------------------------------------------------------- -!BOP -! -! !IROUTINE: SetServices --- Set services for FVCAM Dynamical Core - - !INTERFACE: - Subroutine SetServices ( gc, rc ) - - !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: gc ! gridded component - integer, intent(out), optional :: rc ! return code - - - !DESCRIPTION: -! Set services (register) for the FVCAM Dynamical Core -! Grid Component. -! -!EOP -!---------------------------------------------------------------------- - - type (T_FVDYCORE_STATE), pointer :: dyn_internal_state - type (DYN_wrap) :: wrap - - integer :: status - character(len=ESMF_MAXSTR) :: IAm - character(len=ESMF_MAXSTR) :: COMP_NAME - -! Begin -!------ - - Iam = "SetServices" - call ESMF_GridCompGet( GC, name=COMP_NAME, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // Iam - -! Allocate this instance of the internal state and put it in wrapper. -! ------------------------------------------------------------------- - - allocate( dyn_internal_state, stat=status ) - VERIFY_(STATUS) - wrap%dyn_state => dyn_internal_state - -! Save pointer to the wrapped internal state in the GC -! ---------------------------------------------------- - - call ESMF_UserCompSetInternalState ( GC,'FVstate',wrap,status ) - VERIFY_(STATUS) - -!BOS - -! !IMPORT STATE: - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DUDT', & - LONG_NAME = 'eastward_wind_tendency', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DVDT', & - LONG_NAME = 'northward_wind_tendency', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DTDT', & - LONG_NAME = 'delta-p_weighted_temperature_tendency', & - UNITS = 'Pa K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DQVANA', & - LONG_NAME = 'specific_humidity_vapor_increment_from_analysis', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DQLANA', & - LONG_NAME = 'specific_humidity_liquid_increment_from_analysis', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DQIANA', & - LONG_NAME = 'specific_humidity_ice_increment_from_analysis', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DOXANA', & - LONG_NAME = 'ozone_increment_from_analysis', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'DPEDT', & - LONG_NAME = 'edge_pressure_tendency', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( gc, & - SHORT_NAME = 'PHIS', & - LONG_NAME = 'surface_geopotential_height', & - UNITS = 'm+2 s-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec( gc, & - SHORT_NAME = 'TRADV', & - LONG_NAME = 'advected_quantities', & - UNITS = 'unknown', & - DATATYPE = MAPL_BundleItem, & - RC=STATUS ) - VERIFY_(STATUS) - -! !EXPORT STATE: - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KE', & - LONG_NAME = 'vertically_integrated_kinetic_energy', & - UNITS = 'J m-2' , & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TAVE', & - LONG_NAME = 'vertically_averaged_dry_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UAVE', & - LONG_NAME = 'vertically_averaged_zonal_wind', & - UNITS = 'm sec-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEPHY', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_physics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEPHY', & - LONG_NAME = 'total_potential_energy_tendency_due_to_physics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TEPHY', & - LONG_NAME = 'mountain_work_tendency_due_to_physics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEANA', & - LONG_NAME = 'total_kinetic_energy_tendency_due_to_analysis', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEANA', & - LONG_NAME = 'total_potential_energy_tendency_due_to_analysis', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TEANA', & - LONG_NAME = 'mountain_work_tendency_due_to_analysis', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEHOT', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_HOT', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEDP', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_pressure_change', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEADV', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_dynamics_advection', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEPG', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_pressure_gradient', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEDYN', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_dynamics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEDYN', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_dynamics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TEDYN', & - LONG_NAME = 'mountain_work_tendency_due_to_dynamics', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KECDCOR', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_cdcore', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PECDCOR', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_cdcore', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TECDCOR', & - LONG_NAME = 'mountain_work_tendency_due_to_cdcore', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'QFIXER', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_CONSV', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEREMAP', & - LONG_NAME = 'vertically_integrated_kinetic_energy_tendency_due_to_remap', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PEREMAP', & - LONG_NAME = 'vertically_integrated_potential_energy_tendency_due_to_remap', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TEREMAP', & - LONG_NAME = 'mountain_work_tendency_due_to_remap', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'KEGEN', & - LONG_NAME = 'vertically_integrated_generation_of_kinetic_energy', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DKERESIN', & - LONG_NAME = 'vertically_integrated_kinetic_energy_residual_from_inertial_terms', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DKERESPG', & - LONG_NAME = 'vertically_integrated_kinetic_energy_residual_from_PG_terms', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DMDTANA', & - LONG_NAME = 'vertically_integrated_mass_tendency_due_to_analysis', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DOXDTANAINT', & - LONG_NAME = 'vertically_integrated_ozone_tendency_due_to_analysis', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQVDTANAINT', & - LONG_NAME = 'vertically_integrated_water_vapor_tendency_due_to_analysis', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQLDTANAINT', & - LONG_NAME = 'vertically_integrated_liquid_water_tendency_due_to_analysis', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQIDTANAINT', & - LONG_NAME = 'vertically_integrated_ice_water_tendency_due_to_analysis', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DMDTDYN', & - LONG_NAME = 'vertically_integrated_mass_tendency_due_to_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DOXDTDYNINT', & - LONG_NAME = 'vertically_integrated_ozone_tendency_due_to_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTHVDTDYNINT', & - LONG_NAME = 'vertically_integrated_THV_tendency_due_to_dynamics', & - UNITS = 'K kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTHVDTREMAP', & - LONG_NAME = 'vertically_integrated_THV_tendency_due_to_vertical_remapping', & - UNITS = 'K kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTHVDTCONSV', & - LONG_NAME = 'vertically_integrated_THV_tendency_due_to_TE_conservation', & - UNITS = 'K kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTHVDTPHYINT', & - LONG_NAME = 'vertically_integrated_THV_tendency_due_to_physics', & - UNITS = 'K kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTHVDTANAINT', & - LONG_NAME = 'vertically_integrated_THV_tendency_due_to_analysis', & - UNITS = 'K kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQVDTDYNINT', & - LONG_NAME = 'vertically_integrated_water_vapor_tendency_due_to_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQLDTDYNINT', & - LONG_NAME = 'vertically_integrated_liquid_water_tendency_due_to_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQIDTDYNINT', & - LONG_NAME = 'vertically_integrated_ice_water_tendency_due_to_dynamics', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'CONVKE', & - LONG_NAME = 'vertically_integrated_kinetic_energy_convergence', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'CONVTHV', & - LONG_NAME = 'vertically_integrated_thetav_convergence', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'CONVCPT', & - LONG_NAME = 'vertically_integrated_enthalpy_convergence', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'CONVPHI', & - LONG_NAME = 'vertically_integrated_geopotential_convergence', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U', & - LONG_NAME = 'eastward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V', & - LONG_NAME = 'northward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'T', & - LONG_NAME = 'air_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PL', & - LONG_NAME = 'mid_level_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'ZLE', & - LONG_NAME = 'edge_heights', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'ZL', & - LONG_NAME = 'mid_layer_heights', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'S', & - LONG_NAME = 'mid_layer_dry_static_energy', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PLE', & - LONG_NAME = 'edge_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TH', & - LONG_NAME = 'potential_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PLK', & - LONG_NAME = 'mid_layer_$p^\kappa$', & - UNITS = 'Pa$^\kappa$', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'OMEGA', & - LONG_NAME = 'vertical_pressure_velocity', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PTFX', & - LONG_NAME = 'pressure_weighted_eastward_potential_temperature_flux_unremapped', & - UNITS = 'K Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PTFY', & - LONG_NAME = 'pressure_weighted_northward_potential_temperature_flux_unremapped', & - UNITS = 'K Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFX_UR', & - LONG_NAME = 'pressure_weighted_eastward_wind_unremapped', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFY_UR', & - LONG_NAME = 'pressure_weighted_northward_wind_unremapped', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFX', & - LONG_NAME = 'pressure_weighted_eastward_wind', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFY', & - LONG_NAME = 'pressure_weighted_northward_wind', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFZ', & - LONG_NAME = 'vertical_mass_flux', & - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFX_A', & - LONG_NAME = 'zonal_mass_flux', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'MFY_A', & - LONG_NAME = 'meridional_mass_flux', & - UNITS = 'Pa m+2 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PV', & - LONG_NAME = 'ertels_isentropic_potential_vorticity', & - UNITS = 'm+2 kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'EPV', & - LONG_NAME = 'ertels_potential_vorticity', & - UNITS = 'K m+2 kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'Q', & - LONG_NAME = 'specific_humidity', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DUDTANA', & - LONG_NAME = 'tendency_of_eastward_wind_due_to_analysis', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DVDTANA', & - LONG_NAME = 'tendency_of_northward_wind_due_to_analysis', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTDTANA', & - LONG_NAME = 'tendency_of_air_temperature_due_to_analysis', & - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DDELPDTANA', & - LONG_NAME = 'tendency_of_pressure_thickness_due_to_analysis', & - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DUDTDYN', & - LONG_NAME = 'tendency_of_eastward_wind_due_to_dynamics', & - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DVDTDYN', & - LONG_NAME = 'tendency_of_northward_wind_due_to_dynamics',& - UNITS = 'm s-2', & - DIMS = MAPL_DimsHorzVert, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DTDTDYN', & - LONG_NAME = 'tendency_of_air_temperature_due_to_dynamics', & - UNITS = 'K s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQVDTDYN', & - LONG_NAME = 'tendency_of_specific_humidity_due_to_dynamics', & - UNITS = 'kg kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQIDTDYN', & - LONG_NAME = 'tendency_of_ice_water_due_to_dynamics', & - UNITS = 'kg kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQLDTDYN', & - LONG_NAME = 'tendency_of_liquid_water_due_to_dynamics', & - UNITS = 'kg kg-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DOXDTDYN', & - LONG_NAME = 'tendency_of_ozone_due_to_dynamics', & - UNITS = 'mol mol-1 s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PREF', & - LONG_NAME = 'reference_air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'AK', & - LONG_NAME = 'hybrid_sigma_pressure_a', & - UNITS = '1', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'BK', & - LONG_NAME = 'hybrid_sigma_pressure_b', & - UNITS = '1', & - DIMS = MAPL_DimsVertOnly, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PS', & - LONG_NAME = 'surface_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TA', & - LONG_NAME = 'surface_air_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'QA', & - LONG_NAME = 'surface_specific_humidity', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'US', & - LONG_NAME = 'surface_eastward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VS', & - LONG_NAME = 'surface_northward_wind', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'SPEED', & - LONG_NAME = 'surface_wind_speed', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DZ', & - LONG_NAME = 'surface_layer_height', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'SLP', & - LONG_NAME = 'sea_level_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'H1000', & - LONG_NAME = 'height_at_1000_mb', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TROPP_EPV', & - LONG_NAME = 'tropopause_pressure_based_on_EPV_estimate', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TROPP_THERMAL', & - LONG_NAME = 'tropopause_pressure_based_on_thermal_estimate', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TROPP_BLENDED', & - LONG_NAME = 'tropopause_pressure_based_on_blended_estimate', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TROPT', & - LONG_NAME = 'tropopause_temperature_using_blended_TROPP_estimate', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TROPQ', & - LONG_NAME = 'tropopause_specific_humidity_using_blended_TROPP_estimate', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DELP', & - LONG_NAME = 'pressure_thickness', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U_CGRID', & - LONG_NAME = 'eastward_wind_on_C-Grid', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V_CGRID', & - LONG_NAME = 'northward_wind_on_C-Grid', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U_DGRID', & - LONG_NAME = 'eastward_wind_on_native_D-Grid', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V_DGRID', & - LONG_NAME = 'northward_wind_on_native_D-Grid', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'TV', & - LONG_NAME = 'air_virtual_temperature', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'THV', & - LONG_NAME = 'scaled_virtual_potential_temperature', & - UNITS = 'K/Pa$^\kappa$', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DDELPDTDYN', & - LONG_NAME = 'tendency_of_pressure_thickness_due_to_dynamics', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UKE', & - LONG_NAME = 'eastward_flux_of_atmospheric_kinetic_energy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VKE', & - LONG_NAME = 'northward_flux_of_atmospheric_kinetic_energy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UCPT', & - LONG_NAME = 'eastward_flux_of_atmospheric_enthalpy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VCPT', & - LONG_NAME = 'northward_flux_of_atmospheric_enthalpy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UPHI', & - LONG_NAME = 'eastward_flux_of_atmospheric_potential_energy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VPHI', & - LONG_NAME = 'northward_flux_of_atmospheric_potential_energy', & - UNITS = 'J m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UQV', & - LONG_NAME = 'eastward_flux_of_atmospheric_water_vapor', & - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VQV', & - LONG_NAME = 'northward_flux_of_atmospheric_water_vapor', & - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UQL', & - LONG_NAME = 'eastward_flux_of_atmospheric_liquid_water', & - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VQL', & - LONG_NAME = 'northward_flux_of_atmospheric_liquid_water',& - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'UQI', & - LONG_NAME = 'eastward_flux_of_atmospheric_ice', & - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'VQI', & - LONG_NAME = 'northward_flux_of_atmospheric_ice', & - UNITS = 'kg m-1 s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DKE', & - LONG_NAME = 'tendency_of_atmosphere_kinetic_energy_content_due_to_dynamics',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DCPT', & - LONG_NAME = 'tendency_of_atmosphere_dry_energy_content_due_to_dynamics',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DPET', & - LONG_NAME = 'tendency_of_atmosphere_topographic_potential_energy_due_to_dynamics',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'WRKT', & - LONG_NAME = 'work_done_by_atmosphere_at_top', & - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQV', & - LONG_NAME = 'tendency_of_atmosphere_water_vapor_content_due_to_dynamics',& - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQL', & - LONG_NAME = 'tendency_of_atmosphere_liquid_water_content_due_to_dynamics',& - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'DQI', & - LONG_NAME = 'tendency_of_atmosphere_ice_content_due_to_dynamics',& - UNITS = 'kg m-2 s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'CNV', & - LONG_NAME = 'generation_of_atmosphere_kinetic_energy_content',& - UNITS = 'W m-2', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U850', & - LONG_NAME = 'eastward_wind_at_850_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U500', & - LONG_NAME = 'eastward_wind_at_500_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U250', & - LONG_NAME = 'eastward_wind_at_250_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V850', & - LONG_NAME = 'northward_wind_at_850_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V500', & - LONG_NAME = 'northward_wind_at_500_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V250', & - LONG_NAME = 'northward_wind_at_250_hPa', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'T850', & - LONG_NAME = 'air_temperature_at_850_hPa', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'T500', & - LONG_NAME = 'air_temperature_at_500_hPa', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'T250', & - LONG_NAME = 'air_temperature_at_250_hPa', & - UNITS = 'K', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'Q850', & - LONG_NAME = 'specific_humidity_at_850_hPa', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'Q500', & - LONG_NAME = 'specific_humidity_at_500_hPa', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'Q250', & - LONG_NAME = 'specific_humidity_at_250_hPa', & - UNITS = 'kg kg-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'H850', & - LONG_NAME = 'height_at_850_hPa', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'H500', & - LONG_NAME = 'height_at_500_hPa', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'H250', & - LONG_NAME = 'height_at_250_hPa', & - UNITS = 'm', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'OMEGA500', & - LONG_NAME = 'omega_at_500_hPa', & - UNITS = 'Pa s-1', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'U50M', & - LONG_NAME = 'eastward_wind_at_50_meters', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'V50M', & - LONG_NAME = 'northward_wind_at_50_meters', & - UNITS = 'm s-1', & - DIMS = MAPL_DimsHorzOnly, & - FIELD_TYPE = MAPL_VectorField, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'AREA', & - LONG_NAME = 'agrid_cell_area', & - UNITS = 'm+2' , & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PT', & - LONG_NAME = 'scaled_potential_temperature', & - UNITS = 'K Pa$^{-\kappa}$', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec ( gc, & - SHORT_NAME = 'PE', & - LONG_NAME = 'air_pressure', & - UNITS = 'Pa', & - DIMS = MAPL_DimsHorzVert, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - -! !INTERNAL STATE: - -!ALT: technically the first 2 records of "old" style FV restart have -! 6 ints: YYYY MM DD H M S -! 5 ints: I,J,K, KS (num true pressure levels), NQ (num tracers) headers - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'AK', & - LONG_NAME = 'hybrid_sigma_pressure_a', & - UNITS = 'Pa', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsVertOnly, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'BK', & - LONG_NAME = 'hybrid_sigma_pressure_b', & - UNITS = '1', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsVertOnly, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'U', & - LONG_NAME = 'eastward_wind', & - UNITS = 'm s-1', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'V', & - LONG_NAME = 'northward_wind', & - UNITS = 'm s-1', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'PT', & - LONG_NAME = 'scaled_potential_temperature', & - UNITS = 'K Pa$^{-\kappa}$', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'PE', & - LONG_NAME = 'air_pressure', & - UNITS = 'Pa', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationEdge, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddInternalSpec ( gc, & - SHORT_NAME = 'PKZ', & - LONG_NAME = 'pressure_to_kappa', & - UNITS = 'Pa$^\kappa$', & - PRECISION = ESMF_KIND_R8, & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartRequired, & - VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - - -!EOS - -! Set the Profiling timers -! ------------------------ - - call MAPL_TimerAdd(GC, name="INITIALIZE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="RUN1" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="-WRAPPER" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="-DIAG_Polar_FFT" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--CDCORE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--OMEGA" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--BUDGETS" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--EPVD" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---PRE_C_CORE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----PRE_C_CORE_COMM" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----C_DELP_LOOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---C_CORE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---C_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----YZ_TO_XY_C_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----XY_TO_YZ_C_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---PRE_D_CORE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----PRE_D_CORE_COMM" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----C_U_LOOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----C_V_PGRAD" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---D_CORE" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---D_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----XY_TO_YZ_D_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----YZ_TO_XY_D_GEOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---PRE_D_PGRAD" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----PRE_D_PGRAD_COMM_1", RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----D_DELP_LOOP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---D_PGRAD_1" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---D_PGRAD_2" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---PRE_D_PGRAD_COMM_2" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--TRAC2D" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---TRAC2D_COMM" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="---TRAC2D_TRACER" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="----TRAC2D_TRACER_COMM", RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--REMAP" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--BENERGY" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--TRANSPOSE_FWD" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="RUN2" , RC=STATUS) - VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="FINALIZE" , RC=STATUS) - VERIFY_(STATUS) - -! Register services for this component -! ------------------------------------ - - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_INITIALIZE, Initialize, rc=status) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_RUN, Run1, rc=status) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_RUN, Run2, rc=status) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_FINALIZE, Finalize, rc=status) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_READRESTART, Coldstart, rc=status) - VERIFY_(STATUS) - -! Generic SetServices -!-------------------- - - call MAPL_GenericSetServices( GC, RC=STATUS ) - VERIFY_(STATUS) - - RETURN_(ESMF_SUCCESS) - - end subroutine SetServices - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - subroutine Initialize ( gc, import, export, clock, rc ) - -! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc ! composite gridded component - type(ESMF_State), intent(inout) :: import ! import state - type(ESMF_State), intent(inout) :: export ! export state - type(ESMF_Clock), intent(inout) :: clock ! the clock - - integer, intent(out), OPTIONAL :: rc ! Error code: - ! = 0 all is well - ! otherwise, error - integer :: I,J - type (ESMF_Grid) :: grid - type (ESMF_Config) :: cf - type (ESMF_Config), pointer :: config - - type (DYN_wrap) :: wrap - type (T_FVDYCORE_STATE), pointer :: STATE - type (T_FVDYCORE_GRID), pointer :: FVGRID - - - type (MAPL_MetaComp), pointer :: mapl - - character (len=ESMF_MAXSTR) :: restart_file - - type (ESMF_Field) :: field - type (ESMF_Array) :: array - type (ESMF_VM) :: VM - real, pointer :: pref(:), ak4(:), bk4(:) - real(r8), pointer :: ak(:), bk(:) - real(r8), pointer :: pe(:,:,:) - real(r4), pointer :: ple(:,:,:) - real(r4), pointer :: temp2d(:,:) - character(len=ESMF_MAXSTR) :: ReplayMode - real :: DNS_INTERVAL - type (ESMF_TimeInterval) :: Intv - type (ESMF_Alarm) :: Alarm - - - integer :: status - character(len=ESMF_MAXSTR) :: IAm - character(len=ESMF_MAXSTR) :: COMP_NAME - - type (ESMF_State) :: INTERNAL - - real(r8), allocatable :: tmp2d(:,:) - integer :: ifirstxy, ilastxy, jfirstxy, jlastxy - integer :: im,jm - - -! Begin -!------ - - Iam = "Initialize" - call ESMF_GridCompGet( GC, name=COMP_NAME, CONFIG=CF, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // Iam - -! Call Generic Initialize -!------------------------ - - call MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC=STATUS) - VERIFY_(STATUS) - -! Retrieve the pointer to the state -! --------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - -! Start the timers -!----------------- - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"INITIALIZE") - -! Get the private internal state -!------------------------------- - - call ESMF_UserCompGetInternalState(GC, 'FVstate', wrap, status) - VERIFY_(STATUS) - - state => wrap%dyn_state - fvgrid => state%grid ! direct handle to grid - -! Set Private Internal State from ESMF internal state in MAPL object -! ------------------------------------------------------------------ - - call MAPL_Get ( MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS ) - VERIFY_(STATUS) - - call FV_InitState ( STATE, CLOCK, INTERNAL, GC ) - -! Create PLE and PREF EXPORT Coupling (Needs to be done only once per run) -! ------------------------------------------------------------------------ - - call MAPL_GetPointer(EXPORT,PREF,'PREF',ALLOC=.true.,RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,AK4 ,'AK' ,ALLOC=.true.,RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,BK4 ,'BK' ,ALLOC=.true.,RC=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer(INTERNAL, AK, 'AK', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, BK, 'BK', RC=STATUS) - VERIFY_(STATUS) - - AK4 = AK - BK4 = BK - PREF = AK + BK * P00 - - call MAPL_GetPointer(EXPORT,PLE,'PLE',ALLOC=.true.,RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL,PE,'PE',RC=STATUS) - VERIFY_(STATUS) - - PLE = PE - -! Compute Grid-Cell Area -! ---------------------- - call MAPL_GetPointer(export, temp2d, 'AREA', ALLOC=.true., rc=status) - VERIFY_(STATUS) - - im = fvgrid%im - jm = fvgrid%jm - ifirstxy = fvgrid%ifirstxy - ilastxy = fvgrid%ilastxy - jfirstxy = fvgrid%jfirstxy - jlastxy = fvgrid%jlastxy - - ALLOCATE( tmp2d(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - do j=MAX(2,jfirstxy),MIN(jlastxy,jm-1) - tmp2d(:,j) = fvgrid%dl*fvgrid%cosp(j)*RADIUS * fvgrid%dp*RADIUS - enddo - if ( jfirstxy == 1 ) then - j=1 - tmp2d(:,j) = fvgrid%acap*( fvgrid%dl*RADIUS * fvgrid%dp*RADIUS)/im - endif - if ( jlastxy == jm ) then - j=jm - tmp2d(:,j) = fvgrid%acap*( fvgrid%dl*RADIUS * fvgrid%dp*RADIUS)/im - endif - temp2d = tmp2d - - DEALLOCATE( tmp2d ) - -! ====================================================================== -!ALT: the next section addresses the problem when export variables have been -! assigned values during Initialize. To prevent "connected" exports -! being overwritten by DEFAULT in the Import spec in the other component -! we label them as being "initailized by restart". A better solution -! would be to move the computation to phase 2 of Initialize and -! eliminate this section alltogether -! ====================================================================== - call ESMF_StateGet(EXPORT, 'PREF', FIELD, RC=STATUS) - VERIFY_(STATUS) - call MAPL_AttributeSet(field, NAME="MAPL_InitStatus", & - VALUE=MAPL_InitialRestart, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_StateGet(EXPORT, 'PLE', FIELD, RC=STATUS) - VERIFY_(STATUS) - call MAPL_AttributeSet(field, NAME="MAPL_InitStatus", & - VALUE=MAPL_InitialRestart, RC=STATUS) - VERIFY_(STATUS) - -!=====Begin intemittent replay======================= - -! Set the intermittent replay alarm, if needed. -! Note that it is a non-sticky alarm -! and is set to ringing on first step. So it will -! work whether the clock is backed-up ans ticked -! or not. - - call MAPL_GetResource(MAPL, ReplayMode, 'REPLAY_MODE:', default="NoReplay", RC=STATUS ) - VERIFY_(STATUS) - - if(adjustl(ReplayMode)=="Intermittent") then - call MAPL_GetResource(MAPL, DNS_INTERVAL,'REPLAY_INTERVAL:', default=21600., RC=STATUS ) - VERIFY_(STATUS) - call ESMF_TimeIntervalSet(Intv, S=nint(DNS_INTERVAL), RC=STATUS) - VERIFY_(STATUS) - - ALARM = ESMF_AlarmCreate(name='INTERMITTENT', clock=CLOCK, & - ringInterval=Intv, sticky=.false., & - RC=STATUS ) - VERIFY_(STATUS) - call ESMF_AlarmRingerOn(ALARM, rc=status) - VERIFY_(STATUS) - end if - -!========End intermittent replay======================== - - call MAPL_TimerOff(MAPL,"INITIALIZE") - call MAPL_TimerOff(MAPL,"TOTAL") - - RETURN_(ESMF_SUCCESS) - end subroutine Initialize - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - subroutine FV_InitState (STATE, CLOCK, INTERNAL, GC) - - use dynamics_vars, only : dynamics_init - use parutilitiesmodule, only : gsize, gid, parinit - - type (T_FVDYCORE_STATE),pointer :: STATE - - type (ESMF_Clock), target, intent(INOUT) :: CLOCK - type (ESMF_GridComp) , intent(INout) :: GC - type (ESMF_State) , intent(INOUT) :: INTERNAL - -! Local variables - - type (ESMF_TimeInterval) :: Time2Run - type (ESMF_TimeInterval) :: CheckMaxMin - type (ESMF_VM) :: VM - type (T_FVDYCORE_GRID) , pointer :: GRID - integer :: rc - integer :: status - integer :: len - real(r8) :: REAL_PACK(6) - - integer :: NPRXY_X, NPRXY_Y, NPRYZ_Y, NPRYZ_Z, & - DT, IORD, JORD, KORD, TE_METHOD, NSPLIT - integer :: force_2d, geopktrans - integer, allocatable :: IMXY(:), JMXY(:), JMYZ(:), KMYZ(:) - - integer :: nx, ny - integer :: nstep, nymd, nhms - integer :: yr, mm, dd, h, m, s, itmp - integer :: INT_PACK(6) - - type(ESMF_DELayout) :: layoutYZ - integer :: I, nDEs - integer :: img - integer :: jmg - integer :: kmg - - integer :: im, jm, km ! Global dims - integer :: nq ! No. advected tracers - integer :: ntotq ! No. total tracers - integer :: ks ! True # press. levs - integer :: ifirstxy, ilastxy ! Interval - integer :: jfirstxy, jlastxy ! Interval - integer :: jfirst, jlast ! Interval - integer :: kfirst, klast ! Interval - integer :: k ! Vertical loop index - integer :: srcCellCountPerDim(3), srcStartPerDEPerDim(gsize,3) - - character(len=ESMF_MAXSTR) :: IAm='FV:Init_State' - - real(r8), pointer :: AK(:), BK(:) - real(r8), dimension(:,:,:), pointer :: U, V, PT, PE, PKZ - type (MAPL_MetaComp), pointer :: mapl - integer :: comm - - real ple,ples,plet,sig,dpl - -! Retrieve the pointer to the state -! --------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - -! Save the mapl state for FVperf_module -! ------------------------------------- - - STATE%GRID%FVgenstate => MAPL - GRID => STATE%GRID ! For convenience - -! Initialize Layout based on 2-D decomposition -! -------------------------------------------- - - call MAPL_GetResource( MAPL, NX, 'NX:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, NY, 'NY:', default=0, RC=STATUS ) - VERIFY_(STATUS) - - NPRXY_X = NX - NPRXY_Y = NY - NPRYZ_Y = NY - NPRYZ_Z = NX - - _ASSERT( NPRXY_X>0 .AND. NPRXY_Y>0 ,'needs informative message') - _ASSERT( NPRYZ_Y>0 .AND. NPRYZ_Z>0 ,'needs informative message') - _ASSERT( NPRXY_X*NPRXY_Y == NPRYZ_Y*NPRYZ_Z ,'needs informative message') - - call MAPL_GetResource( MAPL, force_2d, 'force_2d:', default=0, RC=STATUS ) - VERIFY_(STATUS) - -! Get the layout and store directly in the GRID data structure -! ------------------------------------------------------------ - - grid%twod_decomp = 1 - - if (npryz_z .eq. 1 .and. nprxy_x .eq. 1 .and. force_2d .eq. 0) then - grid%twod_decomp = 0 - call WRITE_PARALLEL('Code operating with 1D decomposition') - endif - -! Pilgrim initialization: pass the 2D decomposition and other parameters for FV optimization -! ------------------------------------------------------------------------------------------ - - call ESMF_VMGetCurrent(vm, rc=rc) - call ESMF_VMGet(vm, mpiCommunicator=comm, rc=rc) - call parinit( comm=comm, npryzxy = (/ npryz_y, npryz_z, nprxy_x, nprxy_y/), & - mod_method = grid%mod_method, & - mod_geopk = grid%mod_geopk, & - mod_gatscat = grid%mod_gatscat ) - -! Get Global Dimensions -! --------------------- - call MAPL_GetResource( MAPL, IMG, 'AGCM_IM:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, JMG, 'AGCM_JM:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, KMG, 'AGCM_LM:', default=0, RC=STATUS ) - VERIFY_(STATUS) - -! Create IMXY, JMXY, JMYZ, KMYZ vectors -! ------------------------------------- - - allocate( imxy(0:nprxy_x-1) ) - allocate( jmxy(0:nprxy_y-1) ) - allocate( jmyz(0:npryz_y-1) ) - allocate( kmyz(0:npryz_z-1) ) - - call MAPL_DecomposeDim ( img,imxy,nprxy_x ) - call MAPL_DecomposeDim ( jmg,jmxy,nprxy_y ) - call MAPL_DecomposeDim ( jmg,jmyz,npryz_y ) - call MAPL_DecomposeDim ( kmg,kmyz,npryz_z ) - -! Get other scalars -! ----------------- - - call MAPL_GetResource( MAPL, dt, 'RUN_DT:', default=0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, iord, 'iord:', default=3, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, jord, 'jord:', default=3, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, kord, 'kord:', default=4, RC=STATUS ) - VERIFY_(STATUS) - -! Vertical Remapping Method for Total Energy (default=1 is cubic interpolation) -! ----------------------------------------------------------------------------- - - call MAPL_GetResource( MAPL, te_method, 'te_method:', default=1, RC=STATUS ) - VERIFY_(STATUS) - -! Ratio of Large/Small Timesteps (default=0 implies automatic calculation) -! ------------------------------------------------------------------------ - - call MAPL_GetResource( MAPL, nsplit, 'nsplit:', default=0, RC=STATUS ) - VERIFY_(STATUS) - -! Heritage Code for Tracers -! ------------------------- - ntotq = 1 ! Total Number of Tracers - nq = ntotq ! Total Number of Advected Tracers - -! Other assertions -! - _ASSERT(maxval(IMXY)>0 .AND. maxval(JMXY)>0,'needs informative message') - _ASSERT(maxval(JMYZ)>0 .AND. maxval(KMYZ)>0,'needs informative message') - _ASSERT(DT > 0.0 ,'needs informative message') - - call WRITE_PARALLEL('Dynamics PE Layout') - call WRITE_PARALLEL(IMG ,format='("IM_Global: ",( I4))') - call WRITE_PARALLEL(JMG ,format='("JM_Global: ",( I4))') - call WRITE_PARALLEL(KMG ,format='("LM_Global: ",( I4))') - call WRITE_PARALLEL(NPRXY_X ,format='("NPRXY_X : ",( I4))') - call WRITE_PARALLEL(NPRXY_Y ,format='("NPRXY_Y : ",( I4))') - call WRITE_PARALLEL(NPRYZ_Y ,format='("NPRYZ_Y : ",( I4))') - call WRITE_PARALLEL(NPRYZ_Z ,format='("NPRYZ_Z : ",( I4))') - call WRITE_PARALLEL(IMXY(0:NPRXY_X-1),format='("IMXY : ",(256I3))') - call WRITE_PARALLEL(JMXY(0:NPRXY_Y-1),format='("JMXY : ",(256I3))') - call WRITE_PARALLEL(JMYZ(0:NPRYZ_Y-1),format='("JMYZ : ",(256I3))') - call WRITE_PARALLEL(KMYZ(0:NPRYZ_Z-1),format='("KMYZ : ",(256I3))') - - call WRITE_PARALLEL(iord,format='(/,"IORD: ",(I2))') - call WRITE_PARALLEL(jord,format='( "JORD: ",(I2))') - call WRITE_PARALLEL(kord,format='( "KORD: ",(I2))') - call WRITE_PARALLEL(te_method,format='( "TE_METHOD: ",(I2),/)') - -! These are run-specific variables: -! DT Time step -! IORD Order (mode) of X interpolation (1,..,6) -! JORD Order (mode) of Y interpolation (1,..,6) -! NSPLIT Ratio of big to small timestep (set to zero if in doubt) -! - - STATE%DOTIME = .TRUE. - STATE%CHECK_DT = 21600. ! Check max and min of arrays every 6 hours. - STATE%DT = DT - STATE%IORD = IORD - STATE%JORD = JORD - STATE%KORD = KORD - STATE%TE_METHOD = TE_METHOD - -! Calculation of orders for the C grid is fixed by D-grid IORD, JORD -!------------------------------------------------------------------- - - if( iord <= 2 ) then - STATE%ICD = 1 - else - STATE%ICD = -2 - endif - - if( jord <= 2 ) then - STATE%JCD = 1 - else - STATE%JCD = -2 - endif - - call WRITE_PARALLEL(STATE%DT,format='("Dynamics time step: ",(F10.4))') - - -! Get the main GRIDXY grid from the application (no longer set in this module) -!----------------------------------------------------------------------------- - - call ESMF_GridCompGet(gc, grid=GRID%GRIDXY, vm=vm, rc=STATUS) - -! Get size, grid, and coordinate specifications -!---------------------------------------------- - -!MJS: we should get these from the MAPL object - - im = SUM(IMXY) - jm = SUM(JMXY) - km = SUM(KMYZ) - -! Calculate NSPLIT if it was specified as 0 -! ----------------------------------------- - if ( NSPLIT == 0 ) then - STATE%NSPLIT = INIT_NSPLIT(STATE%DT,IM,JM) - else - STATE%NSPLIT = NSPLIT - call WRITE_PARALLEL(STATE%NSPLIT,format='("Dynamics NSPLIT: ",(I3),/)') - endif - - call WRITE_PARALLEL((/im,jm,km/) , & - format='("Resolution of dynamics restart =",3I5)' ) - - ks = 0 ! ALT: this was the value when we read "old" style FV_internal restart - ! if needed, we could compute, ks by count(BK==0.0) - ! then FV will try to run slightly more efficient code - ! So far, GEOS-5 has used ks = 0 - _ASSERT(ks <= KM+1,'needs informative message') - call WRITE_PARALLEL(ks , & - format='("Number of true pressure levels =", I5)' ) - -! -! Make sure that IM, JM, KM are the sums of the (exclusive) dist. -! - _ASSERT(jm == SUM(JMYZ),'needs informative message') - -! -! -! Note: it is necessary to create GRIDXY and GRIDYZ now in -! order to access the first and last local indices. -! This makes it difficult to cleanly separate the -! grid initialization into init_fvdycore_grid. -! -! - -!ALT??? -! we need to check if the grid is OK - - GRID%GRIDYZ = ESMF_GridCreate( & - name="FVCORE_YZ_grid", & - countsPerDEDim1=JMYZ, & - countsPerDEDim2=KMYZ, & - indexFlag = ESMF_INDEX_GLOBAL, & - coordDep1 = (/1,2/), & - coordDep2 = (/1,2/), & - gridEdgeLWidth = (/0,0/), & - gridEdgeUWidth = (/0,0/), & - rc=status) - VERIFY_(STATUS) - - - call MAPL_GRID_INTERIOR(GRID%GRIDXY, ifirstxy, ilastxy, & - jfirstxy, jlastxy ) - - call MAPL_GRID_INTERIOR(GRID%GRIDYZ, jfirst, jlast, & - kfirst, klast ) - -! Get pointers to internal state vars -!------------------------------------ - - call MAPL_GetPointer(internal, ak, "AK", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, bk, "BK", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, u, "U", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, v, "V", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, pt, "PT", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, pe, "PE", rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(internal, pkz, "PKZ",rc=status) - VERIFY_(STATUS) - -! -! WS: CREATE_VARS moved here to define STATE%VARS soon enough -! - call CREATE_VARS ( ifirstxy, ilastxy, & - jfirstxy, jlastxy, & - 1, km, km+1, & - U, V, PT, PE, PKZ, & - STATE%VARS ) - - -! Report -!------- - - if( gid.eq.0 ) then - print * - write(6,100) -100 format(2x,' k ',' A(k) ',2x,' B(k) ',2x,' Pref ',2x,' DelP ',2x,' Sige ',/, & - 1x,'----',3x,'----------',2x,'----------',2x,'----------',2x,'---------',2x,'--------' ) - k=0 - plet = ak(k )*0.01 + 1000.0*bk(k) - ple = ak(k )*0.01 + 1000.0*bk(k) - ples = ak(km)*0.01 + 1000.0*bk(km) - write(6,101) k+1,ak(k)*0.01, bk(k), ple - do k=1,km - dpl = ple - ple = ak(k)*0.01 + 1000.0*bk(k) - dpl = ple-dpl - sig = (ple-plet)/(ples-plet) - write(6,102) k+1,ak(k)*0.01, bk(k), ple, dpl, sig - enddo - - print * -101 format(2x,i3,2x,f10.6,2x,f10.6,2x,f10.4) -102 format(2x,i3,2x,f10.6,2x,f10.6,2x,f10.4,3x,f8.4,2x,f10.6) - endif - -! Initialize the FVDYCORE static variables in the GRID -!----------------------------------------------------- - - call dynamics_init( state%dt, state%jord, im, jm, km, & - PI, RADIUS, OMEGA, nq, ntotq, ks, & - ifirstxy,ilastxy, jfirstxy,jlastxy, & - jfirst, jlast, kfirst, klast, & - nprxy_x, nprxy_y, npryz_y, npryz_z, & - imxy, jmxy, jmyz, kmyz, & - ak, bk, 0, grid ) - - STATE%CLOCK => CLOCK - - call ESMF_TimeIntervalSet(Time2Run, & - S=nint(STATE%DT), rc=status) - VERIFY_(status) - - STATE%ALARMS(TIME_TO_RUN) = ESMF_AlarmCreate(name="Time2Run", clock=clock, & - ringInterval=Time2Run, & - Enabled=.TRUE., rc=status) - VERIFY_(status) - - call ESMF_AlarmEnable (STATE%ALARMS(TIME_TO_RUN), rc=status); VERIFY_(status) - call ESMF_AlarmRingerOn(STATE%ALARMS(TIME_TO_RUN), rc=status); VERIFY_(status) - - call ESMF_TimeIntervalSet(CheckMaxMin, S=nint(STATE%CHECK_DT), rc=status) - VERIFY_(status) - - STATE%ALARMS(CHECK_MAXMIN) = ESMF_AlarmCreate(name="CheckMaxMin", clock=clock, & - RingInterval=CheckMaxMin, & - Enabled=.TRUE., rc=status) - VERIFY_(status) - - call WRITE_PARALLEL(' ') - - call WRITE_PARALLEL(STATE%DT, & - format='("INITIALIZED ALARM: DYN_TIME_TO_RUN EVERY ",F9.1," secs.")') - call WRITE_PARALLEL(STATE%CHECK_DT, & - format='("INITIALIZED ALARM: CHECK MAX AND MIN EVERY ",F9.1," secs.")') - - return - -contains - -!----------------------------------------------------------------------- -! BOP -! !IROUTINE: init_nsplit --- find proper value for nsplit if not specified -! -! !INTERFACE: - integer function INIT_NSPLIT(dtime,im,jm) -! -! !USES: - implicit none - -! !INPUT PARAMETERS: - real (r8), intent(in) :: dtime ! time step - integer, intent(in) :: im, jm ! Global horizontal resolution - -! !DESCRIPTION: -! -! If nsplit=0 (module variable) then determine a good value -! for ns (used in dynpkg) based on resolution and the large-time-step -! (pdt). The user may have to set this manually if instability occurs. - !EOP - -! !REVISION HISTORY: -! 00.10.19 Lin Creation -! 01.03.26 Sawyer ProTeX documentation -! 01.06.10 Sawyer Modified for dynamics_init framework -! 03.12.04 Sawyer Moved here from dynamics_vars. Now a function -! -!----------------------------------------------------------------------- -! !LOCAL VARIABLES: - real (r8) pdt ! Time-step in seconds - ! Negative dt (backward in time - ! integration) is allowed - real (r8) dim - real (r8) dim0 ! base dimension - real (r8) dt0 ! base time step - real (r8) ns0 ! base nsplit for base dimension - real (r8) ns ! final value to be returned - - parameter ( dim0 = 180. ) - parameter ( dt0 = 1800. ) - parameter ( ns0 = 4. ) - - pdt = int(dtime) ! dtime is a variable internal to this module - dim = max ( im, 2*(jm-1) ) - ns = int ( ns0*abs(pdt)*dim/(dt0*dim0) + 0.75 ) - ns = max ( 1.0d0, ns ) ! for cases in which dt or dim is too small - - init_nsplit = ns - - call WRITE_PARALLEL ( ns ,format='("Dynamics NSPLIT: ",(f7.2),/)' ) - - return - end function INIT_NSPLIT -!--------------------------------------------------------------------- - subroutine CREATE_VARS (I1, IN, J1, JN, K1, KN, KP, & - U, V, PT, PE, PKZ, VARS ) - - integer, intent(IN ) :: I1, IN, J1, JN, K1, KN, KP - real(r8), target :: U(I1:IN,J1:JN,K1:KN ) - real(r8), target :: V(I1:IN,J1:JN,K1:KN ) - real(r8), target :: PT(I1:IN,J1:JN,K1:KN ) - real(r8), target :: PE(I1:IN,J1:JN,K1:KP ) - real(r8), target :: PKZ(I1:IN,J1:JN,K1:KN ) - - type (T_FVDYCORE_VARS), intent(INOUT) :: VARS - - VARS%U => U - VARS%V => V - VARS%PT => PT - VARS%PE => PE - VARS%PKZ => PKZ - - return - end subroutine CREATE_VARS - - - -end subroutine FV_INITSTATE - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - - - - - subroutine Run1(gc, import, export, clock, rc) - use dynamics_vars, only : a2d3d, d2a3d, c2a3d - use BlendingMod, only : blend_wind_height - - type(ESMF_GridComp), intent(inout) :: gc - type (ESMF_State), intent(inout) :: import - type (ESMF_State), intent(inout) :: export - type (ESMF_Clock), intent(INout) :: clock - integer, intent(out), optional :: rc - -! !Local Variables: - - integer :: status - type (ESMF_FieldBundle) :: bundle - type (ESMF_FieldBundle) :: DNS_Bundle - type (ESMF_Field) :: field - type (ESMF_Field) :: dns_field - type (ESMF_Config) :: cf - type (ESMF_Alarm) :: Alarm - type (ESMF_Grid) :: ESMFGRID - type (ESMF_Time) :: currentTime - type (ESMF_VM) :: vm - - type (MAPL_MetaComp), pointer :: mapl - - type (DYN_wrap) :: wrap - type (T_FVDYCORE_STATE), pointer :: STATE - type (T_FVDYCORE_GRID), pointer :: GRID - type (T_FVDYCORE_VARS), pointer :: VARS - - integer :: J1, JN, K1, KN, NQ - integer :: IM, JM, KM - integer :: NKE, NPHI - integer :: NUMVARS - integer :: ifirstxy, ilastxy, jfirstxy, jlastxy - integer :: I, J, K, L, n, pos - logical, parameter :: convt = .false. ! Until this is run with full physics - logical :: is_ringing - - real(r8), pointer :: phisxy(:,:) - real(kind=4), pointer :: phis(:,:) - - real(r8), allocatable :: pkxy(:,:,:) ! pe**kappa - real(r8), allocatable :: pl(:,:,:) ! mid-level pressure - real(r8), allocatable :: tempxy(:,:,:) ! mid-level temperature - real(r8), allocatable :: ua(:,:,:) ! temporary array - real(r8), allocatable :: va(:,:,:) ! temporary array - real(r8), allocatable :: qv(:,:,:) ! temporary array - real(r8), allocatable :: ql(:,:,:) ! temporary array - real(r8), allocatable :: qi(:,:,:) ! temporary array - real(r8), allocatable :: qdnew(:,:,:) ! temporary array - real(r8), allocatable :: qdold(:,:,:) ! temporary array - real(r8), allocatable :: qvold(:,:,:) ! temporary array - real(r8), allocatable :: qlold(:,:,:) ! temporary array - real(r8), allocatable :: qiold(:,:,:) ! temporary array - real(r8), allocatable :: ox(:,:,:) ! temporary array - real(r8), allocatable :: zl(:,:,:) ! temporary array - real(r8), allocatable :: zle(:,:,:) ! temporary array - real(r8), allocatable :: delp(:,:,:) ! temporary array - real(r8), allocatable :: dudt(:,:,:) ! temporary array - real(r8), allocatable :: dvdt(:,:,:) ! temporary array - real(r8), allocatable :: dtdt(:,:,:) ! temporary array - real(r8), allocatable :: dqdt(:,:,:) ! temporary array - real(r8), allocatable :: dthdt(:,:,:) ! temporary array - real(r8), allocatable :: ddpdt(:,:,:) ! temporary array - real(r8), allocatable :: dmdt(:,:) ! temporary array - real(r8), allocatable :: tmp2d (:,:) ! temporary array - real(r8), allocatable :: gze(:,:,:) ! temporary array - - real(r8), allocatable, target :: ke (:,:,:) ! Kinetic Energy - real(r8), allocatable, target :: cpt (:,:,:) ! Internal Energy - real(r8), allocatable, target :: phi (:,:,:) ! Potential Energy - real(r8), allocatable :: qsum1 (:,:) ! Vertically Integrated Variable - real(r8), allocatable :: qsum2 (:,:) ! Vertically Integrated Variable - - real(r8), allocatable :: phi00 (:,:) ! Vertically Integrated phi - real(r8), allocatable :: penrg (:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrg (:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrg (:,:) ! PHIS*(Psurf-Ptop) - real(r8), allocatable :: penrg0(:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrg0(:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrg0(:,:) ! PHIS*(Psurf-Ptop) - real(r8), allocatable :: penrga(:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrga(:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrga(:,:) ! PHIS*(Psurf-Ptop) - real(r8), allocatable :: penrgb(:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrgb(:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrgb(:,:) ! PHIS*(Psurf-Ptop) - real(r8), allocatable :: kehot (:,:) ! Vertically Integrated K due to higher-order-terms - real(r8), allocatable :: kedp (:,:) ! Vertically Integrated K due to pressure change - real(r8), allocatable :: keadv (:,:) ! Vertically Integrated K due to advection - real(r8), allocatable :: kepg (:,:) ! Vertically Integrated K due to pressure gradient - - real(r8), allocatable :: kegen (:,:) - real(r8), allocatable :: kedyn (:,:) - real(r8), allocatable :: pedyn (:,:) - real(r8), allocatable :: tedyn (:,:) - real(r8), allocatable :: kecdcor(:,:) - real(r8), allocatable :: pecdcor(:,:) - real(r8), allocatable :: tecdcor(:,:) - real(r8), allocatable :: keremap(:,:) - real(r8), allocatable :: peremap(:,:) - real(r8), allocatable :: teremap(:,:) - real(r8), allocatable :: convke (:,:) - real(r8), allocatable :: convcpt(:,:) - real(r8), allocatable :: convphi(:,:) - real(r8), allocatable :: convthv(:,:) - - real(r8), allocatable :: DNS_phis(:,:) - real(r8), allocatable :: DNS_thv (:,:,:) - - real(r8), allocatable :: dthdtremap (:,:) ! Vertically Integrated THV tendency due to vertical remapping - real(r8), allocatable :: dthdtconsv (:,:) ! Vertically Integrated THV tendency due to TE conservation - real(kind=4), allocatable :: dqvdtanaint1(:,:) - real(kind=4), allocatable :: dqvdtanaint2(:,:) - real(kind=4), allocatable :: dqldtanaint1(:,:) - real(kind=4), allocatable :: dqldtanaint2(:,:) - real(kind=4), allocatable :: dqidtanaint1(:,:) - real(kind=4), allocatable :: dqidtanaint2(:,:) - real(kind=4), allocatable :: doxdtanaint1(:,:) - real(kind=4), allocatable :: doxdtanaint2(:,:) - real(kind=4), allocatable :: dthdtanaint1(:,:) - real(kind=4), allocatable :: dthdtanaint2(:,:) - - real(kind=4), allocatable :: dummy (:,:,:) ! Dummy 3-D Variable - real(kind=4), allocatable :: tropp1(:,:) ! Tropopause Pressure - real(kind=4), allocatable :: tropp2(:,:) ! Tropopause Pressure - real(kind=4), allocatable :: tropp3(:,:) ! Tropopause Pressure - real(kind=4), allocatable :: tropt (:,:) ! Tropopause Temperature - real(kind=4), allocatable :: tropq (:,:) ! Tropopause Specific Humidity - - real(r8), allocatable :: pelnxz(:,:,:) ! log pressure (pe) at layer edges - real(r8), allocatable :: omaxyz(:,:,:) ! vertical pressure velocity (pa/sec) - real(r8), allocatable :: cptxyz(:,:,:) ! Cp*Tv - real(r8), allocatable :: thvxyz(:,:,:) ! Thetav - real(r8), allocatable :: epvxyz(:,:,:) ! ertel's potential vorticity - real(r8), allocatable :: cxxyz(:,:,:) ! Accumulated zonal winds - real(r8), allocatable :: cyxyz(:,:,:) ! Accumulated meridional winds - real(r8), allocatable :: ptfxxyz(:,:,:) ! zonal mass-weighted PT flux - real(r8), allocatable :: ptfyxyz(:,:,:) ! meridional mass-weighted PT flux - real(r8), allocatable :: mfxxyz_ur(:,:,:) ! zonal mass flux - real(r8), allocatable :: mfyxyz_ur(:,:,:) ! meridional mass flux - real(r8), allocatable :: mfxxyz(:,:,:) ! zonal mass flux - real(r8), allocatable :: mfyxyz(:,:,:) ! meridional mass flux - real(r8), allocatable :: mfzxyz(:,:,:) ! vertical mass flux - real(r8), allocatable :: mfxxyz_a(:,:,:) ! zonal mass flux A-Grid - real(r8), allocatable :: mfyxyz_a(:,:,:) ! meridional mass flux A-Grid - real(r8) :: dt ! Dynamics time step - real(r8) :: kinetic ! local kinetic energy - real(r8) :: potential ! local potential energy - real(r8) :: dtmp ! Temperature Change due to CONSV=TRUE - real(r8), allocatable :: trsum1(:) ! Global Sum of Tracers before Add_Incs - real(r8), allocatable :: trsum2(:) ! Global Sum of Tracers after Add_Incs - - real(r8), allocatable :: blend_u_f(:,:,:) - real(r8), allocatable :: blend_v_f(:,:,:) - real(r8), allocatable :: blend_pt_f(:,:,:) - real(r8), allocatable :: blend_pe_f(:,:,:) - - real(r8) :: blend_p_above ! the highest of the two blending pressure levels - real(r8) :: blend_p_below ! the lowest of the two blending pressure levels - - real :: rc_blend_p_above - real :: rc_blend_p_below - integer :: rc_blend - - real(kind=4), pointer :: dudtana(:,:,:) - real(kind=4), pointer :: dvdtana(:,:,:) - real(kind=4), pointer :: dtdtana(:,:,:) - real(kind=4), pointer :: ddpdtana(:,:,:) - real(kind=4), pointer :: dqldt (:,:,:) - real(kind=4), pointer :: dqidt (:,:,:) - real(kind=4), pointer :: doxdt (:,:,:) - real(kind=4), pointer :: dqvana (:,:,:) - real(kind=4), pointer :: dqlana (:,:,:) - real(kind=4), pointer :: dqiana (:,:,:) - real(kind=4), pointer :: doxana (:,:,:) - real(kind=4), pointer :: temp3d(:,:,:) - real(kind=4), pointer :: temp2d(:,:) - real(kind=4), pointer :: tempu (:,:) - real(kind=4), pointer :: tempv (:,:) - - character(len=ESMF_MAXSTR), ALLOCATABLE :: NAMES (:) - character(len=ESMF_MAXSTR), ALLOCATABLE, save :: NAMES0(:) - character(len=ESMF_MAXSTR) :: IAm - character(len=ESMF_MAXSTR) :: COMP_NAME - character(len=ESMF_MAXSTR) :: STRING - character(len=ESMF_MAXSTR) :: ReplayFile - character(len=ESMF_MAXSTR) :: ReplayMode - character(len=ESMF_MAXSTR) :: uname,vname,tname,qname,psname,dpname,o3name,rgrid,tvar - - type(T_TRACERS) :: qqq ! Specific Humidity - type(T_TRACERS) :: ooo ! OX - integer :: NXQ ! Number of Additional Budget Tracers - - type (MAPL_SunOrbit) :: ORBIT - real(kind=4), pointer :: LATS(:,:) - real(kind=4), pointer :: LONS(:,:) - real(kind=4), allocatable :: ZTH(:,:) - real(kind=4), allocatable :: SLR(:,:) - - logical LCONSV, LFILL, LBUD - integer CONSV, FILL, NBUD, NBUDS - - parameter (nbuds = 19) - character(len=ESMF_MAXSTR) budnames(nbuds) - logical budflags(nbuds) - - data budnames / 'KECDCOR' , & - 'PECDCOR' , & - 'TECDCOR' , & - 'KEREMAP' , & - 'PEREMAP' , & - 'TEREMAP' , & - 'CONVKE' , & - 'CONVCPT' , & - 'CONVPHI' , & - 'CONVTHV' , & - 'KEADV' , & - 'KEPG' , & - 'KEDP' , & - 'KEHOT' , & - 'DKERESIN' , & - 'DKERESPG' , & - 'QFIXER' , & - 'DTHVDTREMAP', & - 'DTHVDTCONSV' / - - Iam = "Run1" - call ESMF_GridCompGet( GC, name=COMP_NAME, CONFIG=CF, Grid=ESMFGRID, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // trim(Iam) - -! Retrieve the pointer to the generic state -! ----------------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"RUN1") - - call ESMF_VMGetCurrent(vm) - -! Retrieve the pointer to the internal state -! ------------------------------------------ - - call ESMF_UserCompGetInternalState(gc, 'FVstate', wrap, status) - VERIFY_(STATUS) - state => wrap%dyn_state - - vars => state%vars ! direct handle to control variables - grid => state%grid ! direct handle to grid - dt = state%dt ! dynamics time step (large) - - ifirstxy = grid%ifirstxy - ilastxy = grid%ilastxy - jfirstxy = grid%jfirstxy - jlastxy = grid%jlastxy - - im = grid%im - jm = grid%jm - km = grid%km - - - is_ringing = ESMF_AlarmIsRinging( STATE%ALARMS(TIME_TO_RUN),rc=status); VERIFY_(status) - if (.not. is_ringing) return - -! Allocate Arrays -! --------------- - ALLOCATE( dummy(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( delp(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dudt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dvdt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dtdt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dqdt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dthdt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( ddpdt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( tempxy(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( pl(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( ua(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( va(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qv(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( ql(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qi(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qdnew(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qdold(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qvold(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qlold(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qiold(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( ox(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - - ALLOCATE( ke(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( cpt(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( phi(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( gze(ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - - ALLOCATE( qsum1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( qsum2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( dmdt(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( phi00(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kenrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kenrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( kepg (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( keadv (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kedp (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kehot (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kenrga(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrga(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrga(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kenrgb(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrgb(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrgb(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( kegen (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kedyn (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( pedyn (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tedyn (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kecdcor(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( pecdcor(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tecdcor(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( keremap(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( peremap(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( teremap(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( convke (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( convcpt(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( convphi(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( convthv(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( tropp1 (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tropp2 (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tropp3 (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tropt (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tropq (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( dqvdtanaint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dqvdtanaint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dqldtanaint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dqldtanaint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dqidtanaint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dqidtanaint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( doxdtanaint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( doxdtanaint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dthdtanaint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dthdtanaint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dthdtremap (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dthdtconsv (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( pelnxz (ifirstxy:ilastxy,km+1,jfirstxy:jlastxy) ) - - ALLOCATE( tmp2d (ifirstxy:ilastxy,jfirstxy:jlastxy ) ) - ALLOCATE( phisxy (ifirstxy:ilastxy,jfirstxy:jlastxy ) ) - ALLOCATE( pkxy (ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - ALLOCATE( zl (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( zle (ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - ALLOCATE( omaxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( cptxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( thvxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( epvxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( cxxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( cyxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( ptfxxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( ptfyxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfxxyz_ur(ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfyxyz_ur(ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfxxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfyxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfzxyz (ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - ALLOCATE( mfxxyz_a (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - ALLOCATE( mfyxyz_a (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - - -! Report advected friendlies -!--------------------------- - - call ESMF_StateGet ( IMPORT, 'TRADV' , BUNDLE, RC=STATUS ) - VERIFY_(STATUS) - call ESMF_FieldBundleGet ( BUNDLE, fieldCount=NQ, RC=STATUS ) - VERIFY_(STATUS) - - allocate( NAMES(NQ),STAT=STATUS ) - VERIFY_(STATUS) - call ESMF_FieldBundleGet ( BUNDLE, itemorderflag=ESMF_ITEMORDER_ADDORDER, fieldNameList=NAMES, rc=STATUS ) - VERIFY_(STATUS) - - if( .not.allocated( names0 ) ) then - allocate( NAMES0(NQ),STAT=STATUS ) - VERIFY_(STATUS) - write(STRING,'(A,I5,A)') "Advecting the following ", nq, " tracers in FV:" - call WRITE_PARALLEL( trim(STRING) ) - do k=1,nq - call WRITE_PARALLEL( trim(NAMES(K)) ) - end do - NAMES0 = NAMES - endif - - !if( size(names0).ne.size(names) ) then - ! deallocate( NAMES0 ) - ! allocate( NAMES0(NQ),STAT=STATUS ) - ! VERIFY_(STATUS) - ! write(STRING,'(A,I,A)') "Advecting the following ", nq, " tracers in FV:" - ! call WRITE_PARALLEL( trim(STRING) ) - ! do k=1,nq - ! call WRITE_PARALLEL( trim(NAMES(K)) ) - ! end do - ! NAMES0 = NAMES - !endif - -! Surface Geopotential from IMPORT state -!--------------------------------------- - - call MAPL_GetPointer ( IMPORT, PHIS, 'PHIS', RC=STATUS ) - VERIFY_(STATUS) - - phisxy = real(phis,kind=r8) - - -! Set Addition Tracers for Exact Budget Diagnostics -!-------------------------------------------------- - - NBUD = 0 - LBUD = .true. - - do k=1,nbuds - call CheckBud ( EXPORT,trim(budnames(k)),budflags(k),NBUD ) - LBUD = budflags(k) .and. LBUD - enddo - - if( LBUD ) then - NXQ = 2 - else - if( NBUD.ne.0 ) then - if(MAPL_AM_I_ROOT()) then - print * - print *, "Exact Energy Budgets Require the Following EXPORTS from DYN:" - print *, "------------------------------------------------------------" - do k=1,nbuds - if( budflags(k) ) then - print *, "EXPORT Currently Turned ON: ",trim(budnames(k)) - else - print *, "EXPORT Currently Turned OFF: ",trim(budnames(k)) - endif - enddo - print * - print *, "You must ADD the necessary EXPORTS" - print *, " or DELETE the partial list from your HISTORY" - print * - endif - call ESMF_VMBarrier ( VM,RC=STATUS ) - VERIFY_(ESMF_FAILURE) - else - NXQ = 0 - endif - endif - - -! Get tracers from IMPORT State (Note: Contains Updates from Analysis) -!--------------------------------------------------------------------- - - call PULL_Q ( STATE, IMPORT, qqq, NXQ, rc ) - - do k=1,size(names) - pos = index(names(k),'::') - if(pos > 0) then - if( (names(k)(pos+2:))=='OX' ) then - ooo = vars%tracer(k) - endif - endif - if( trim(names(k))=='Q' ) then - qqq = vars%tracer(k) - endif - enddo - -! If requested, do Intermittent Replay -!------------------------------------- - - call MAPL_GetResource(MAPL, ReplayMode, 'REPLAY_MODE:', default="NoReplay", RC=STATUS ) - VERIFY_(STATUS) - - REPLAYING: if(adjustl(ReplayMode)=="Intermittent") then - -! It is an error not to specify a replay file at this point. -!----------------------------------------------------------- - - call MAPL_GetResource ( MAPL,ReplayFile,'REPLAY_FILE:', RC=STATUS ) - VERIFY_(status) - - call MAPL_GetResource ( MAPL, psname, Label="REPLAY_PSNAME:", Default="ps", RC=status ) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, dpname, Label="REPLAY_DPNAME:", Default="delp", RC=status ) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, uname, Label="REPLAY_UNAME:", Default="uwnd", RC=status ) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, vname, Label="REPLAY_VNAME:", Default="vwnd", RC=status ) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, tname, Label="REPLAY_TNAME:", Default="theta", RC=status ) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, qname, Label="REPLAY_QNAME:", Default="sphu", RC=status ) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, o3name, Label="REPLAY_O3NAME:", Default="ozone", RC=status ) - VERIFY_(STATUS) - - call MAPL_GetResource ( MAPL, rgrid, Label="REPLAY_GRID:", Default="D-GRID", RC=status ) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, tvar, Label="REPLAY_TVAR:", Default="THETAV", RC=status ) - VERIFY_(STATUS) - - call MAPL_GetResource ( MAPL, rc_blend, 'REPLAY_BLEND:', default= 0 , RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, rc_blend_p_above, 'REPLAY_BLEND_P_ABOVE:', default= 10.0, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource ( MAPL, rc_blend_p_below, 'REPLAY_BLEND_P_BELOW:', default=100.0, RC=STATUS ) - VERIFY_(STATUS) - -! If replay alarm is ringing, we need to reset state -!--------------------------------------------------- - - call ESMF_ClockGetAlarm(Clock,'INTERMITTENT',Alarm,rc=Status) - VERIFY_(status) - - is_ringing = ESMF_AlarmIsRinging( Alarm,rc=status ) - VERIFY_(status) - - TIME_TO_REPLAY: if(is_ringing) then - call ESMF_AlarmRingerOff(Alarm, RC=STATUS) - VERIFY_(STATUS) - -! Introduce global mass fixer for intermittent replay -! --------------------------------------------------- - allocate( trsum1(nq) ) - allocate( trsum2(nq) ) - call glosum ( STATE,NQ,TRSUM1 ) - - if (rc_blend /= 0) then - ! copy the forecast variables before they are overwritten by the analysis - allocate(blend_u_f (ifirstxy:ilastxy,jfirstxy:jlastxy,km)) - allocate(blend_v_f (ifirstxy:ilastxy,jfirstxy:jlastxy,km)) - allocate(blend_pt_f(ifirstxy:ilastxy,jfirstxy:jlastxy,km)) - allocate(blend_pe_f(ifirstxy:ilastxy,jfirstxy:jlastxy,km+1)) - - blend_u_f = vars%u - blend_v_f = vars%v - blend_pt_f = vars%pt - blend_pe_f = vars%pe - end if - - ALLOCATE( DNS_phis(ifirstxy:ilastxy,jfirstxy:jlastxy ) ) - ALLOCATE( DNS_thv (ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - -! Read the fields to be reset into a bundle -!------------------------------------------ - - DNS_Bundle = ESMF_FieldBundleCreate( RC=STATUS) - VERIFY_(STATUS) - call ESMF_FieldBundleSet(DNS_bundle, grid=ESMFGRID, RC=STATUS) - VERIFY_(STATUS) - - call ESMF_ClockGet(CLOCK, CurrTime=currentTIME, RC=STATUS) - VERIFY_(STATUS) - call MAPL_CFIORead(ReplayFile, currentTime, DNS_Bundle, & -! ONLY_VARS='uwnd,vwnd,delp,ozone,sphu,theta,phis', & - RC=STATUS) - VERIFY_(STATUS) - -! Fill the state variables from the bundle only if the corresponding fields are there. -!------------------------------------------------------------------------------------- - -! U-Wind -!------- - if( trim(uname).ne.'NULL' ) then - call ESMFL_BundleGetPointertoData(DNS_Bundle,trim(uname),TEMP3D, RC=STATUS) - if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Replaying ',trim(uname) - vars%u = TEMP3D - endif - endif - -! V-Wind -!------- - if( trim(vname).ne.'NULL' ) then - call ESMFL_BundleGetPointertoData(DNS_Bundle,trim(vname),TEMP3D, RC=STATUS) - if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Replaying ',trim(vname) - vars%v = TEMP3D - endif - endif - -! Put A-Grid Wind Fields on the D-grid -! ------------------------------------ - if( trim(rgrid).eq.'A-GRID' .and. trim(uname).ne.'NULL' .and. trim(vname).ne.'NULL' ) then - if(grid%iam==0) print *, 'Convert A-Grid Winds to D-Grid' - call a2d3d( state%grid, vars%u, vars%v ) - endif - -! Pressure -!--------- - if( trim(dpname).ne.'NULL' ) then - call ESMFL_BundleGetPointertoData(DNS_Bundle,trim(dpname),TEMP3D, RC=STATUS) - DNS_PRESSURE: if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Replaying ',trim(dpname) - vars%pe(:,:,1) = grid%ak(1) - do k=2,km+1 - vars%pe(:,:,k) = vars%pe(:,:,k-1) + temp3d(:,:,k-1) - enddo - pkxy = vars%pe**kappa - do k=1,km - vars%pkz(:,:,k) = ( pkxy(:,:,k+1)-pkxy(:,:,k) ) & - / ( kappa*( log(vars%pe(:,:,k+1))-log(vars%pe(:,:,k)) ) ) - enddo - end if DNS_PRESSURE - endif - -! Ozone (Needs to be adjusted to OX) -!----------------------------------- - if( trim(o3name).ne.'NULL' ) then - call ESMFL_BundleGetPointertoData(DNS_Bundle,trim(o3name),TEMP3D, RC=STATUS) - DNS_OZONE: if(STATUS==ESMF_SUCCESS) then - - if(grid%iam==0) print *, 'Replaying ',trim(o3name) - - call MAPL_Get(MAPL, LONS=LONS, LATS=LATS, ORBIT=ORBIT, RC=STATUS ) - VERIFY_(STATUS) - allocate( ZTH( size(LONS,1),size(LONS,2) ) ) - allocate( SLR( size(LONS,1),size(LONS,2) ) ) - call MAPL_SunGetInsolation( LONS,LATS,ORBIT,ZTH,SLR, CLOCK=CLOCK,RC=STATUS ) - VERIFY_(STATUS) - - pl = ( vars%pe(:,:,2:) + vars%pe(:,:,:km) ) * 0.5 - - do L=1,km - if( ooo%is_r4 ) then - where(PL(:,:,L) >= 100.0 .or. ZTH <= 0.0) & - ooo%content_r4(:,:,L) = TEMP3D(:,:,L)*1.0E-6 - else - where(PL(:,:,L) >= 100.0 .or. ZTH <= 0.0) & - ooo%content (:,:,L) = TEMP3D(:,:,L)*1.0E-6 - end if - enddo - deallocate( ZTH, SLR ) - - end if DNS_OZONE - endif - -! Moisture -!--------- - if( trim(qname).ne.'NULL' ) then - call ESMFL_BundleGetPointertoData(DNS_Bundle,trim(qname),TEMP3D, RC=STATUS) - DSN_HUMIDITY: if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Replaying ',trim(qname) - if( qqq%is_r4 ) then - qqq%content_r4 = TEMP3D - else - qqq%content = TEMP3D - endif - end if DSN_HUMIDITY - endif - -! Temperature -!------------ - if( trim(tname).ne.'NULL' ) then - call ESMFL_BundleGetPointertoData(DNS_Bundle,trim(tname),TEMP3D, RC=STATUS) - DSN_THETAV: if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Replaying ',trim(tname) - if( trim(tvar).eq.'THETAV' ) DNS_thv = TEMP3D - if( trim(tvar).eq.'TV' ) DNS_thv = TEMP3D/vars%pkz - if( trim(tvar).eq.'THETA' .or. & - trim(tvar).eq.'T' ) then - if( qqq%is_r4 ) then - if( trim(tvar).eq.'THETA' ) DNS_thv = TEMP3D*(1.0+eps*qqq%content_r4) - if( trim(tvar).eq.'T' ) DNS_thv = TEMP3D*(1.0+eps*qqq%content_r4)/vars%pkz - else - if( trim(tvar).eq.'THETA' ) DNS_thv = TEMP3D*(1.0+eps*qqq%content ) - if( trim(tvar).eq.'T' ) DNS_thv = TEMP3D*(1.0+eps*qqq%content )/vars%pkz - endif - endif - else - if( qqq%is_r4 ) then - DNS_thv = vars%pt*(1.0+eps*qqq%content_r4) - else - DNS_thv = vars%pt*(1.0+eps*qqq%content ) - endif - end if DSN_THETAV - endif - -! If there is a topo in the file, remap fields -!--------------------------------------------- - call ESMFL_BundleGetPointertoData(DNS_Bundle,'phis',TEMP2D, RC=STATUS) - if(STATUS==ESMF_SUCCESS) then - if(grid%iam==0) print *, 'Remapping ...' - DNS_phis = TEMP2D - call remap ( vars%pe, vars%u, vars%v, DNS_thv, vars%tracer, DNS_phis, phisxy, & - grid%ak, grid%bk, size(DNS_thv,1), size(DNS_thv,2), km, nq ) - end if - - if( qqq%is_r4 ) then - vars%pt = dns_thv/(1.0+eps*qqq%content_r4) - else - vars%pt = dns_thv/(1.0+eps*qqq%content ) - endif - - pkxy = vars%pe**kappa - do k=1,km - vars%pkz(:,:,k) = ( pkxy(:,:,k+1)-pkxy(:,:,k) ) & - / ( kappa*( log(vars%pe(:,:,k+1))-log(vars%pe(:,:,k)) ) ) - enddo - -! Blend wind and temperature -! -------------------------- - if (rc_blend /= 0) then - - if (grid%iam == 0) then - write(*, '(A)') 'INFO::REPLAY::BLENDING: Blending...' - endif - - ! make sure that p_above <= p_below - blend_p_above = min(rc_blend_p_above, rc_blend_p_below) - blend_p_below = max(rc_blend_p_above, rc_blend_p_below) - - call blend_wind_height(blend_u_f, blend_v_f, blend_pt_f, blend_pe_f, & - vars%u, vars%v, vars%pt, vars%pe, & - blend_p_below, blend_p_above, & - ifirstxy, ilastxy, jfirstxy, jlastxy, km) - - deallocate(blend_u_f) - deallocate(blend_v_f) - deallocate(blend_pt_f) - deallocate(blend_pe_f) - - if (grid%iam == 0) then - write(*, '(A)') 'INFO::REPLAY::BLENDING: Done.' - print * - endif - - end if ! blending - -! Done with replay; clean-up -!--------------------------- - - call ESMF_FieldBundleGet(DNS_Bundle , FieldCount=NUMVARS, RC=STATUS) - VERIFY_(STATUS) - - do k=1,NUMVARS - call ESMF_FieldBundleGet (DNS_Bundle, k, DNS_FIELD, RC=STATUS) - VERIFY_(STATUS) - call MAPL_FieldDestroy (DNS_Field, RC=STATUS) - VERIFY_(STATUS) - end do - - call ESMF_FieldBundleDestroy(DNS_Bundle, RC=STATUS) - VERIFY_(STATUS) - - DEALLOCATE( DNS_phis ) - DEALLOCATE( DNS_thv ) - -! Apply mass fixer tracers after state update -! ------------------------------------------- - call glosum ( STATE,NQ,TRSUM2 ) - do n=1,NQ - if( trsum2(n).ne.0.0d0 ) then - trsum2(n) = trsum1(n)/trsum2(n) - else - trsum2(n) = 1.0d0 - endif - if( STATE%VARS%TRACER(N)%IS_R4 ) then - state%vars%tracer(n)%content_r4 = state%vars%tracer(n)%content_r4 * trsum2(n) - else - state%vars%tracer(n)%content = state%vars%tracer(n)%content * trsum2(n) - endif - enddo - deallocate( trsum1 ) - deallocate( trsum2 ) - - end if TIME_TO_REPLAY - end if REPLAYING - -! Create Local Copy of QV and OX (Contains Updates from Analysis) -!---------------------------------------------------------------- - - ox = 0.0d0 ! Initialize in case no OX advection - do k=1,size(names) - pos = index(names(k),'::') - if(pos > 0) then - if( (names(k)(pos+2:))=='OX' ) then - if ( ooo%is_r4 ) then - ox = ooo%content_r4 - else - ox = ooo%content - endif - endif - endif - if( trim(names(k))=='Q' ) then - if ( qqq%is_r4 ) then - qv = qqq%content_r4 - else - qv = qqq%content - endif - endif - enddo - -! Diagnostics Before Analysis Increments are Added -!------------------------------------------------- - - call MAPL_GetPointer ( IMPORT, dqvana, 'DQVANA', RC=STATUS ) ! Get QV Increment from Analysis - VERIFY_(STATUS) - call MAPL_GetPointer ( IMPORT, dqlana, 'DQLANA', RC=STATUS ) ! Get QL Increment from Analysis - VERIFY_(STATUS) - call MAPL_GetPointer ( IMPORT, dqiana, 'DQIANA', RC=STATUS ) ! Get QI Increment from Analysis - VERIFY_(STATUS) - call MAPL_GetPointer ( IMPORT, doxana, 'DOXANA', RC=STATUS ) ! Get OX Increment from Analysis - VERIFY_(STATUS) - - QL = 0.0 - QI = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - if( state%vars%tracer(N)%is_r4 ) then - QL = QL + state%vars%tracer(N)%content_r4 - else - QL = QL + state%vars%tracer(N)%content - endif - endif - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - if( state%vars%tracer(N)%is_r4 ) then - QI = QI + state%vars%tracer(N)%content_r4 - else - QI = QI + state%vars%tracer(N)%content - endif - endif - enddo - QVOLD = QV-DQVANA - QLOLD = QL-DQLANA - QIOLD = QI-DQIANA - - QDOLD = 1.0 - (QVOLD+QLOLD+QIOLD) - QDNEW = 1.0 - (QV +QL +QI ) - - call d2a3d( grid, vars%u, vars%v, ua, va ) - - delp = vars%pe(:,:,2:) -vars%pe(:,:,:km) ! Pressure Thickness - dmdt = vars%pe(:,:,km+1)-vars%pe(:,:,1) ! Psurf-Ptop - tempxy = vars%pt * (1.0+eps*(qv-dqvana)) ! Compute THV Before Analysis Update - - call Energetics (state,vars%u,vars%v,tempxy,vars%pe,delp,vars%pkz,phisxy,kenrg,penrg,tenrg) - -! DUDTANA -! ------- - call MAPL_GetPointer ( export, dudtana, 'DUDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dudtana) ) dudtana = ua - -! DVDTANA -! ------- - call MAPL_GetPointer ( export, dvdtana, 'DVDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dvdtana) ) dvdtana = va - -! DTDTANA -! ------- - call MAPL_GetPointer ( export, dtdtana, 'DTDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dtdtana) ) dtdtana = vars%pt * vars%pkz - -! DDELPDTANA -! ---------- - call MAPL_GetPointer ( export, ddpdtana, 'DDELPDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(ddpdtana) ) ddpdtana = delp - -! DTHVDTANAINT -! ------------ - call MAPL_GetPointer ( export, temp2D, 'DTHVDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = vars%pt*(1+eps*(qv-dqvana)) ! Set tempxy = TH*QVold (Before Analysis Update) - dthdtanaint1 = 0.0 - do k=1,km - dthdtanaint1 = dthdtanaint1 + tempxy(:,:,k)*delp(:,:,k) - enddo - endif - -! DQVDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQVDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = qv-dqvana ! Set tempxy = QVold (Before Analysis Update) - dqvdtanaint1 = 0.0 - do k=1,km - dqvdtanaint1 = dqvdtanaint1 + tempxy(:,:,k)*delp(:,:,k) - enddo - endif - -! DQLDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQLDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dqldtanaint1 = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - do k=1,km - if( state%vars%tracer(N)%is_r4 ) then - dqldtanaint1 = dqldtanaint1 + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - else - dqldtanaint1 = dqldtanaint1 + state%vars%tracer(N)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - do k=1,km - dqldtanaint1 = dqldtanaint1 - dqlana(:,:,k)*delp(:,:,k) - enddo - endif - -! DQIDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQIDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dqidtanaint1 = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - do k=1,km - if( state%vars%tracer(N)%is_r4 ) then - dqidtanaint1 = dqidtanaint1 + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - else - dqidtanaint1 = dqidtanaint1 + state%vars%tracer(N)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - do k=1,km - dqidtanaint1 = dqidtanaint1 - dqiana(:,:,k)*delp(:,:,k) - enddo - endif - -! DOXDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DOXDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = ox-doxana ! Set tempxy = OXold (Before Analysis Update) - doxdtanaint1 = 0.0 - do k=1,km - doxdtanaint1 = doxdtanaint1 + tempxy(:,:,k)*delp(:,:,k) - enddo - endif - -! Add Diabatic Forcing from Analysis to State Variables -! ----------------------------------------------------- - - allocate( trsum1(nq) ) - allocate( trsum2(nq) ) - - ! Compute Global Mass of Aerosol Constituents Before ANA Updates - ! -------------------------------------------------------------- - call glosum ( STATE,NQ,TRSUM1 ) - - call ADD_INCS ( STATE,IMPORT,DT ) - -! Update Specific Mass of Aerosol Constituents Keeping Mixing_Ratio Constant WRT_Dry_Air After ANA Updates -! -------------------------------------------------------------------------------------------------------- - do n=1,NQ - if( (trim(names(n)).ne.'Q' ) .and. & - (trim(names(n)).ne.'QLLS') .and. & - (trim(names(n)).ne.'QLCN') .and. & - (trim(names(n)).ne.'QILS') .and. & - (trim(names(n)).ne.'QICN') .and. & - (trim(names(n)).ne.'CLLS') .and. & - (trim(names(n)).ne.'CLCN') ) then - if( STATE%VARS%TRACER(N)%IS_R4 ) then - state%vars%tracer(n)%content_r4 = state%vars%tracer(n)%content_r4 * ( QDNEW/QDOLD ) - else - state%vars%tracer(n)%content = state%vars%tracer(n)%content * ( QDNEW/QDOLD ) - endif - endif - enddo - - ! Compute Global Mass of Aerosol Constituents After ANA Updates - ! ------------------------------------------------------------- - call glosum ( STATE,NQ,TRSUM2 ) - - ! Ensure Conservation of Global Mass of Aerosol Constituents After ANA Updates - ! ---------------------------------------------------------------------------- - do n=1,NQ - if( (trim(names(n)).ne.'Q' ) .and. & - (trim(names(n)).ne.'QLLS') .and. & - (trim(names(n)).ne.'QLCN') .and. & - (trim(names(n)).ne.'QILS') .and. & - (trim(names(n)).ne.'QICN') .and. & - (trim(names(n)).ne.'CLLS') .and. & - (trim(names(n)).ne.'CLCN') ) then - - if( trsum2(n).ne.0.0d0 ) then - trsum2(n) = trsum1(n)/trsum2(n) - else - trsum2(n) = 1.0d0 - endif - !IF (MAPL_AM_I_ROOT()) print *, trim(names(n)),' ratio is: ',trsum2(n) - - if( STATE%VARS%TRACER(N)%IS_R4 ) then - state%vars%tracer(n)%content_r4 = state%vars%tracer(n)%content_r4 * trsum2(n) - else - state%vars%tracer(n)%content = state%vars%tracer(n)%content * trsum2(n) - endif - endif - enddo - - deallocate( trsum1 ) - deallocate( trsum2 ) - -! Update Local Copy of QV and OX to account for Global Sum Adjustment -!-------------------------------------------------------------------- - - do k=1,size(names) - pos = index(names(k),'::') - if(pos > 0) then - if( (names(k)(pos+2:))=='OX' ) then - if ( ooo%is_r4 ) then - ox = ooo%content_r4 - else - ox = ooo%content - endif - endif - endif - if( trim(names(k))=='Q' ) then - if ( qqq%is_r4 ) then - qv = qqq%content_r4 - else - qv = qqq%content - endif - endif - enddo - -! Diagnostics After Analysis Increments are Added -!------------------------------------------------ - - call MAPL_GetPointer ( export, temp2D, 'DMDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) temp2D = ( (vars%pe(:,:,km+1)-vars%pe(:,:,1)) - dmdt )/(grav*dt) - - call d2a3d( grid, vars%u, vars%v, ua, va ) - - delp = vars%pe(:,:,2:) -vars%pe(:,:,:km) ! Pressure Thickness - dmdt = vars%pe(:,:,km+1)-vars%pe(:,:,1) ! Psurf-Ptop - -! DUDTANA -! ------- - call MAPL_GetPointer ( export, dudtana, 'DUDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dudtana) ) then - dummy = ua - dudtana = (dummy-dudtana)/dt - endif - -! DVDTANA -! ------- - call MAPL_GetPointer ( export, dvdtana, 'DVDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dvdtana) ) then - dummy = va - dvdtana = (dummy-dvdtana)/dt - endif - -! DTDTANA -! ------- - call MAPL_GetPointer ( export, dtdtana, 'DTDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(dtdtana) ) then - dummy = vars%pt*vars%pkz - dtdtana = (dummy-dtdtana)/dt - endif - -! DDELPDTANA -! ---------- - call MAPL_GetPointer ( export, ddpdtana, 'DDELPDTANA', rc=status ) - VERIFY_(STATUS) - if( associated(ddpdtana) ) then - dummy = delp - ddpdtana = (dummy-ddpdtana)/dt - endif - -! DTHVDTANAINT -! ------------ - call MAPL_GetPointer ( export, temp2D, 'DTHVDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = vars%pt*(1+eps*qv) ! Set tempxy = TH*QVnew (After Analysis Update) - dthdtanaint2 = 0.0 - do k=1,km - dthdtanaint2 = dthdtanaint2 + tempxy(:,:,k)*delp(:,:,k) - enddo - temp2D = (dthdtanaint2-dthdtanaint1) * MAPL_P00**MAPL_KAPPA / (MAPL_GRAV*DT) - endif - -! DQVDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQVDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = qv ! Set tempxy = QNEW (After Analysis Update) - dqvdtanaint2 = 0.0 - do k=1,km - dqvdtanaint2 = dqvdtanaint2 + tempxy(:,:,k)*delp(:,:,k) - enddo - temp2D = (dqvdtanaint2-dqvdtanaint1) / (MAPL_GRAV*DT) - endif - -! DQLDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQLDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dqldtanaint2 = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - do k=1,km - if( state%vars%tracer(N)%is_r4 ) then - dqldtanaint2 = dqldtanaint2 + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - else - dqldtanaint2 = dqldtanaint2 + state%vars%tracer(N)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2D = (dqldtanaint2-dqldtanaint1) / (MAPL_GRAV*DT) - endif - -! DQIDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DQIDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dqidtanaint2 = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - do k=1,km - if( state%vars%tracer(N)%is_r4 ) then - dqidtanaint2 = dqidtanaint2 + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - else - dqidtanaint2 = dqidtanaint2 + state%vars%tracer(N)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2D = (dqidtanaint2-dqidtanaint1) / (MAPL_GRAV*DT) - endif - -! DOXDTANAINT -! ----------- - call MAPL_GetPointer ( export, temp2D, 'DOXDTANAINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - tempxy = ox ! Set tempxy = OXnew (After Analysis Update) - doxdtanaint2 = 0.0 - do k=1,km - doxdtanaint2 = doxdtanaint2 + tempxy(:,:,k)*delp(:,:,k) - enddo - temp2D = (doxdtanaint2-doxdtanaint1) * (MAPL_O3MW/MAPL_AIRMW) / (MAPL_GRAV*DT) - endif - -! Create FV Thermodynamic Variables -!---------------------------------- - - tempxy = vars%pt * vars%pkz ! Compute Dry Temperature - vars%pt = vars%pt * (1.0+eps*qv) ! Compute Virtual Potential Temperature - -! Initialize Diagnostic Dynamics Tendencies -! ----------------------------------------- - - ddpdt = delp ! Pressure Thickness Tendency - dudt = ua ! U-Wind on A-Grid Tendency - dvdt = va ! V-Wind on A-Grid Tendency - dtdt = tempxy ! Dry Temperature Tendency - dqdt = qv ! Specific Humidity Tendency - -! Initialize 3-D Tracer Dynamics Tendencies -! ----------------------------------------- - - call MAPL_GetPointer( export,dqldt,'DQLDTDYN', rc=status ) - VERIFY_(STATUS) - if( associated(dqldt) ) then - dqldt = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - if( state%vars%tracer(N)%is_r4 ) then - dqldt = dqldt - state%vars%tracer(N)%content_r4 - else - dqldt = dqldt - state%vars%tracer(N)%content - endif - endif - enddo - endif - - call MAPL_GetPointer( export,dqidt,'DQIDTDYN', rc=status ) - VERIFY_(STATUS) - if( associated(dqidt) ) then - dqidt = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - if( state%vars%tracer(N)%is_r4 ) then - dqidt = dqidt - state%vars%tracer(N)%content_r4 - else - dqidt = dqidt - state%vars%tracer(N)%content - endif - endif - enddo - endif - - call MAPL_GetPointer( export,doxdt,'DOXDTDYN', rc=status ) - VERIFY_(STATUS) - if( associated(doxdt) ) then - doxdt = 0.0 - do N = 1,size(names) - pos = index(names(N),'::') - if(pos > 0) then - if( (names(N)(pos+2:))=='OX' ) then - if( state%vars%tracer(N)%is_r4 ) then - doxdt = doxdt - state%vars%tracer(N)%content_r4 - else - doxdt = doxdt - state%vars%tracer(N)%content - endif - endif - endif - enddo - endif - -! Initialize 2-D Vertically Integrated Tracer Dynamics Tendencies -! --------------------------------------------------------------- - - call MAPL_GetPointer ( export, temp2D, 'DQVDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d - qv(:,:,k)*delp(:,:,k) - enddo - endif - - call MAPL_GetPointer ( export, temp2D, 'DQLDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - enddo - endif - - call MAPL_GetPointer ( export, temp2D, 'DQIDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - enddo - endif - - call MAPL_GetPointer ( export, temp2D, 'DOXDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - temp2d = 0.0 - do N = 1,size(names) - pos = index(names(N),'::') - if(pos > 0) then - if( (names(N)(pos+2:))=='OX' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d - state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - endif - enddo - endif - - -! Compute Grid-Cell Area -! ---------------------- - - call MAPL_GetPointer(export,temp2d,'AREA', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - do j=MAX(2,jfirstxy),MIN(jlastxy,jm-1) - tmp2d(:,j) = grid%dl*grid%cosp(j)*RADIUS * grid%dp*RADIUS - enddo - if ( jfirstxy == 1 ) then - j=1 - tmp2d(:,j) = grid%acap*( grid%dl*RADIUS * grid%dp*RADIUS)/im - endif - if ( jlastxy == jm ) then - j=jm - tmp2d(:,j) = grid%acap*( grid%dl*RADIUS * grid%dp*RADIUS)/im - endif - temp2d = tmp2d - end if - -! Compute Energetics After Analysis (and Before Dycore) -! ----------------------------------------------------- - - call Energetics (state,vars%u,vars%v,vars%pt,vars%pe,delp,vars%pkz,phisxy, kenrg0,penrg0,tenrg0,ke=ke,cpt=cpt,gze=gze) - - kenrg = (kenrg0-kenrg)/DT - penrg = (penrg0-penrg)/DT - tenrg = (tenrg0-tenrg)/DT - - call FILLOUT2 (export, 'KEANA', kenrg, rc=status); VERIFY_(STATUS) - call FILLOUT2 (export, 'PEANA', penrg, rc=status); VERIFY_(STATUS) - call FILLOUT2 (export, 'TEANA', tenrg, rc=status); VERIFY_(STATUS) - -! Add Passive Tracers for KE and PHI+CpT -! -------------------------------------- - - nq = STATE%GRID%NQ - - phi00 = 0.0 - do k=1,km - phi(:,:,k) = ( gze(:,:,k+1)*vars%pe(:,:,k+1)-gze(:,:,k)*vars%pe(:,:,k) )/delp(:,:,k) + (1+kappa)*cpt(:,:,k) - phi00 = phi00 + phi(:,:,k)*delp(:,:,k) - enddo - phi00 = phi00 / grav - - if( NXQ.eq.2 ) then - NKE = nq-1 - NPHI = nq - state%vars%tracer(NKE )%content => KE - state%vars%tracer(NPHI)%content => PHI - state%vars%tracer(NKE )%is_r4 = .false. - state%vars%tracer(NPHI)%is_r4 = .false. - - deallocate( NAMES ) - allocate( NAMES(NQ),STAT=STATUS ) - VERIFY_(STATUS) - NAMES(1:NQ-NXQ) = NAMES0(1:NQ-NXQ) - NAMES(NQ-1) = 'KE' - NAMES(NQ ) = 'PHI' - deallocate( NAMES0 ) - allocate( NAMES0(NQ),STAT=STATUS ) - VERIFY_(STATUS) - NAMES0 = NAMES - else - NKE = -999 - NPHI = -999 - endif - - dthdt = vars%pt*delp - -! Clear mass fluxes -!------------------ - - ptfxxyz (:,:,:) = 0. - ptfyxyz (:,:,:) = 0. - mfxxyz_ur(:,:,:) = 0. - mfyxyz_ur(:,:,:) = 0. - mfxxyz (:,:,:) = 0. - mfyxyz (:,:,:) = 0. - mfzxyz (:,:,:) = 0. - mfxxyz_a (:,:,:) = 0. - mfyxyz_a (:,:,:) = 0. - -! Call Wrapper for FVDycore -! ------------------------- - call MAPL_GetResource( MAPL, CONSV, 'CONSV:', default=1, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GetResource( MAPL, FILL, 'FILL:', default=0, RC=STATUS ) - VERIFY_(STATUS) - - LCONSV = CONSV.eq.1 - LFILL = FILL.eq.1 - - call MAPL_TimerOn (MAPL,"-WRAPPER") - call FVdycore_wrapper( phisxy, tempxy, qqq, STATE, & - pkxy, pelnxz, omaxyz, & - cptxyz, thvxyz, epvxyz, & - cxxyz, cyxyz, & - ptfxxyz, ptfyxyz, & - mfxxyz_ur, mfyxyz_ur, & - mfxxyz, mfyxyz, mfzxyz, convt, & - kenrga, penrga, tenrga, & - kenrgb, penrgb, tenrgb, & - keadv, kepg, kedp, kehot, & - dthdtremap, dthdtconsv, dtmp, & - P00, PI, CP, KAPPA, OMEGA, & - RADIUS, GRAV, RGAS, EPS, & - NKE, NPHI, LCONSV, LFILL ) - call MAPL_TimerOff(MAPL,"-WRAPPER") - -! Filter EPV Near Poles -! --------------------- - call MAPL_TimerOn (MAPL,"-DIAG_Polar_FFT") - call Polar_FFT ( epvxyz,grid%lattice ) - call MAPL_TimerOff(MAPL,"-DIAG_Polar_FFT") - -! Check for Negative Tracers -! -------------------------- - delp = ( vars%pe(:,:,2:) - vars%pe(:,:,:km) ) - do k=1,size(names) - if( state%vars%tracer(k)%is_r4 ) then - tempxy = state%vars%tracer(k)%content_r4 - else - tempxy = state%vars%tracer(k)%content - endif - call FILL_Q ( tempxy,delp,names(k),ilastxy-ifirstxy+1,jlastxy-jfirstxy+1,km ) - if( state%vars%tracer(k)%is_r4 ) then - state%vars%tracer(k)%content_r4 = tempxy - else - state%vars%tracer(k)%content = tempxy - endif - enddo - -! Vertically Integrated THV Tendency Diagnostic -! --------------------------------------------- - dthdt = ( vars%pt*delp-dthdt )/dt - - call MAPL_GetPointer(export,temp2d,'DTHVDTDYNINT', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - qsum1 = 0.0 - do k=1,km - qsum1 = qsum1 + dthdt(:,:,k) - enddo - temp2d = qsum1 * (MAPL_P00**MAPL_KAPPA) / grav - end if - - call MAPL_GetPointer(export,temp2d,'DTHVDTREMAP', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = dthdtremap - - call MAPL_GetPointer(export,temp2d,'DTHVDTCONSV', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = dthdtconsv - -! Unify Poles for Tracers -! ----------------------- - - call PUSH_Q ( STATE ) - -! Load Local Variable with Vapor Specific Humidity -! ------------------------------------------------ - - if ( qqq%is_r4 ) then - qv = qqq%content_r4 - else - qv = qqq%content - endif - -! Compute Dry Theta and T with Unified Poles -! ------------------------------------------ - - vars%pt = vars%pt / (1.0+eps*qv ) - tempxy = vars%pt * vars%pkz - -! Compute Mid-Layer Pressure and Pressure Thickness -! ------------------------------------------------- - - delp = ( vars%pe(:,:,2:) - vars%pe(:,:,:km) ) - pl = ( vars%pe(:,:,2:) + vars%pe(:,:,:km) ) * 0.5 - -! Compute Tropopause Pressure, Temperature, and Moisture -! ------------------------------------------------------ - - call tropovars ( ilastxy-ifirstxy+1,jlastxy-jfirstxy+1,km, & - real(vars%pe ,kind=4), & - real(pl ,kind=4), & - real(tempxy ,kind=4), & - real(qv ,kind=4), & - real(epvxyz*(p00**kappa),kind=4), & - tropp1,tropp2,tropp3,tropt,tropq ) - - call MAPL_GetPointer(export,temp2D,'TROPP_THERMAL',rc=status) - VERIFY_(STATUS) - if(associated(temp2D)) temp2D = tropp1 - - call MAPL_GetPointer(export,temp2D,'TROPP_EPV',rc=status) - VERIFY_(STATUS) - if(associated(temp2D)) temp2D = tropp2 - - call MAPL_GetPointer(export,temp2D,'TROPP_BLENDED',rc=status) - VERIFY_(STATUS) - if(associated(temp2D)) temp2D = tropp3 - - call MAPL_GetPointer(export,temp2D,'TROPT',rc=status) - VERIFY_(STATUS) - if(associated(temp2D)) temp2D = tropt - - call MAPL_GetPointer(export,temp2D,'TROPQ',rc=status) - VERIFY_(STATUS) - if(associated(temp2D)) temp2D = tropq - -! Compute A-Grid Winds -! -------------------- - - call d2a3d( grid, vars%u, vars%v, ua, va ) - -! Compute A-Grid Mass Fluxes -! -------------------------- - - call c2a3d( grid, mfxxyz, mfyxyz, mfxxyz_a, mfyxyz_a ) - -! Compute Diagnostic Dynamics Tendencies -! (Note: initial values of d(m,u,v,T,q)/dt are progs m,u,v,T,q) -! -------------------------------------------------------------- - - dmdt = ( vars%pe(:,:,km+1)-vars%pe(:,:,1) - dmdt )/(grav*dt) - - dudt = ( ua-dudt )/dt - dvdt = ( va-dvdt )/dt - dtdt = (tempxy-dtdt )/dt - dqdt = ( qv-dqdt )/dt - - ddpdt = ( delp - ddpdt )/dt ! Pressure Thickness Tendency - - call FILLOUT3 (export, 'DELP' ,delp , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'DUDTDYN' ,dudt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'DVDTDYN' ,dvdt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'DTDTDYN' ,dtdt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'DQVDTDYN' ,dqdt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'DDELPDTDYN',ddpdt, rc=status); VERIFY_(STATUS) - - call FILLOUT3 (export, 'U_CGRID' ,cxxyz, rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'V_CGRID' ,cyxyz, rc=status); VERIFY_(STATUS) - - call FILLOUT3 (export, 'PTFX' , ptfxxyz , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PTFY' , ptfyxyz , rc=status); VERIFY_(STATUS) - - call FILLOUT3 (export, 'MFX_UR' , mfxxyz_ur , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFY_UR' , mfyxyz_ur , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFX' , mfxxyz , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFY' , mfyxyz , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFZ' , mfzxyz , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFX_A' , mfxxyz_a, rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'MFY_A' , mfyxyz_a, rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'U' , ua , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'V' , va , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'T' , tempxy , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'Q' , qv , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PL' , pl , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PLE' , vars%pe , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PLK' , vars%pkz, rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'U_DGRID', vars%u , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'V_DGRID', vars%v , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PT' , vars%pt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PE' , vars%pe , rc=status); VERIFY_(STATUS) - - call MAPL_GetPointer(export, temp3D, 'EPV', rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = epvxyz*(p00**kappa) - - call MAPL_GetPointer(export, temp3D, 'PV', rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = epvxyz/vars%pt - - call MAPL_GetPointer(export, temp3D, 'S', rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = tempxy*cp - - call MAPL_GetPointer(export, temp3d, 'TH',rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = vars%pt*(p00**kappa) - - call MAPL_GetPointer(export, temp2d, 'DMDTDYN',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = dmdt - - -! Compute 3-D Tracer Dynamics Tendencies -! -------------------------------------- - - if( associated(dqldt) ) then - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - if( state%vars%tracer(N)%is_r4 ) then - dqldt = dqldt + state%vars%tracer(N)%content_r4 - else - dqldt = dqldt + state%vars%tracer(N)%content - endif - endif - enddo - dqldt = dqldt/dt - endif - - if( associated(dqidt) ) then - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - if( state%vars%tracer(N)%is_r4 ) then - dqidt = dqidt + state%vars%tracer(N)%content_r4 - else - dqidt = dqidt + state%vars%tracer(N)%content - endif - endif - enddo - dqidt = dqidt/dt - endif - - if( associated(doxdt) ) then - do N = 1,size(names) - pos = index(names(N),'::') - if(pos > 0) then - if( (names(N)(pos+2:))=='OX' ) then - if( state%vars%tracer(N)%is_r4 ) then - doxdt = doxdt + state%vars%tracer(N)%content_r4 - else - doxdt = doxdt + state%vars%tracer(N)%content - endif - endif - endif - enddo - doxdt = doxdt/dt - endif - -! Compute 2-D Vertically Integrated Tracer Dynamics Tendencies -! ------------------------------------------------------------ - - call MAPL_GetPointer ( export, temp2D, 'DQVDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - do k=1,km - temp2d = temp2d + qv(:,:,k)*delp(:,:,k) - enddo - temp2d = temp2d/(grav*dt) - endif - - call MAPL_GetPointer ( export, temp2D, 'DQLDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - do N = 1,size(names) - if( trim(names(N)).eq.'QLCN' .or. & - trim(names(N)).eq.'QLLS' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - enddo - temp2d = temp2d/(grav*dt) - endif - - call MAPL_GetPointer ( export, temp2D, 'DQIDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - do N = 1,size(names) - if( trim(names(N)).eq.'QICN' .or. & - trim(names(N)).eq.'QILS' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - enddo - temp2d = temp2d/(grav*dt) - endif - - call MAPL_GetPointer ( export, temp2D, 'DOXDTDYNINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - do N = 1,size(names) - pos = index(names(N),'::') - if(pos > 0) then - if( (names(N)(pos+2:))=='OX' ) then - if( state%vars%tracer(N)%is_r4 ) then - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content_r4(:,:,k)*delp(:,:,k) - enddo - else - do k=1,km - temp2d = temp2d + state%vars%tracer(N)%content(:,:,k)*delp(:,:,k) - enddo - endif - endif - endif - enddo - temp2d = temp2d * (MAPL_O3MW/MAPL_AIRMW) / (MAPL_GRAV*DT) - endif - -! Fill Surface and Near-Surface Variables -! --------------------------------------- - - call MAPL_GetPointer(export,temp2d,'PS', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = vars%pe(:,:,km+1) - - call MAPL_GetPointer(export,temp2d,'US', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = ua(:,:,km) - - call MAPL_GetPointer(export,temp2d,'VS' ,rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = va(:,:,km) - - call MAPL_GetPointer(export,temp2d,'TA' ,rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = tempxy(:,:,km) - - call MAPL_GetPointer(export,temp2d,'QA' ,rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = qv(:,:,km) - - call MAPL_GetPointer(export,temp2d,'SPEED',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = sqrt( ua(:,:,km)**2 + va(:,:,km)**2 ) - - -! Virtual temperature -! ------------------- - - tempxy = tempxy*(1.0+eps*qv) - - call MAPL_GetPointer(export,temp3D,'TV' ,rc=status) - VERIFY_(STATUS) - if(associated(temp3D)) temp3D = tempxy - - -! Fluxes: UCPT & VCPT -!-------------------- - call MAPL_GetPointer(export,temp2d,'UCPT',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + ua(:,:,k)*tempxy(:,:,k)*delp(:,:,k) - enddo - temp2d = temp2d*(cp/grav) - end if - - call MAPL_GetPointer(export,temp2d,'VCPT',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + va(:,:,k)*tempxy(:,:,k)*delp(:,:,k) - enddo - temp2d = temp2d*(cp/grav) - end if - - -! Compute Energetics After Dycore -! ------------------------------- - - tempxy = vars%pt*(1.0+eps*qv) ! Convert TH to THV - - call MAPL_GetPointer(export,temp3d,'THV',rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = tempxy - - call Energetics (state,vars%u,vars%v,tempxy,vars%pe,delp,vars%pkz,phisxy,kenrg,penrg,tenrg) - - kedyn = (kenrg -kenrg0)/DT - pedyn = (penrg -penrg0)/DT - tedyn = (tenrg -tenrg0)/DT - - kecdcor = (kenrga-kenrg0)/DT - pecdcor = (penrga-penrg0)/DT - tecdcor = (tenrga-tenrg0)/DT - - keremap = (kenrgb-kenrga)/DT - peremap = (penrgb-penrga)/DT - teremap = (tenrgb-tenrga)/DT - - call MAPL_GetPointer(export,temp2d,'KEDYN',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kedyn - - call MAPL_GetPointer(export,temp2d,'PEDYN',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = pedyn - - call MAPL_GetPointer(export,temp2d,'TEDYN',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = tedyn - - call MAPL_GetPointer(export,temp2d,'KECDCOR',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kecdcor - - call MAPL_GetPointer(export,temp2d,'PECDCOR',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = pecdcor - - call MAPL_GetPointer(export,temp2d,'TECDCOR',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = tecdcor - - call MAPL_GetPointer(export,temp2d,'KEREMAP',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = keremap - - call MAPL_GetPointer(export,temp2d,'PEREMAP',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = peremap - - call MAPL_GetPointer(export,temp2d,'TEREMAP',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = teremap - - -! Energy Budget Calculations -! -------------------------- - - convke = 0.0 - convthv = 0.0 - convcpt = 0.0 - convphi = 0.0 - kegen = 0.0 - do k=1,km - kegen = kegen - omaxyz(:,:,k)*delp(:,:,k) - convke = convke + ke(:,:,k)*delp(:,:,k) - convphi = convphi + phi(:,:,k)*delp(:,:,k) - convthv = convthv + thvxyz(:,:,k) - convcpt = convcpt + cptxyz(:,:,k) - enddo - kegen = kegen /grav - convthv = convthv/grav * (MAPL_P00**MAPL_KAPPA) - convcpt = convcpt/grav - convke = (convke /grav-kenrg0)/dt - convphi = (convphi/grav- phi00)/dt - convcpt - - - call MAPL_GetPointer(export,temp2d,'KEHOT',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kehot - - call MAPL_GetPointer(export,temp2d,'KEDP',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kedp - - call MAPL_GetPointer(export,temp2d,'KEADV',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = keadv - - call MAPL_GetPointer(export,temp2d,'KEPG',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kepg - - call MAPL_GetPointer(export,temp2d,'KEGEN', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kegen - - call MAPL_GetPointer(export,temp2d,'CONVKE',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = convke - - call MAPL_GetPointer(export,temp2d,'CONVTHV', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = convthv - - call MAPL_GetPointer(export,temp2d,'CONVCPT', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = convcpt - - call MAPL_GetPointer(export,temp2d,'CONVPHI',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = convphi - - call MAPL_GetPointer(export,temp2d,'DKERESIN',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = keadv + kedp + kehot - convke - - call MAPL_GetPointer(export,temp2d,'DKERESPG',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kepg - ( convphi + kegen - tedyn ) - - call MAPL_GetPointer(export,temp2d,'QFIXER',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = pedyn - convcpt + kegen - - -! Fluxes: UKE & VKE -! ----------------- - call MAPL_GetPointer(export,tempu,'UKE',rc=status); VERIFY_(STATUS) - call MAPL_GetPointer(export,tempv,'VKE',rc=status); VERIFY_(STATUS) - - if(associated(tempu) .or. associated(tempv)) then - ke = 0.5*(ua**2 + va**2) - end if - - if(associated(tempu)) then - tempu = 0.0 - do k=1,km - tempu = tempu + ua(:,:,k)*ke(:,:,k)*delp(:,:,k) - enddo - tempu = tempu / grav - end if - - if(associated(tempv)) then - tempv = 0.0 - do k=1,km - tempv = tempv + va(:,:,k)*ke(:,:,k)*delp(:,:,k) - enddo - tempv = tempv / grav - end if - -! Fluxes: UQV & VQV -! ----------------- - call MAPL_GetPointer(export,temp2d,'UQV',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + ua(:,:,k)*QV(:,:,k)*delp(:,:,k) - enddo - temp2d = temp2d / grav - end if - - call MAPL_GetPointer(export,temp2d,'VQV',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + va(:,:,k)*QV(:,:,k)*delp(:,:,k) - enddo - temp2d = temp2d / grav - end if - -! Fluxes: UQL & VQL -! ----------------- - call MAPL_GetPointer(export,temp2d,'UQL',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(n)).eq.'QLCN' .or. & - trim(names(n)).eq.'QLLS' ) then - do k=1,km - if( state%vars%tracer(n)%is_r4 ) then - temp2d = temp2d + ua(:,:,k)*state%vars%tracer(n)%content_r4(:,:,k)*delp(:,:,k) - else - temp2d = temp2d + ua(:,:,k)*state%vars%tracer(n)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2d = temp2d / grav - end if - - call MAPL_GetPointer(export,temp2d,'VQL',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(n)).eq.'QLCN' .or. & - trim(names(n)).eq.'QLLS' ) then - do k=1,km - if( state%vars%tracer(n)%is_r4 ) then - temp2d = temp2d + va(:,:,k)*state%vars%tracer(n)%content_r4(:,:,k)*delp(:,:,k) - else - temp2d = temp2d + va(:,:,k)*state%vars%tracer(n)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2d = temp2d / grav - end if - -! Fluxes: UQI & VQI -! ----------------- - call MAPL_GetPointer(export,temp2d,'UQI',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(n)).eq.'QICN' .or. & - trim(names(n)).eq.'QILS' ) then - do k=1,km - if( state%vars%tracer(n)%is_r4 ) then - temp2d = temp2d + ua(:,:,k)*state%vars%tracer(n)%content_r4(:,:,k)*delp(:,:,k) - else - temp2d = temp2d + ua(:,:,k)*state%vars%tracer(n)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2d = temp2d / grav - end if - - call MAPL_GetPointer(export,temp2d,'VQI',rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do N = 1,size(names) - if( trim(names(n)).eq.'QICN' .or. & - trim(names(n)).eq.'QILS' ) then - do k=1,km - if( state%vars%tracer(n)%is_r4 ) then - temp2d = temp2d + va(:,:,k)*state%vars%tracer(n)%content_r4(:,:,k)*delp(:,:,k) - else - temp2d = temp2d + va(:,:,k)*state%vars%tracer(n)%content (:,:,k)*delp(:,:,k) - endif - enddo - endif - enddo - temp2d = temp2d / grav - end if - -! Height related diagnostics -! -------------------------- - zle(:,:,km+1) = phisxy(:,:) - do k=km,1,-1 - zle(:,:,k) = zle(:,:,k+1) + cp*tempxy(:,:,k)*( pkxy(:,:,k+1)-pkxy(:,:,k) ) - enddo - zle = zle/grav - - call MAPL_GetPointer(export,temp3d,'ZLE',rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = zle - - call MAPL_GetPointer(export,temp2d,'DZ', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = 0.5*( zle(:,:,km)-zle(:,:,km+1) ) - - call MAPL_GetPointer(export,temp3d,'ZL' ,rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = 0.5*( zle(:,:,:km)+zle(:,:,2:) ) - - call MAPL_GetPointer(export,temp3d,'S' ,rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = temp3d + grav*(0.5*( zle(:,:,:km)+zle(:,:,2:) )) - -! Fluxes: UPHI & VPHI -! ------------------- - call MAPL_GetPointer(export,tempu,'UPHI',rc=status); VERIFY_(STATUS) - call MAPL_GetPointer(export,tempv,'VPHI',rc=status); VERIFY_(STATUS) - - if( associated(tempu).or.associated(tempv) ) zl = 0.5*( zle(:,:,:km)+zle(:,:,2:) ) - - if(associated(tempu)) then - tempu = 0.0 - do k=1,km - tempu = tempu + ua(:,:,k)*zl(:,:,k)*delp(:,:,k) - enddo - end if - - if(associated(tempv)) then - tempv = 0.0 - do k=1,km - tempv = tempv + va(:,:,k)*zl(:,:,k)*delp(:,:,k) - enddo - end if - - -! Compute Omega -! ------------- - - do k=1,km - omaxyz(:,:,k) = - omaxyz(:,:,k)*delp(:,:,k) / ( zle(:,:,k+1)-zle(:,:,k) ) * (1.0/grav) - enddo - call FILLOUT3 (export,'OMEGA',omaxyz,rc=status) - VERIFY_(STATUS) - - call MAPL_GetPointer(export,temp2d,'OMEGA500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,omaxyz,log(pl),log(50000.),log(vars%pe(:,:,km+1)),status) - VERIFY_(STATUS) - end if - -! De-Allocate Arrays -! ------------------ - - DEALLOCATE( dummy ) - DEALLOCATE( dqvdtanaint1 ) - DEALLOCATE( dqvdtanaint2 ) - DEALLOCATE( dqldtanaint1 ) - DEALLOCATE( dqldtanaint2 ) - DEALLOCATE( dqidtanaint1 ) - DEALLOCATE( dqidtanaint2 ) - DEALLOCATE( doxdtanaint1 ) - DEALLOCATE( doxdtanaint2 ) - DEALLOCATE( dthdtanaint1 ) - DEALLOCATE( dthdtanaint2 ) - DEALLOCATE( dthdtremap ) - DEALLOCATE( dthdtconsv ) - - DEALLOCATE( TROPP1 ) - DEALLOCATE( TROPP2 ) - DEALLOCATE( TROPP3 ) - DEALLOCATE( TROPT ) - DEALLOCATE( TROPQ ) - - DEALLOCATE( KEPG ) - DEALLOCATE( KEADV ) - DEALLOCATE( KEDP ) - DEALLOCATE( KEHOT ) - DEALLOCATE( KENRG ) - DEALLOCATE( PENRG ) - DEALLOCATE( TENRG ) - DEALLOCATE( KENRG0 ) - DEALLOCATE( PENRG0 ) - DEALLOCATE( TENRG0 ) - - DEALLOCATE( KEGEN ) - DEALLOCATE( KEDYN ) - DEALLOCATE( PEDYN ) - DEALLOCATE( TEDYN ) - DEALLOCATE( KECDCOR) - DEALLOCATE( PECDCOR) - DEALLOCATE( TECDCOR) - DEALLOCATE( KEREMAP) - DEALLOCATE( PEREMAP) - DEALLOCATE( TEREMAP) - - DEALLOCATE( CONVKE ) - DEALLOCATE( CONVCPT) - DEALLOCATE( CONVPHI) - DEALLOCATE( CONVTHV) - - DEALLOCATE( KENRGA ) - DEALLOCATE( PENRGA ) - DEALLOCATE( TENRGA ) - DEALLOCATE( KENRGB ) - DEALLOCATE( PENRGB ) - DEALLOCATE( TENRGB ) - - DEALLOCATE( ke ) - DEALLOCATE( cpt ) - DEALLOCATE( phi ) - DEALLOCATE( gze ) - DEALLOCATE( qsum1 ) - DEALLOCATE( qsum2 ) - - DEALLOCATE( ZL ) - DEALLOCATE( ZLE ) - DEALLOCATE( PKXY ) - DEALLOCATE( tmp2d ) - DEALLOCATE( pelnxz ) - DEALLOCATE( omaxyz ) - DEALLOCATE( cptxyz ) - DEALLOCATE( thvxyz ) - DEALLOCATE( epvxyz ) - DEALLOCATE( cxxyz ) - DEALLOCATE( cyxyz ) - DEALLOCATE( ptfxxyz ) - DEALLOCATE( ptfyxyz ) - DEALLOCATE( mfxxyz_ur ) - DEALLOCATE( mfyxyz_ur ) - DEALLOCATE( mfxxyz ) - DEALLOCATE( mfyxyz ) - DEALLOCATE( mfzxyz ) - DEALLOCATE( mfxxyz_a ) - DEALLOCATE( mfyxyz_a ) - DEALLOCATE( tempxy ) - DEALLOCATE( pl ) - DEALLOCATE( va ) - DEALLOCATE( ua ) - DEALLOCATE( qv ) - DEALLOCATE( ql ) - DEALLOCATE( qi ) - DEALLOCATE( qdnew ) - DEALLOCATE( qdold ) - DEALLOCATE( qvold ) - DEALLOCATE( qlold ) - DEALLOCATE( qiold ) - DEALLOCATE( ox ) - DEALLOCATE( delp ) - DEALLOCATE( dmdt ) - DEALLOCATE( dudt ) - DEALLOCATE( dvdt ) - DEALLOCATE( dtdt ) - DEALLOCATE( dqdt ) - DEALLOCATE( dthdt ) - DEALLOCATE( ddpdt ) - DEALLOCATE( phisxy ) - DEALLOCATE( names ) - DEALLOCATE( phi00 ) - - do i=1,size(STATE%VARS%tracer)-NXQ - if ( .not. STATE%VARS%TRACER(I)%IS_R4 ) then - DEALLOCATE(STATE%VARS%tracer(i)%content, STAT=STATUS) ! TEMPORARY, till pointers are passed - end if - enddo - - DEALLOCATE( STATE%VARS%tracer, STAT=STATUS ) ! Comment out to output tracer to checkpoint file - - call MAPL_TimerOff(MAPL,"RUN1") - call MAPL_TimerOff(MAPL,"TOTAL") - - RETURN_(ESMF_SUCCESS) - -end subroutine RUN1 - -!----------------------------------------------------------------------- - - subroutine CheckBud ( EXPORT,NAME,LBUD,NBUD ) - type (ESMF_State), intent(inout) :: EXPORT - character(len=*), intent(in) :: NAME - integer, intent(inout) :: NBUD - logical, intent(inout) :: LBUD - integer status, rc - real(kind=4), pointer :: temp2d(:,:) - character(len=ESMF_MAXSTR) :: IAm='FV:CheckBud' - call MAPL_GetPointer ( EXPORT,temp2d,trim(NAME),rc=status ) - VERIFY_(STATUS) - if( associated(temp2d) ) then - LBUD = .true. - NBUD = NBUD + 1 - else - LBUD = .false. - endif - return -end subroutine CheckBud - -!----------------------------------------------------------------------- - - subroutine PULL_Q(STATE, IMPORT, QQQ, NXQ, RC) - - type (T_FVDYCORE_STATE) :: STATE - type (ESMF_State) :: IMPORT - type (T_TRACERS) :: QQQ ! Specific Humidity - integer, intent(IN) :: NXQ - integer, optional, intent(OUT) :: RC - - integer :: STATUS - character(len=ESMF_MAXSTR) :: IAm="Pull_Q" - character(len=ESMF_MAXSTR) :: FIELDNAME - type (ESMF_FieldBundle) :: BUNDLE - type (ESMF_Field) :: field - type (ESMF_Array) :: array - type (ESMF_TypeKind_Flag) :: kind - real(r4), pointer :: ptr_r4(:,:,:), humidity(:,:,:) - real(r8), pointer :: ptr(:,:,:) - integer :: I,K,N,NQ - logical :: EMPTY - integer :: i1,in,j1,jn,im,jm,km - real(r8) :: sumout - - i1 = state%grid%ifirstxy - in = state%grid%ilastxy - j1 = state%grid%jfirstxy - jn = state%grid%jlastxy - im = state%grid%im - jm = state%grid%jm - km = state%grid%km - - call ESMF_StateGet(IMPORT, 'TRADV' , BUNDLE, RC=STATUS) - VERIFY_(STATUS) - -! Count the friendlies -!--------------------- - - call ESMF_FieldBundleGet(BUNDLE, fieldCount=NQ, RC=STATUS) - VERIFY_(STATUS) - - NQ = NQ + NXQ - STATE%GRID%NQ = NQ ! GRID%NQ is now the "official" NQ - -! -! Tracer pointer array -! - ALLOCATE(STATE%VARS%tracer(nq), STAT=STATUS) - VERIFY_(STATUS) - - DO n = 1, NQ-NXQ - call ESMF_FieldBundleGet(bundle, fieldIndex=n, field=field, rc=status) - VERIFY_(STATUS) - call ESMF_FieldGet(field, name=fieldname, rc=status) - VERIFY_(STATUS) - call ESMF_FieldGet(field, Array=array, rc=status) - VERIFY_(STATUS) - - call ESMF_ArrayGet(array,typekind=kind,rc=status) - VERIFY_(STATUS) - - STATE%VARS%TRACER(N)%IS_R4 = (kind == ESMF_TYPEKIND_R4) ! Is real*4? - - if ( STATE%VARS%TRACER(N)%IS_R4 ) then - call ESMF_ArrayGet(array, localDE=0, farrayptr=ptr_r4, rc=status) - VERIFY_(STATUS) - state%vars%tracer(n)%content_r4 => MAPL_RemapBounds(PTR_R4, i1,in,j1,jn, & - 1, STATE%GRID%KM) - if (fieldname == "Q") then - qqq%is_r4 = .true. - qqq%content_r4 => state%vars%tracer(n)%content_r4 - end if - -! Constrain Poles -! ---------------- - if ( j1 == 1 ) then - do k=1,km - call par_xsum_r4 ( state%grid, state%vars%tracer(n)%content_r4(i1:in,1,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content_r4(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jm ) then - do k=1,km - call par_xsum_r4 ( state%grid, state%vars%tracer(n)%content_r4(i1:in,jm,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content_r4(i,jm,k) = sumout - enddo - enddo - endif - - else ! Tracer is R8 - - call ESMF_ArrayGet(array, localDE=0, farrayptr=ptr, rc=status) - VERIFY_(STATUS) - - state%vars%tracer(n)%content => PTR - if (fieldname == "Q") then - qqq%is_r4 = .false. - qqq%content => state%vars%tracer(n)%content - end if - -! Constrain Poles -! ---------------- - if ( j1 == 1 ) then - do k=1,km - call par_xsum ( state%grid, state%vars%tracer(n)%content(i1:in,1,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jm ) then - do k=1,km - call par_xsum ( state%grid, state%vars%tracer(n)%content(i1:in,jm,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content(i,jm,k) = sumout - enddo - enddo - endif - endif - END DO - - end subroutine PULL_Q - -!----------------------------------------------------------------------- - - subroutine PUSH_Q (STATE) - - type (T_FVDYCORE_STATE) :: STATE - - - integer :: STATUS - integer :: I,K,N - integer :: i1,in,j1,jn,im,jm,km - real(r8) :: sumout - - i1 = state%grid%ifirstxy - in = state%grid%ilastxy - j1 = state%grid%jfirstxy - jn = state%grid%jlastxy - im = state%grid%im - jm = state%grid%jm - km = state%grid%km - -! Count the friendlies -!--------------------- - - DO N = 1, state%grid%NQ - -! Constrain Poles -! --------------- - if ( state%vars%tracer(n)%is_r4 ) then - if ( j1 == 1 ) then - do k=1,km - call par_xsum_r4 ( state%grid, state%vars%tracer(n)%content_r4(i1:in,1,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content_r4(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jm ) then - do k=1,km - call par_xsum_r4 ( state%grid, state%vars%tracer(n)%content_r4(i1:in,jm,k), & - 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content_r4(i,jm,k) = sumout - enddo - enddo - endif - - else ! Content is R8 - - if ( j1 == 1 ) then - do k=1,km - call par_xsum ( state%grid, state%vars%tracer(n)%content(i1:in,1,k), 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jm ) then - do k=1,km - call par_xsum ( state%grid, state%vars%tracer(n)%content(i1:in,jm,k), 1, sumout ) - sumout = sumout/im - do i=i1,in - state%vars%tracer(n)%content(i,jm,k) = sumout - enddo - enddo - endif - - endif - END DO - - end subroutine PUSH_Q -!----------------------------------------------------------------------- - - subroutine FILLOUT3(export, name, V, RC) - type (ESMF_State), intent(inout) :: export - character(len=*), intent(IN ) :: name - real(r8), intent(IN ) :: V(:,:,:) - integer, optional, intent( out) :: rc - - real(r4), pointer :: CPL(:,:,:) - integer :: status - character(len=ESMF_MAXSTR) :: IAm="Fillout3" - - call MAPL_GetPointer(export, cpl, name, RC=STATUS) - VERIFY_(STATUS) - if(associated(cpl)) cpl=v - - end subroutine FILLOUT3 - -!----------------------------------------------------------------------- - - subroutine FILLOUT2(export, name, V, rc) - type (ESMF_State), intent(inout) :: export - character(len=*), intent(IN ) :: name - real(r8), intent(IN ) :: V(:,:) - integer, optional, intent( out) :: rc - - real(kind=4), pointer :: CPL(:,:) - integer :: status - character(len=ESMF_MAXSTR) :: IAm="Fillout2" - - call MAPL_GetPointer(export, cpl, name, RC=STATUS) - VERIFY_(STATUS) - if(associated(cpl)) cpl=v - - return - end subroutine FILLOUT2 - -!----------------------------------------------------------------------- - - subroutine Energetics (state,ud,vd,thv,ple,delp,pk,phiS,keint,peint,teint,ke,cpt,gze) - use dynamics_vars, only : d2a3d - - type (T_FVDYCORE_STATE) :: STATE - real(8), optional, intent(out) :: ke(:,:,:) - real(8), optional, intent(out) :: cpt(:,:,:) - real(8), optional, intent(out) :: gze(:,:,:) - real(8) ud(:,:,:) - real(8) vd(:,:,:) - real(8) thv(:,:,:) - real(8) ple(:,:,:) - real(8) delp(:,:,:) - real(8) pk(:,:,:) - real(8) keint(:,:) - real(8) peint(:,:) - real(8) teint(:,:) - real(8) phiS(:,:) - - real(8) kinetic, potential, sump - integer i,ifirst,ilast - integer j,jfirst,jlast - integer im,jm,km,k - - real(8), allocatable :: ud2(:,:,:) - real(8), allocatable :: vd2(:,:,:) - real(8), allocatable :: ua2(:,:,:) - real(8), allocatable :: va2(:,:,:) - real(8), allocatable :: pke(:,:,:) - real(8), allocatable :: phiT(:,:) - - ifirst = lbound( ud,1 ) - ilast = ubound( ud,1 ) - jfirst = lbound( ud,2 ) - jlast = ubound( ud,2 ) - km = ubound( ud,3 ) - im = state%grid%im - jm = state%grid%jm - - allocate( ua2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( va2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( ud2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( vd2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( pke ( ifirst:ilast, jfirst:jlast , 1:km+1 ) ) - allocate( phiT ( ifirst:ilast, jfirst:jlast ) ) - -! Compute Model Edge Heights -! -------------------------- - pke = ple**kappa - phiT = phiS - if( present(gze) ) gze(:,:,km+1) = phiS - do k=km,1,-1 - phiT = phiT + cp*thv(:,:,k)*( pke(:,:,k+1)-pke(:,:,k) ) - if( present(gze) ) gze(:,:,k) = phiT - enddo - -! Compute D-Grid Kinetic Energy -! ----------------------------- - ud2 = ud*ud - vd2 = vd*vd - call d2a3d( state%grid, ud2, vd2, ua2, va2 ) - - if( state%grid%jfirstxy.eq.1 ) then - ua2(:,1,:) = ud2(:,2,:) - va2(:,1,:) = vd2(:,2,:) - endif - if( state%grid%jlastxy.eq.jm ) then - ua2(:,jlast,:) = ud2(:,jlast ,:) - va2(:,jlast,:) = vd2(:,jlast-1,:) - endif - -! Compute Energetics: Cp*Tv + K + PHI -! ------------------------------------ - keint = 0.0 - peint = 0.0 - do k=1,km - do j=jfirst,jlast - do i=ifirst,ilast - kinetic = 0.5_r8*( ua2(i,j,k) + va2(i,j,k) ) - potential = cp*thv(i,j,k)*pk(i,j,k) - keint(i,j) = keint(i,j) + kinetic *delp(i,j,k) - peint(i,j) = peint(i,j) + potential*delp(i,j,k) - if( present(ke) ) ke(i,j,k) = kinetic - if( present(cpt) ) cpt(i,j,k) = potential - enddo - enddo - enddo - keint(:,:) = keint(:,:)/grav - peint(:,:) = peint(:,:)/grav - teint(:,:) = (phiS(:,:)*ple(:,:,km+1)-phiT(:,:)*ple(:,:,1))/grav - - if( state%grid%jfirstxy.eq.1 ) then - call par_xsum ( state%grid, keint(ifirst:ilast,1), 1, sump ) ! Unify Pole Estimate -! call par_xsum ( state%grid, keint(ifirst:ilast,2), 1, sump ) ! Average Surrounding Points to Pole Location - sump = sump/im - do i=ifirst,ilast - keint(i,1) = sump - enddo - endif - if( state%grid%jlastxy.eq.jm ) then - call par_xsum ( state%grid, keint(ifirst:ilast,jlast ), 1, sump ) ! Unify Pole Estimate -! call par_xsum ( state%grid, keint(ifirst:ilast,jlast-1), 1, sump ) ! Average Surrounding Points to Pole Location - sump = sump/im - do i=ifirst,ilast - keint(i,jlast) = sump - enddo - endif - - deallocate ( ua2 ) - deallocate ( va2 ) - deallocate ( ud2 ) - deallocate ( vd2 ) - deallocate ( pke ) - deallocate ( phiT ) - - return - end subroutine Energetics - -!----------------------------------------------------------------------- - - subroutine Run2(gc, import, export, clock, rc) - use dynamics_vars, only : a2d3d, d2a3d - use mod_comm, only: commglobal, mp_swapirr - - type(ESMF_GridComp), intent(inout) :: gc - type (ESMF_State), intent(inout) :: import - type (ESMF_State), intent(inout) :: export - type (ESMF_Clock), intent(in) :: clock - integer, intent(out), optional :: rc - -! !Local Variables: - - integer :: status - character(len=ESMF_MAXSTR) :: IAm - - type (MAPL_MetaComp), pointer :: genstate - - type (DYN_wrap) :: wrap - type (T_FVDYCORE_STATE), pointer :: STATE - type (T_FVDYCORE_GRID), pointer :: GRID - type (T_FVDYCORE_VARS), pointer :: VARS - type (T_TRACERS) :: qqq ! Specific Humidity - - real(r8), allocatable :: penrg (:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrg (:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrg (:,:) ! PHIS*(Psurf-Ptop) - real(r8), allocatable :: penrg0(:,:) ! Vertically Integrated Cp*T - real(r8), allocatable :: kenrg0(:,:) ! Vertically Integrated K - real(r8), allocatable :: tenrg0(:,:) ! PHIS*(Psurf-Ptop) - - real(r8), pointer :: phisxy(:,:) - real(r4), pointer :: phis(:,:) - real(r8), allocatable :: slp(:,:) - real(r8), allocatable :: H1000(:,:) - real(r8), allocatable :: H850 (:,:) - real(r8), allocatable :: H500 (:,:) - real(r8), allocatable :: pke(:,:,:) - real(r8), allocatable :: pl(:,:,:) - real(r8), allocatable :: ua(:,:,:) - real(r8), allocatable :: va(:,:,:) - real(r8), allocatable :: va_yz(:,:,:) - real(r8), allocatable :: vd_yz(:,:,:) - real(r8), allocatable :: qv(:,:,:) - real(r8), allocatable :: dp(:,:,:) - real(r8), allocatable :: thv(:,:,:) - real(r8), allocatable :: zle(:,:,:) - real(r8), allocatable :: tempxy(:,:,:) - - real(r8), allocatable :: logpl(:,:,:) - real(r8), allocatable :: logpe(:,:,:) - real(r8), allocatable :: logps(:,:) - - real(r8) :: dt - real(r8) :: delp ! delta pressure thickness - real(r8) :: kinetic ! local kinetic energy - real(r8) :: potential ! local potential energy - - - real(r4), pointer :: QOLD(:,:,:) - real(r4), pointer :: temp3d(:,:,:) - real(r4), pointer :: temp2d(:,: ) - real(r4), pointer :: ztemp1(:,: ) - real(r4), pointer :: ztemp2(:,: ) - real(r4), pointer :: ztemp3(:,: ) - - real(kind=4), allocatable :: dthdtphyint1(:,:) - real(kind=4), allocatable :: dthdtphyint2(:,:) - - integer ifirstxy, ilastxy, ifirst, ilast - integer jfirstxy, jlastxy, jfirst, jlast - integer kfirst, klast - integer im,jm,km, nxq, im1, ng_s, ng_c, ng_d - integer i,j,k - - character(len=ESMF_MAXSTR) :: COMP_NAME - - Iam = "Run2" - call ESMF_GridCompGet( GC, name=COMP_NAME, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // trim(Iam) - -! Retrieve the pointer to the generic state -! ----------------------------------------- - - call MAPL_GetObjectFromGC (GC, GENSTATE, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_TimerOn(GENSTATE,"TOTAL") - call MAPL_TimerOn(GENSTATE,"RUN2") - -! Retrieve the pointer to the internal state -! ------------------------------------------ - - call ESMF_UserCompGetInternalState(gc, 'FVstate', wrap, status) - VERIFY_(STATUS) - state => wrap%dyn_state - - vars => state%vars ! direct handle to control variables - grid => state%grid ! direct handle to grid - dt = state%dt ! dynamics time step (large) - - ifirstxy = grid%ifirstxy - ilastxy = grid%ilastxy - jfirstxy = grid%jfirstxy - jlastxy = grid%jlastxy - jfirst = GRID%jfirst - jlast = GRID%jlast - kfirst = GRID%kfirst - klast = GRID%klast - ng_s = GRID%ng_s - ng_c = GRID%ng_c - ng_d = GRID%ng_d - - - im = grid%im - jm = grid%jm - km = grid%km - nxq = 0 - - ALLOCATE( dthdtphyint1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( dthdtphyint2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( kenrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrg(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( kenrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( penrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( tenrg0(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( phisxy(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE( logps(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - ALLOCATE( ua(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( va(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( qv(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( pl(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( logpl(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( dp(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( thv(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - ALLOCATE( tempxy(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - - ALLOCATE( pke(ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - ALLOCATE( logpe(ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - ALLOCATE( zle(ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - - call MAPL_GetPointer ( IMPORT, PHIS, 'PHIS', RC=STATUS ) - VERIFY_(STATUS) - - phisxy = real(phis,kind=r8) - -! Compute Pressure Thickness -! -------------------------- - - dp = ( vars%pe(:,:,2:) - vars%pe (:,:,:km) ) - -! Create A-Grid Winds -! ------------------- - - call d2a3d( grid, vars%u, vars%v, ua, va ) - -! Specific humidity before and after physics updates -! -------------------------------------------------- - - call MAPL_GetPointer(export,QOLD,'Q', rc=status) - - call PULL_Q ( STATE, IMPORT, qqq, NXQ, rc ) - - if ( qqq%is_r4 ) then - qv = qqq%content_r4 - else - qv = qqq%content - endif - -! Compute Energetics Before Diabatic Forcing -! ------------------------------------------ - - thv = vars%pt*(1.0+eps*QOLD) - - call Energetics (state,vars%u,vars%v,thv,vars%pe,dp,vars%pkz,phisxy,kenrg0,penrg0,tenrg0) - -! DTHVDTPHYINT -! ------------ - call MAPL_GetPointer ( export, temp2D, 'DTHVDTPHYINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dthdtphyint1 = 0.0 - do k=1,km - dthdtphyint1 = dthdtphyint1 + thv(:,:,k)*dp(:,:,k) - enddo - endif - -! Add Diabatic Forcing to State Variables -! --------------------------------------- - - call ADD_INCS ( STATE,IMPORT,DT ) - -! Update Mid-Layer Pressure and Pressure Thickness -! ------------------------------------------------ - - dp = ( vars%pe(:,:,2:) - vars%pe (:,:,:km) ) - pl = ( vars%pe(:,:,2:) + vars%pe (:,:,:km) )*0.5 - - logpl = log(pl) - logpe = log(vars%pe) - logps = log(vars%pe(:,:,km+1)) - -! Create A-Grid Winds -! ------------------- - - call d2a3d( grid, vars%u, vars%v, ua, va ) - -! Compute Energetics After Diabatic Forcing -! ----------------------------------------- - - thv = vars%pt*(1.0+eps*qv) - - call Energetics (state,vars%u,vars%v,thv,vars%pe,dp,vars%pkz,phisxy,kenrg,penrg,tenrg) - - call MAPL_GetPointer(export,temp2d,'KE', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d = kenrg - - kenrg = (kenrg-kenrg0)/DT - penrg = (penrg-penrg0)/DT - tenrg = (tenrg-tenrg0)/DT - - call FILLOUT2 (export, 'KEPHY', kenrg, rc=status); VERIFY_(STATUS) - call FILLOUT2 (export, 'PEPHY', penrg, rc=status); VERIFY_(STATUS) - call FILLOUT2 (export, 'TEPHY', tenrg, rc=status); VERIFY_(STATUS) - -! DTHVDTPHYINT -! ------------ - call MAPL_GetPointer ( export, temp2D, 'DTHVDTPHYINT', rc=status ) - VERIFY_(STATUS) - if( associated(temp2D) ) then - dthdtphyint2 = 0.0 - do k=1,km - dthdtphyint2 = dthdtphyint2 + thv(:,:,k)*dp(:,:,k) - enddo - temp2D = (dthdtphyint2-dthdtphyint1) * MAPL_P00**MAPL_KAPPA / (MAPL_GRAV*DT) - endif - -! Fill V_DGRID with Reasonable Pole Values Averaged from V_AGRID (For use by utilities outside Model) -! --------------------------------------------------------------------------------------------------- - - allocate( va_yz(im,jfirst:jlast,kfirst:klast) ) - allocate( vd_yz(im,jfirst:jlast,kfirst:klast) ) - - if( grid%twod_decomp /= 0 ) then - call mp_swapirr( commglobal, grid%ijk_xy_to_yz%SendDesc, & - grid%ijk_xy_to_yz%RecvDesc, va, va_yz, & - a2in=vars%v, a2out=vd_yz ) - -! Question: why should this be grid%ijk_xy_to_yz and not grid%vxy_to_v ?? Ghosting?? -!!! call mp_sendirr( vars%v, grid%ijk_xy_to_yz%SendDesc, grid%ijk_xy_to_yz%RecvDesc, vd_yz ) -!!! call mp_recvirr( vd_yz, grid%ijk_xy_to_yz%RecvDesc ) - else - do k=1,km - do j=jfirst,jlast - do i=1,im - va_yz(i,j,k) = va(i,j,k) - vd_yz(i,j,k) = vars%v(i,j,k) - enddo - enddo - enddo - endif - - if ( jfirst == 1 ) then - do k=kfirst,klast - im1 = im - do i=1,im - vd_yz(i,jfirst,k) = 0.5_r8*( va_yz(i,jfirst,k)+va_yz(im1,jfirst,k) ) - im1 = i - enddo - enddo - endif - if ( jlast == jm ) then - do k=kfirst,klast - im1 = im - do i=1,im - vd_yz(i,jlast,k) = 0.5_r8*( va_yz(i,jlast,k)+va_yz(im1,jlast,k) ) - im1 = i - enddo - enddo - endif - - if( grid%twod_decomp /= 0 ) then - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, vd_yz, vars%v ) - else - do k=1,km - do j=jfirst,jlast - do i=1,im - vars%v(i,j,k) = vd_yz(i,j,k) - enddo - enddo - enddo - endif - - deallocate( va_yz ) - deallocate( vd_yz ) - -! Fill Diagnostics -! ---------------- - - tempxy = vars%pt * vars%pkz ! Dry Temperature - - call FILLOUT3 (export, 'DELP' , dp , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'U' , ua , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'V' , va , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'T' , tempxy , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'Q' , qv , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PL' , pl , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PLE' , vars%pe , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PLK' , vars%pkz, rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'THV' , thv , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'U_DGRID', vars%u , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'V_DGRID', vars%v , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PT' , vars%pt , rc=status); VERIFY_(STATUS) - call FILLOUT3 (export, 'PE' , vars%pe , rc=status); VERIFY_(STATUS) - - call MAPL_GetPointer(export,temp3d,'TH',rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = vars%pt*(p00**kappa) - -! Compute Edge Heights -! -------------------- - - pke = vars%pe**kappa - zle(:,:,km+1) = phisxy(:,:) - do k=km,1,-1 - zle(:,:,k) = zle(:,:,k+1) + cp*thv(:,:,k)*( pke(:,:,k+1)-pke(:,:,k) ) - enddo - zle(:,:,:) = zle(:,:,:)/grav - - call FILLOUT3 (export, 'ZLE', zle, rc=status); VERIFY_(STATUS) - -! Compute Mid-Layer Heights -! ------------------------- - - call MAPL_GetPointer(export,temp3d,'ZL', rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d = 0.5*( zle(:,:,2:) + zle(:,:,:km) ) - -! Fill Single Level Variables -! --------------------------- - - call MAPL_GetPointer(export,temp2d,'U250', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,ua,logpl,log(25000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'U500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,ua,logpl,log(50000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'U850', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,ua,logpl,log(85000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'V250', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,va,logpl,log(25000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'V500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,va,logpl,log(50000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'V850', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,va,logpl,log(85000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'T250', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,tempxy,logpl,log(25000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'T500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,tempxy,logpl,log(50000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'T850', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,tempxy,logpl,log(85000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'Q250', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,qv,logpl,log(25000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'Q500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,qv,logpl,log(50000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'Q850', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,qv,logpl,log(85000.),logps,status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'H250', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,zle,logpe,log(25000.),rc=status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'H500', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,zle,logpe,log(50000.),rc=status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'H850', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,zle,logpe,log(85000.),rc=status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'H1000', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,zle,logpe,log(100000.),rc=status) - VERIFY_(STATUS) - end if - -! Compute Mid-Level Heights Above Surface -! --------------------------------------- - do k=1,km - zle(:,:,k) = 0.5*( zle(:,:,k)+zle(:,:,k+1) ) - zle(:,:,km+1) - enddo - zle(:,:,km+1) = 0.0 - - call MAPL_GetPointer(export,temp2d,'U50M', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,ua,zle(:,:,1:km),50.,zle(:,:,km+1),status) - VERIFY_(STATUS) - end if - - call MAPL_GetPointer(export,temp2d,'V50M', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - call VertInterp(temp2d,va,zle(:,:,1:km),50.,zle(:,:,km+1),status) - VERIFY_(STATUS) - end if - -! Compute Surface Pressure -! ------------------------ - - call MAPL_GetPointer(export,temp2d,'PS', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) temp2d=vars%pe(:,:,km+1) - -! Compute Vertically Averaged T,U -! ------------------------------- - call MAPL_GetPointer(export,temp2d,'TAVE', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + tempxy(:,:,k)*dp(:,:,k) - enddo - temp2d = temp2d / (vars%pe(:,:,km+1)-vars%pe(:,:,1)) - endif - - call MAPL_GetPointer(export,temp2d,'UAVE', rc=status) - VERIFY_(STATUS) - if(associated(temp2d)) then - temp2d = 0.0 - do k=1,km - temp2d = temp2d + ua(:,:,k)*dp(:,:,k) - enddo - temp2d = temp2d / (vars%pe(:,:,km+1)-vars%pe(:,:,1)) - endif - -! Convert T to Tv -! --------------- - - tempxy = tempxy*(1.0+eps*qv) - - call MAPL_GetPointer(export,temp3d,'TV', rc=status) - VERIFY_(STATUS) - if(associated(temp3d)) temp3d=tempxy - -! Compute Sea-Level Pressure -! -------------------------- - - call MAPL_GetPointer(export,temp2d,'SLP' ,rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(export,Ztemp1,'H1000',rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(export,Ztemp2,'H850' ,rc=status) - VERIFY_(STATUS) - call MAPL_GetPointer(export,Ztemp3,'H500' ,rc=status) - VERIFY_(STATUS) - - if(associated(temp2d) .or. associated(ztemp1) & - .or. associated(ztemp2) & - .or. associated(ztemp3) ) then - ALLOCATE( slp(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE(H1000(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE(H850 (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - ALLOCATE(H500 (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - call get_slp ( km,vars%pe (i,j, km+1),phisxy(i,j), slp(i,j), & - vars%pe (i,j,1:km+1), & - vars%pkz(i,j,1:km ), & - tempxy(i,j,1:km ), & - H1000(i,j), H850(i,j), H500(i,j) ) - enddo - enddo - if(associated(temp2d)) temp2d = slp - if(associated(ztemp1)) where( ztemp1.eq.MAPL_UNDEF ) ztemp1 = H1000 - if(associated(ztemp2)) where( ztemp2.eq.MAPL_UNDEF ) ztemp2 = H850 - if(associated(ztemp3)) where( ztemp3.eq.MAPL_UNDEF ) ztemp3 = H500 - DEALLOCATE(slp,H1000,H850,H500) - end if - -! Deallocate Memory -! ----------------- - - DEALLOCATE( kenrg ) - DEALLOCATE( penrg ) - DEALLOCATE( tenrg ) - DEALLOCATE( kenrg0 ) - DEALLOCATE( penrg0 ) - DEALLOCATE( tenrg0 ) - - DEALLOCATE( phisxy ) - - DEALLOCATE( ua ) - DEALLOCATE( va ) - DEALLOCATE( qv ) - DEALLOCATE( pl ) - DEALLOCATE( dp ) - DEALLOCATE( tempxy ) - - DEALLOCATE( thv ) - DEALLOCATE( pke ) - DEALLOCATE( logpl ) - DEALLOCATE( logpe ) - DEALLOCATE( logps ) - DEALLOCATE( zle ) - DEALLOCATE( dthdtphyint1 ) - DEALLOCATE( dthdtphyint2 ) - - DEALLOCATE( STATE%VARS%tracer, STAT=STATUS ) ! Allocated by call to PULL_Q - - call MAPL_TimerOff(GENSTATE,"RUN2") - call MAPL_TimerOff(GENSTATE,"TOTAL") - - RETURN_(ESMF_SUCCESS) -end subroutine Run2 - -!----------------------------------------------------------------------- - subroutine ADD_INCS ( STATE,IMPORT,DT,QOLD,QNEW,RC ) - - use dynamics_vars, only : a2d3d, d2a3d -! -! !INPUT PARAMETERS: - - type(T_FVDYCORE_STATE), intent(INOUT) :: STATE - type(ESMF_State), intent(INOUT) :: IMPORT - real(r8), intent(IN ) :: DT - real(r4), optional, intent(IN ) :: QOLD (:,:,:) - real(r8), optional, intent(IN ) :: QNEW (:,:,:) - integer, optional, intent(OUT ) :: RC - -! -! !DESCRIPTION: This routine adds the tendencies to the state, -! weighted appropriately by the time step. Temperature -! tendencies are pressure weighted (ie., DELP*DT/Dt). -! All tendencies are on the A-grid, and have an XY decomposition. -! - - integer :: status - - integer :: I1, IN, J1, JN, K, im, jm, km - integer :: KL, KU - real(r8) :: SUMOUT - real(r8), allocatable :: dum(:,:,:), pkzold(:,:,:) - real(r8), allocatable :: pke(:,:,:), dpinv(:,:,:) - real(r8), allocatable :: tend_u(:,:,:), tend_v(:,:,:) - real(kind=4), pointer :: tend(:,:,:) - - character(len=ESMF_MAXSTR) :: IAm="ADD_INCS" - - i1 = state%grid%ifirstxy - in = state%grid%ilastxy - j1 = state%grid%jfirstxy - jn = state%grid%jlastxy - im = state%grid%im - jm = state%grid%jm - km = state%grid%km - -! ********************************************************************** -! **** Update Winds **** -! ********************************************************************** - - ALLOCATE( tend_u(i1:in,j1:jn,km) ) - ALLOCATE( tend_v(i1:in,j1:jn,km) ) - - call ESMFL_StateGetPointerToData ( IMPORT,TEND,'DUDT',RC=STATUS ) - VERIFY_(STATUS) - tend_u = tend - - call ESMFL_StateGetPointerToData ( IMPORT,TEND,'DVDT',RC=STATUS ) - VERIFY_(STATUS) - tend_v = tend - - -! Put the wind tendencies on the D-grid -! ------------------------------------- - call a2d3d( state%grid, tend_u, tend_v ) - -! Add the wind tendencies to the control variables -! ------------------------------------------------ - STATE%VARS%U = STATE%VARS%U + DT*TEND_U - STATE%VARS%V = STATE%VARS%V + DT*TEND_V - -! Set D-GRID U at the South Pole to UNDEF -! --------------------------------------- - if ( j1 == 1 ) STATE%VARS%U(:,1,:) = MAPL_UNDEF - -! Set D-GRID V at Both Poles to UNDEF -! ----------------------------------- -! if ( j1 == 1 ) STATE%VARS%V(:, 1,:) = MAPL_UNDEF -! if ( jn == jm ) STATE%VARS%V(:,jm,:) = MAPL_UNDEF - - DEALLOCATE( tend_u ) - DEALLOCATE( tend_v ) - -! ********************************************************************** -! **** Compute Pressure Thickness Using Old Pressures **** -! ********************************************************************** - - ALLOCATE( dpinv(i1:in,j1:jn,km) ) - do k=1,km - dpinv(:,:,k) = 1.0/( state%vars%pe(:,:,k+1)-state%vars%pe(:,:,k) ) - enddo - -! ********************************************************************** -! **** Update Edge Pressures **** -! ********************************************************************** - - call ESMFL_StateGetPointerToData ( IMPORT,TEND,'DPEDT',RC=STATUS ) - VERIFY_(STATUS) - - KL = lbound( tend,3 ) - KU = ubound( tend,3 ) - - allocate( dum(i1:in,j1:jn,KL:KU) ) - - DUM = DT*TEND - -! Constrain Poles -! --------------- - if ( j1 == 1 ) then - do k=KL,KU - call par_xsum ( state%grid, DUM(i1:in,1,k), 1, sumout ) - sumout = sumout/im - do i=i1,in - DUM(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jm ) then - do k=KL,KU - call par_xsum ( state%grid, DUM(i1:in,jm,k), 1, sumout ) - sumout = sumout/im - do i=i1,in - DUM(i,jm,k) = sumout - enddo - enddo - endif - - STATE%VARS%PE = STATE%VARS%PE + DUM - DEALLOCATE (DUM) - -! ********************************************************************** -! **** Update P*Kappa at Mid-Levels **** -! ********************************************************************** - - ALLOCATE( pke (i1:in,j1:jn,km+1) ) - ALLOCATE( pkzold(i1:in,j1:jn,1:km) ) - - pke = STATE%VARS%PE**kappa - pkzold = STATE%VARS%PKZ - - do k=1,km - STATE%VARS%PKZ(:,:,k) = ( pke(:,:,k+1)-pke(:,:,k) ) & - / ( kappa*( log(STATE%VARS%PE(:,:,k+1))-log(STATE%VARS%PE(:,:,k)) ) ) - enddo - -! ********************************************************************* -! **** Update Dry Potential Temperature **** -! **** -------------------------------- **** -! **** Note: State Variable is Potential Temperature T/P**kappa **** -! **** while IMPORT Coupling is (Delta_P)*DTDt **** -! ********************************************************************* - - call ESMFL_StateGetPointerToData ( IMPORT,TEND,'DTDT',RC=STATUS ) - VERIFY_(STATUS) - - KL = lbound( tend,3 ) - KU = ubound( tend,3 ) - - allocate( dum(i1:in,j1:jn,KL:KU) ) - - DUM = DT*TEND*DPINV/STATE%VARS%PKZ & - + STATE%VARS%PT*( PKZOLD/STATE%VARS%PKZ - 1.0 ) - -! Constrain Poles -! --------------- - if ( j1 == 1 ) then - do k=KL,KU - call par_xsum ( state%grid, DUM(i1:in,1,k), 1, sumout ) - sumout = sumout/im - do i=i1,in - DUM(i,1,k) = sumout - enddo - enddo - endif - if ( jn == jm ) then - do k=KL,KU - call par_xsum ( state%grid, DUM(i1:in,jm,k), 1, sumout ) - sumout = sumout/im - do i=i1,in - DUM(i,jm,k) = sumout - enddo - enddo - endif - - STATE%VARS%PT = STATE%VARS%PT + DUM -! STATE%VARS%PT = (STATE%VARS%PT*(1+EPS*QOLD) + DUM)/(1+EPS*QNEW) - DEALLOCATE (DUM) - - DEALLOCATE( PKE ) - DEALLOCATE( PKZOLD ) - DEALLOCATE( DPINV ) - - return - - end subroutine ADD_INCS - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!BOP - -! !IROUTINE: Finalize - -! !DESCRIPTION: Writes restarts and cleans-up through MAPL\_GenericFinalize and -! deallocates memory from the Private Internal state. -! -! !INTERFACE: - -subroutine Finalize(gc, import, export, clock, rc) - -! !USES: - use dynamics_vars, only : dynamics_clean - -! !ARGUMENTS: - - type (ESMF_GridComp), intent(inout) :: gc - type (ESMF_State), intent(inout) :: import - type (ESMF_State), intent(inout) :: export - type (ESMF_Clock), intent(inout) :: clock - integer, optional, intent( out) :: rc - -!EOP - -! Local variables - type (DYN_wrap) :: wrap - type (T_FVDYCORE_STATE), pointer :: STATE - character (len=ESMF_MAXSTR) :: restart_file - - character(len=ESMF_MAXSTR) :: IAm - character(len=ESMF_MAXSTR) :: COMP_NAME - integer :: status - - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_Config) :: cf - - -! BEGIN - - Iam = "Finalize" - call ESMF_GridCompGet( GC, name=COMP_NAME, config=cf, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // Iam - -! Retrieve the pointer to the state -! --------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - call MAPL_TimerOn(MAPL,"FINALIZE") - -! Retrieve the pointer to the state -!---------------------------------- - - call ESMF_UserCompGetInternalState(gc, 'FVstate', wrap, status) - VERIFY_(STATUS) - - state => wrap%dyn_state - - call dynamics_clean (STATE%GRID) - -! Call Generic Finalize -!---------------------- - - call MAPL_TimerOff(MAPL,"FINALIZE") - call MAPL_TimerOff(MAPL,"TOTAL") - - call MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC=STATUS) - VERIFY_(STATUS) - - RETURN_(ESMF_SUCCESS) - - end subroutine FINALIZE - - -!======================================================================= - - subroutine get_slp ( km,ps,phis,slp,pe,pk,tv,H1000,H850,H500) - implicit none - integer km - real(r8) pk(km) ! layer-mean P**kappa - real(r8) tv(km) ! layer-mean virtual Temperature - real(r8) pe(km+1) ! press at layer edges (Pa) - real(r8) ps ! surface pressure (Pa) - real(r8) phis ! surface geopotential - real(r8) slp ! sea-level pressure (hPa) - real(r8) H1000 ! 1000mb height - real(r8) H850 ! 850mb height - real(r8) H500 ! 500mb height - real(r8) tstar ! extrapolated temperature (K) - real(r8) p_bot - real(r8) tref ! Reference virtual temperature (K) - real(r8) pref ! Reference pressure level (Pa) - real(r8) pkref ! Reference pressure level (Pa) ** kappa - real(r8) dp1, dp2 - - real(r8), parameter :: gamma = 6.5e-3 - real(r8), parameter :: p_offset = 15000. - real(r8), parameter :: gg = gamma/MAPL_GRAV - - real(r8), parameter :: factor = MAPL_grav / ( MAPL_Rgas * gamma ) - real(r8), parameter :: yfactor = MAPL_Rgas * gg - - integer k_bot, k, k1, k2 - - p_bot = ps - p_offset - k_bot = -1 - - do k = km, 2, -1 - if ( pe(k+1) .lt. p_bot ) then - k_bot = k - exit - endif - enddo - - k1 = k_bot - 1 - k2 = k_bot - dp1 = pe(k_bot) - pe(k_bot-1) - dp2 = pe(k_bot+1) - pe(k_bot) - pkref = ( pk(k1)*dp1 + pk(k2)*dp2 ) / (dp1+dp2) - tref = ( tv(k1)*dp1 + tv(k2)*dp2 ) / (dp1+dp2) - pref = 0.5 * ( pe(k_bot+1) + pe(k_bot-1) ) - tstar = tref*( ps/pref )**yfactor - - slp = ps*( 1.0+gg*phis/tstar )**factor - H1000 = (phis/MAPL_grav) - (tstar/gamma)*((100000.0/ps)**(1./factor)-1.0) - H850 = (phis/MAPL_grav) - (tstar/gamma)*(( 85000.0/ps)**(1./factor)-1.0) - H500 = (phis/MAPL_grav) - (tstar/gamma)*(( 50000.0/ps)**(1./factor)-1.0) - return - end subroutine get_slp - -!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - subroutine VertInterp(v2,v3,pl,pp,ps,rc) - - real(r4), intent(OUT) :: v2(:,:) - real(r8), intent(IN ) :: v3(:,:,:) - real(r8), target, intent(IN ) :: pl(:,:,:) - real, intent(IN ) :: pp - real(r8), optional, intent(IN ) :: ps(:,:) - integer, optional, intent(OUT) :: rc - - real, dimension(size(v2,1),size(v2,2)) :: al,PT,PB - integer km, K, msn - logical flip - real ppx - real(r8), pointer :: plx(:,:,:) - - integer :: status - character*(10) :: Iam='VertInterp' - - km = size(pl,3) - - flip = pl(1,1,km) < pl(1,1,km-1) - - if(flip) then - allocate(plx(size(pl,1),size(pl,2),size(pl,3)),stat=status) - VERIFY_(STATUS) - plx = -pl - ppx = -pp - msn = -1 - else - plx => pl - ppx = pp - msn = 1 - end if - - v2 = MAPL_UNDEF - - pb = plx(:,:,km) - do k=km-1,1,-1 - pt = plx(:,:,k) - if(all(pb=ppx) - al = (pb-ppx)/(pb-pt) - v2 = v3(:,:,k)*al + v3(:,:,k+1)*(1.0-al) - end where - pb = pt - end do - -! Extend Lowest Level Value to the Surface -! ---------------------------------------- - if( present(ps) ) then - where( (plx(:,:,km)=ppx) ) - v2 = v3(:,:,km) - end where - end if - - if(flip) then - deallocate(plx,stat=status) - VERIFY_(STATUS) - end if - - RETURN_(ESMF_SUCCESS) - end subroutine VertInterp - -!BOP - -! !IROUTINE: Coldstart - -! !DESCRIPTION: -! Routine to coldstart from an isothermal state of rest. -! The temperature can be specified in the config, otherwise -! it is 300K. The surface pressure is assumed to be 1000 hPa. -! -! !INTERFACE: - -subroutine Coldstart(gc, import, export, clock, rc) - -! !ARGUMENTS: - - type(ESMF_GridComp), intent(inout) :: gc - type(ESMF_State), intent(inout) :: import - type(ESMF_State), intent(inout) :: export - type (ESMF_Clock), intent(in) :: clock - integer, intent(out), optional :: rc - -!EOP - - character(len=ESMF_MAXSTR) :: IAm - character(len=ESMF_MAXSTR) :: COMP_NAME - integer :: status - - type (MAPL_MetaComp), pointer :: MAPL - type (ESMF_State) :: INTERNAL - - real(r8), pointer :: AK(:), BK(:) - real(r8), pointer :: Ptr3(:,:,:) - real(r8), pointer :: PKL (:,:,:) - real, pointer :: LATS (:,:) - real :: T0 - integer :: L - type(ESMF_Config) :: CF - -! Begin - - Iam = "Coldstart" - call ESMF_GridCompGet( GC, name=COMP_NAME, CONFIG=CF, RC=STATUS ) - VERIFY_(STATUS) - Iam = trim(COMP_NAME) // trim(Iam) - -! Retrieve the pointer to the state -! --------------------------------- - - call MAPL_GetObjectFromGC (GC, MAPL, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_TimerOn(MAPL,"TOTAL") - -!BOR -! !RESOURCE_ITEM: K :: Value of isothermal temperature on coldstart - call MAPL_GetResource ( MAPL, T0, 'T0:', default=300., RC=STATUS ) - VERIFY_(STATUS) -!EOR - - call MAPL_Get ( MAPL, & - INTERNAL_ESMF_STATE=INTERNAL, & - lats = LATS, & - RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_GetPointer(Internal,Ptr3,'U' ,rc=STATUS) - VERIFY_(STATUS) - Ptr3 = 0.0 - - Ptr3(1,:,ubound(Ptr3,3)) = .001*abs(lats(1,:)) - - call MAPL_GetPointer(Internal,Ptr3,'V' ,rc=STATUS) - VERIFY_(STATUS) - Ptr3 = 0.0 - - call MAPL_GetPointer(Internal,Ptr3,'PE',rc=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(Internal,PKL ,'PKZ',rc=STATUS) - VERIFY_(STATUS) - - call MAPL_GetPointer(Internal,ak ,'AK' ,rc=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(Internal,bk ,'BK' ,rc=STATUS) - VERIFY_(STATUS) - - call ESMF_ConfigFindLabel( cf, 'AK:', rc = status ) - VERIFY_(STATUS) - do L = 0, SIZE(AK)-1 - call ESMF_ConfigNextLine ( CF, rc=STATUS ) - call ESMF_ConfigGetAttribute( cf, AK(L), rc = status ) - VERIFY_(STATUS) - enddo - - call ESMF_ConfigFindLabel( cf, 'BK:', rc = status ) - VERIFY_(STATUS) - do L = 0, SIZE(bk)-1 - call ESMF_ConfigNextLine ( CF, rc=STATUS ) - call ESMF_ConfigGetAttribute( cf, BK(L), rc = status ) - VERIFY_(STATUS) - enddo - - _ASSERT(ANY(AK /= 0.0) .or. ANY(BK /= 0.0),'needs informative message') - do L=lbound(Ptr3,3),ubound(Ptr3,3) - Ptr3(:,:,L) = AK(L) + BK(L)*MAPL_P00 - enddo - - PKL = 0.5*(Ptr3(:,:,lbound(Ptr3,3) :ubound(Ptr3,3)-1) + & - Ptr3(:,:,lbound(Ptr3,3)+1:ubound(Ptr3,3) ) ) - PKL = PKL**MAPL_KAPPA - - call MAPL_GetPointer(Internal,Ptr3,'PT',rc=STATUS) - VERIFY_(STATUS) - - Ptr3 = T0/PKL - - call MAPL_TimerOff(MAPL,"TOTAL") - - - RETURN_(ESMF_SUCCESS) - end subroutine COLDSTART - - subroutine FILL_Q ( Q,DP,NAME,IM,JM,LM ) - real*8, intent(INOUT) :: Q(:,:,:) - real*8, intent(IN ) :: DP(:,:,:) - integer IM,JM,LM - character(*) NAME - - real*8, allocatable, dimension(:,:) :: QTEMP1 - real*8, allocatable, dimension(:,:) :: QTEMP2 - integer num,L,STATUS - - num = count( q < 0.0_8 ) - if( num.ne.0 ) then -! write(6,1000) trim(name),num,100.0*float(num)/float(IM*JM*LM) -!1000 format(1x,'Negative values for : ',a,3x,i,2x,'( ',g,' )') - - allocate( QTEMP1(IM,JM) ) - allocate( QTEMP2(IM,JM) ) - - QTEMP1 = 0.0 - do L=1,LM - QTEMP1(:,:) = QTEMP1(:,:) + Q(:,:,L)*DP(:,:,L) - enddo - - where( Q < 0.0 ) Q = 0.0 - - QTEMP2 = 0.0 - do L=1,LM - QTEMP2(:,:) = QTEMP2(:,:) + Q(:,:,L)*DP(:,:,L) - enddo - - where( qtemp2.ne.0.0_8 ) - qtemp2 = max( qtemp1/qtemp2, 0.0_8 ) - end where - - do L=1,LM - Q(:,:,L) = Q(:,:,L)*qtemp2(:,:) - enddo - - deallocate(QTEMP1) - deallocate(QTEMP2) - endif - - end subroutine FILL_Q - -!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - subroutine Polar_FFT (q,lattice) - implicit none - - type ( dynamics_lattice_type ) lattice - real(r8) q( lattice%im(lattice%pei), lattice%jm(lattice%pej), lattice%lm ) - integer i,j,im,jm,img,jmg,lm - real(r8) PHI,PHIC,DPHI,CC,X - real(r8), allocatable :: s(:,:) - - im = lattice%im(lattice%pei) - jm = lattice%jm(lattice%pej) - img = lattice%imglobal - jmg = lattice%jmglobal - lm = lattice%lm - - allocate ( s(img+2,jm) ) - S = 1.0D0 - DPHI = MAPL_PI_R8/(JMG-1) - PHIC = MAPL_PI_R8*80.0D0/180.0D0 - DO j=1,JM - phi = -MAPL_PI_R8*0.5D0 + (lattice%jglobal(j)-1)*DPHI - cc = dcos(phi)/dcos(phic) - DO I=3,IMG+2 - x=(I-1)/2 - S(I,J)= min( cc/dsin(x*mapl_pi_r8/img),1.0D0 )**3 - ENDDO - ENDDO - call G3_AVRX (q,im,jm,lm,s,lattice) - deallocate (s) - - return - end subroutine Polar_FFT - -end module FVdycore_GridCompMod diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_arch.mk b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_arch.mk deleted file mode 100644 index b2b583731..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_arch.mk +++ /dev/null @@ -1,17 +0,0 @@ -# -# System dependent FLAGS for FVdycore. -# - - - ifeq ($(ESMA_FC), gfortran) - USER_FFLAGS = -DNO_R16 -fcray-pointer - endif - - ifeq ($(ESMA_FC), ftn) - USER_FFLAGS = -DNO_R16 - endif - - ifeq ($(ESMA_FC), pgfortran) - USER_FFLAGS = -DNO_R16 - endif - diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_dynamics.rc b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_dynamics.rc deleted file mode 100755 index b9ce0b1cd..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_dynamics.rc +++ /dev/null @@ -1,6 +0,0 @@ -# dynamics resource file - -dyn_restart_file: dynamics_restart.in -dyn_incouplings_file: zero_couplings.in -dyn_layout_file: FVdycore_layout.rc -topography_file: topography diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_wrapper.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_wrapper.F90 deleted file mode 100644 index be546770a..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVdycore_wrapper.F90 +++ /dev/null @@ -1,2073 +0,0 @@ -! $Id$ - -!------------------------------------------------------------------------------ -!BOP -! !ROUTINE: FVdycore_wrapper --- Wrapper for NASA finite-volume dynamical core -! -! !INTERFACE: - subroutine FVdycore_wrapper( phisxy, txy, qqq, STATE, & - pkxy, pelnxz, oma_xy, & - convcpt, convthv, epvxyz, cxxyz, cyxyz, & - ptfxxyz, ptfyxyz, & - mfxxyz_ur, mfyxyz_ur, & - mfxxyz, mfyxyz, mfzxyz, convt, & - kenrg1, penrg1, tenrg1, & - kenrg2, penrg2, tenrg2, & - dkedtad, dkedtpg, dkedtdp, dkedtho, & - dthdtremap, dthdtconsv, dtmp, & - P00, PI, CP, KAPPA, OMEGA, & - RADIUS, GRAV, RGAS, EPS, & - NKE, NPHI, CONSV, FILL ) - - -! !USES: - use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 - use mod_comm, only: commglobal, mp_swapirr, mp_swapirr_r4, & - mp_barrier, mp_send4d_ns, mp_recv4d_ns - use dynamics_vars, only : T_TRACERS, T_FVDYCORE_VARS, & - T_FVDYCORE_GRID, T_FVDYCORE_STATE, & - d2a3d - use FVperf_module, only : FVstartclock, FVstopclock - use diag_module, only : compute_vdot_gradp - use sw_core, only : d2a2c_winds - - implicit none - -! !INPUT/OUTPUT PARAMETERS: - type (T_FVDYCORE_STATE), intent(INOUT), target :: STATE - -! !INPUT PARAMETERS: -! Surface geopotential - real(r8), target :: phisxy(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) -! Dry air temperature - real(r8), intent(in) :: txy(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy, & - STATE%GRID%km ) - - type(T_TRACERS) :: qqq2 ! Specific Humidity (for benergy) - type(T_TRACERS), intent(in) :: qqq ! Specific Humidity (for benergy) - logical, intent(in) :: convt ! true: output pt, the virtual temperature - ! false: pt is updated - - real(r8), intent(in) :: P00 ! Reference Surface Pressure - real(r8), intent(in) :: PI ! Constants, passed as arguments for portability: - real(r8), intent(in) :: CP ! Specific heat - real(r8), intent(in) :: KAPPA ! Kappa (=2/7) - real(r8), intent(in) :: OMEGA ! Angular velocity of earth - real(r8), intent(in) :: RADIUS ! Radius of earth - real(r8), intent(in) :: GRAV ! Gravitational acceleration - real(r8), intent(in) :: RGAS ! Dry air gas constant - real(r8), intent(in) :: EPS ! Constant for the virtual effect - - integer, intent(in) :: NKE, NPHI ! OMEGA-ALPHA Tracer Indices (default: -999) - - -! -! Other interesting stuff which the dynamical core can provide -! - -! pe**kappa - real(r8), intent(INOUT) :: pkxy(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km+1) - -! log pressure (pe) at layer edges - real(r8), intent(INOUT) :: pelnxz(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%km+1,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy) -! ertel's potential vorticity ( K*m^2 / (kg*sec) ) - real(r8), intent(INOUT) :: epvxyz(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km) -! zonal accumulated C-grid winds - real(r8), intent(INOUT) :: cxxyz(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km) -! meridonal accumulated C-grid winds - real(r8), intent(INOUT) :: cyxyz(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km) -! zonal total mass flux ( K * pa * m^2/s ) - real(r8), intent(INOUT) :: ptfxxyz(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km) -! meridonal total mass flux ( K * pa * m^2/s ) - real(r8), intent(INOUT) :: ptfyxyz(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km) - -! zonal total mass flux ( pa * m^2/s ) - real(r8), intent(INOUT) :: mfxxyz_ur(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km) -! meridonal total mass flux ( pa * m^2/s ) - real(r8), intent(INOUT) :: mfyxyz_ur(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km) -! Remapped zonal total mass flux ( pa * m^2/s ) - real(r8), intent(INOUT) :: mfxxyz(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km) -! Remapped meridonal total mass flux ( pa * m^2/s ) - real(r8), intent(INOUT) :: mfyxyz(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km) -! Remapped vertical total mass flux ( pa * m^2/s ) - real(r8), intent(INOUT) :: mfzxyz(STATE%GRID%ifirstxy:STATE%GRID%ilastxy,& - STATE%GRID%jfirstxy:STATE%GRID%jlastxy,& - STATE%GRID%km+1) - -! !OUTPUT PARAMETERS: - real(r8), intent(OUT) :: oma_xy(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy, & - STATE%GRID%km ) - real(r8), intent(OUT) :: convcpt(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy, & - STATE%GRID%km ) - real(r8), intent(OUT) :: convthv(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy, & - STATE%GRID%km ) - - real(r8), intent(OUT) :: kenrg1(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - real(r8), intent(OUT) :: penrg1(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - real(r8), intent(OUT) :: tenrg1(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - real(r8), intent(OUT) :: kenrg2(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - real(r8), intent(OUT) :: penrg2(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - real(r8), intent(OUT) :: tenrg2(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - - real(r8), intent(OUT) :: dkedtad(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - real(r8), intent(OUT) :: dkedtpg(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - real(r8), intent(OUT) :: dkedtdp(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - real(r8), intent(OUT) :: dkedtho(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - - real(r8), intent(OUT) :: dthdtremap(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - real(r8), intent(OUT) :: dthdtconsv(STATE%GRID%ifirstxy:STATE%GRID%ilastxy, & - STATE%GRID%jfirstxy:STATE%GRID%jlastxy ) - - real(r8), intent(OUT) :: dtmp ! Temperature Change due to CONSV=TRUE - -! Developer: Shian-Jiann Lin, NASA/GSFC; email: lin@dao.gsfc.nasa.gov -! -! Top view of D-grid prognostatic variables: u, v, and delp (and other scalars) -! -! u(i,j+1) -! | -! v(i,j)---delp(i,j)---v(i+1,j) -! | -! u(i,j) -! -! External routine required: the user needs to supply a subroutine to set up -! "Eulerian vertical coordinate" for remapping purpose. -! Currently this routine is named as set_eta() -! In principle any terrian following vertical -! coordinate can be used. The input to fvcore -! need not be on the same vertical coordinate -! as the output. -! If SPMD is defined the Pilgrim communication -! library developed by Will Sawyer will be needed. -! -! Remarks: values at poles for both u and v need not be defined; but values for -! all other scalars needed to be defined at both poles (as polar cap mean -! quantities). Tracer advection is done "off-line" using the -! large time step. Consistency is maintained by using the time accumulated -! Courant numbers and horizontal mass fluxes for the FFSL algorithm. -! The input "pt" can be either dry potential temperature -! defined as T/pkz (adiabatic case) or virtual potential temperature -! defined as T*/pkz (full phys case). IF convt is true, pt is not updated. -! Instead, virtual temperature is ouput. -! ipt is updated if convt is false. -! The user may set the value of nx to optimize the SMP performance -! The optimal valuse of nx depends on the total number of available -! shared memory CPUs per node (NS). Assuming the maximm MPI -! decomposition is used in the y-direction, set nx=1 if the -! NS <=4; nx=4 if NS=16. -! -! !REVISION HISTORY: -! WS 03.07.16: From dynpkg -! WS 03.08.06 Improvements w.r.t. newest FVdycore from CAM -! WS 03.08.13 Added logic for 2d domain decomposition -! WS 03.11.19 Integrated 1D decomposition case (data copies only) -! WS 04.09.20 Transition away from dynamics_vars (code now reentrant) -! WS 05.05.17 Split off into a separate file for CAM unification -! WP 06.01.18 Added horizontal/vertical mass fluxes and mfz_comp -! WS 06.05.17 Added compute_vdot_gradp for proper OMGA calculation -! WS 06.06.26 Revised for newest benergy routine (conservation mode) -! LT 07.06.04 Modified OMGA calculation -! WS 09.04.01 Upgraded to PILGRIM from cam3_6_33 -! -!EOP -!----------------------------------------------------------------------- -!BOC -! Local variables - - type (T_FVDYCORE_GRID), pointer :: grid - type (T_FVDYCORE_VARS), pointer :: vars - - integer i, j, k, iq ! Loop indices - integer :: rc ! return code - integer :: klastp - integer :: kord ! parameter controlling monotonicity in mapping - ! recommendation: kord=4 - integer :: te_method ! parameter controlling total energy remapping - ! recommendation: kord=1 (cubic interpolation) - integer :: ntotq ! declared dimension of q3 - integer :: ndt ! the large time step in seconds - ! Also the mapping time step in this setup -! -! Variables which used to come from dynamics_vars -! - integer :: icd, jcd ! C-grid algorithm order in X and Y - integer :: iord, jord ! D-grid algorithm order in X and Y - integer :: im, jm, km, nq ! global domain dimensions - integer :: ng_s, ng_c, ng_d ! halo region sizes - - integer :: jfirst, jlast, kfirst, klast ! YZ decomp. ranges - integer :: ifirstxy, ilastxy, jfirstxy, jlastxy ! XY decomp. ranges - integer :: twod_decomp, myid_z, npr_z, npr_y - - real(r8) rcap ! Radius of polar cap - real(r8) ptop ! Pressure at the top of atmosphere - real(r8) sump ! Summation for Pole Values - real(r8) sumpg ! Summation for Pole Values - real(r8) sumdp ! Summation for Pole Values - real(r8) sumho ! Summation for Pole Values - real(r8) sumad ! Summation for Pole Values - - integer :: nsplit - - real(r8) umax ! Maximum winds, m/s - parameter (umax = 300.0) - real(r8), parameter :: HALF = 0.5_r8 - real(r8), parameter :: ONE = 1.0_r8 - - logical consv ! Flag to force conservation of total energy - logical fill ! Flag to use fill algorithm - logical BUDGETS ! Logical to Calculate Exact Budet Terms - - integer nx ! # of split pieces in x-direction; for performance, the - parameter (nx = 1) ! user may set nx=1 if there is NO shared memory multitasking - integer ipe, it - integer n - integer incount, outcount - integer iqa, iqb, iqc, iqd, mq ! used for tracer transpose grouping - integer im1, ip1, js2gd, jn2gd, jpole, jstar, msgn - -! Geometric arrays -! column integrated Total Energy - real(r8) :: tte(state%grid%jm) - - -! The control variables (with YZ decomposition) - - real(r8), allocatable :: u(:,:,:) ! u wind velocities, staggered grid - real(r8), allocatable :: v(:,:,:) ! v wind velocities, staggered grid - real(r8), allocatable :: pt(:,:,:) ! scaled (virtual) potential temperature - real(r8), pointer :: pe(:,:,:) ! Pressure at layer edges - type(T_TRACERS), allocatable :: q_internal(:) ! WAS: q3 - -! Other arrays - real(r8), pointer :: phis (:,:) ! Surface geopotential - real(r8), pointer :: delp (:,:,:) ! Pressure thickness (must be calculated) - real(r8), pointer :: delp0(:,:,:) ! Pressure thickness (must be calculated) - real(r8), pointer :: delpd(:,:,:) ! Pressure thickness (must be calculated) - -!---------------------------------------------------------------------------- -! The three arrays PE, PK, PKZ must be pre-computed as input to benergy(). -! They are NOT needed if consv=.F.; updated on output (to be used by physdrv) -! Please refer to routine pkez on the algorithm for computing pkz -! from pe and pk -!---------------------------------------------------------------------------- - - real(r8), allocatable :: cosp (:,:) ! Cosine of Area Grid-Box - real(r8), allocatable :: ua(:,:,:) ! u-wind on the A-Grid - real(r8), allocatable :: va(:,:,:) ! v-wind on the A-Grid - real(r8), allocatable :: pk(:,:,:) ! pe to the kappa - real(r8), allocatable :: pke(:,:,:) ! pe to the kappa - real(r8), allocatable :: dum(:,:,:) ! layer-mean pk for converting t to pt - - real(r8), allocatable :: ptfx(:,:,:), ptfy(:,:,:) - real(r8), allocatable ::ptfx_accum(:,:,:),ptfy_accum(:,:,:) - real(r8), allocatable :: mfx(:,:,:), mfy(:,:,:) - real(r8), allocatable :: mfx_accum(:,:,:), mfy_accum(:,:,:) - real(r8), allocatable :: cx(:,:,:), cy(:,:,:) - real(r8), allocatable :: cx_accum(:,:,:), cy_accum(:,:,:) - real(r8), allocatable :: tv (:,:,:) - - real(r8), allocatable :: dthconsv (:,:,:) - real(r8), allocatable :: dthdtremap1(:,:) - real(r8), allocatable :: dthdtremap2(:,:) - real(r8), allocatable :: dkedt (:,:) - real(r8), allocatable :: dkedt_xy (:,:,:) - real(r8), allocatable :: dkedt_pg_yz(:,:,:) - real(r8), allocatable :: dkedt_dp_yz(:,:,:) - real(r8), allocatable :: dkedt_ad_yz(:,:,:) - real(r8), allocatable :: dkedt_ho_yz(:,:,:) - - real(r8), allocatable :: thvx(:,:,:) - real(r8), allocatable :: thvy(:,:,:) - real(r8), allocatable :: difx(:,:,:) - real(r8), allocatable :: dify(:,:,:) - real(r8), allocatable :: pbrx(:,:,:) - real(r8), allocatable :: pbry(:,:,:) - real(r8), allocatable :: facx(:,:,:) - real(r8), allocatable :: facy(:,:,:) - real(r8), allocatable :: dpdx(:,:,:) - real(r8), allocatable :: dpdy(:,:,:) - real(r8), allocatable :: oma_yz(:,:,:) - real(r8), allocatable :: cpt_yz(:,:,:) - real(r8), allocatable :: thv_yz(:,:,:) - real(r8), allocatable :: pkz (:,:,:) - real(r8), allocatable :: pkz0(:,:,:) - real(r8), allocatable :: pkzb(:,:,:) - real(r8), allocatable :: thdp (:,:,:) - real(r8), allocatable :: thdp0(:,:,:) - real(r8), allocatable :: thdpb(:,:,:) - - real(r8), allocatable :: gze(:,:,:) - real(r8), allocatable :: phi(:,:,:) - real(r8), allocatable :: del_KE (:,:,:), tot_KE (:,:,:) - real(r8), allocatable :: del_PHI(:,:,:), tot_PHI(:,:,:) - - real(r8), allocatable :: worka(:,:,:),dp0(:,:,:) - real(r8), allocatable :: delpf(:,:,:) - - real(r8), allocatable :: u0 (:,:,:), v0 (:,:,:) - real(r8), allocatable :: ubar (:,:,:), vbar (:,:,:) - real(r8), allocatable :: dupg (:,:,:), dvpg (:,:,:) - real(r8), allocatable :: duad (:,:,:), dvad (:,:,:) - - real(r8), allocatable :: ud_yz(:,:,:), vd_yz(:,:,:) - real(r8), allocatable :: ua_yz(:,:,:), va_yz(:,:,:) - real(r8), allocatable :: uc_yz(:,:,:), vc_yz(:,:,:) - - real(r8), allocatable :: dwz(:,:,:), pkc(:,:,:), wz(:,:,:) - real(r8), allocatable :: dpt(:,:,:) - real(r8), allocatable :: pkcc(:,:,:), wzc(:,:,:) - real(r8), allocatable :: tmp2(:,:,:) - -! The following variables are work arrays for xy=>yz transpose - real(r8), allocatable :: pkkp(:,:,:), wzkp(:,:,:) - -! The following variables are xy instanciations - real(r8), allocatable :: tmpxy(:,:,:), dp0xy(:,:,:), wzxy(:,:,:) - real(r8), allocatable :: tmp3dfor2d(:,:,:) - real(r8), pointer :: pexy(:,:,:), psxy(:,:) - real(r8), pointer :: delpxy (:,:,:) - real(r8), pointer :: delpxy0(:,:,:) - - real(r8) dt - real(r8) bdt - real(r8) te0,te1 - - GRID => STATE%GRID ! For convenience - VARS => STATE%VARS ! For convenience - -! Initialize Budget Diagnostics -! ----------------------------- - convcpt = 0.0 - convthv = 0.0 - kenrg1 = 0.0 - penrg1 = 0.0 - tenrg1 = 0.0 - kenrg2 = 0.0 - penrg2 = 0.0 - tenrg2 = 0.0 - dkedtad = 0.0 - dkedtpg = 0.0 - dkedtdp = 0.0 - dkedtho = 0.0 - dthdtremap = 0.0 - dthdtconsv = 0.0 - -! -! Set the local variables which used to be imported from dynamics_vars -! - nsplit = STATE%NSPLIT - icd = STATE%icd - jcd = STATE%jcd - iord = STATE%iord - jord = STATE%jord - kord = STATE%kord - te_method= STATE%te_method - im = GRID%im - jm = GRID%jm - km = GRID%km - nq = GRID%nq - ntotq = GRID%nq - GRID%ntotq = ntotq - ng_s = GRID%ng_s - ng_c = GRID%ng_c - ng_d = GRID%ng_d - jfirst = GRID%jfirst - kfirst = GRID%kfirst - jlast = GRID%jlast - klast = GRID%klast - ifirstxy = GRID%ifirstxy - jfirstxy = GRID%jfirstxy - ilastxy = GRID%ilastxy - jlastxy = GRID%jlastxy - - ptop = GRID%ptop - rcap = GRID%rcap - - twod_decomp = GRID%twod_decomp - myid_z = GRID%myid_z - npr_y = GRID%npr_y - npr_z = GRID%npr_z - - js2gd = max( 2,jfirst-ng_d) ! NG latitudes on S (starting at 2 ) - jn2gd = min(jm-1,jlast +ng_d) ! NG latitudes on N (ending at jm-1) - -! -! Allocate the YZ decomposed control variables -! (adapted from prognostics.F90) -! - klastp = klast+1 - ndt = nint( state%dt ) ! IS THIS CORRECT??? - - allocate( delpxy0(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - allocate( delpxy (ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - allocate( pexy(ifirstxy:ilastxy,km+1,jfirstxy:jlastxy) ) - allocate( psxy(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - - allocate( ua(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - allocate( va(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - - allocate( u(im,jfirst-ng_d:jlast+ng_s,kfirst:klast ) ) - allocate( v(im,jfirst-ng_s:jlast+ng_d,kfirst:klast ) ) - allocate( pt(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( dum(im,jfirst :jlast ,kfirst:klast ) ) - allocate( pk(im,jfirst :jlast ,kfirst:klast+1) ) - allocate( pke(im,kfirst:klast+1,jfirst:jlast) ) - - allocate( cosp(im,jfirst:jlast ) ) - allocate(oma_yz(im,jfirst:jlast,kfirst:klast ) ) - allocate(cpt_yz(im,jfirst:jlast,kfirst:klast ) ) - allocate(thv_yz(im,jfirst:jlast,kfirst:klast ) ) - - allocate( thvx(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( thvy(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( difx(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( dify(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( pbrx(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( pbry(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( facx(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( facy(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( dpdx(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( dpdy(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( pkz (im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( pkz0(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( pkzb(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( thdp (im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( thdp0(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) - allocate( thdpb(im,jfirst-ng_d:jlast+ng_d,kfirst:klast ) ) -! -! Allocation of tracers -! - allocate( q_internal(nq) ) ! WAS: q3 - -! -! Other arrays -! - allocate( delp (im, jfirst:jlast, kfirst:klast) ) - allocate( delp0(im, jfirst:jlast, kfirst:klast) ) - allocate( delpd(im, jfirst:jlast, kfirst:klast) ) - -! -! Determine surface pressure (PS) and pressure difference (DELP) -! -!$omp parallel do private(i,j) - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - psxy(i,j) = vars%pe(i,j,km+1) - enddo - enddo - -! -! Define local arrays derived from the edge pressure -! - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - delpxy (i,j,k) = vars%pe(i,j,k+1) - vars%pe(i,j,k) - delpxy0(i,j,k) = delpxy (i,j,k) - pexy (i,k,j) = vars%pe(i,j,k) - pelnxz (i,k,j) = log(vars%pe(i,j,k)) - enddo - enddo - enddo - -! Clean up loop for level km+1 - -!$omp parallel do private(i,j) - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - pexy (i,km+1,j) = vars%pe(i,j,km+1) - pelnxz(i,km+1,j) = log(vars%pe(i,j,km+1)) - enddo - enddo - - if (twod_decomp == 1) then ! true 2D decomposition --> transpose - - allocate( phis(im, jfirst:jlast ) ) - allocate( pe(im,kfirst:klastp,jfirst:jlast) ) - -! -! Transpose phisxy to phis (special 2D case) -! - allocate( tmp3dfor2d(ifirstxy:ilastxy,jfirstxy:jlastxy,npr_z) ) - - do k=1,npr_z - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - tmp3dfor2d(i,j,k) = phisxy(i,j) - enddo - enddo - enddo - call mp_swapirr( commglobal, grid%xy2d_to_yz2d%SendDesc, & - grid%xy2d_to_yz2d%RecvDesc, tmp3dfor2d, phis ) - - do k=1,npr_z - do j=MAX(2,jfirstxy),MIN(jlastxy,jm-1) - tmp3dfor2d(:,j,k) = grid%cosp(j) - enddo - if ( jfirstxy == 1 ) tmp3dfor2d(:,jfirstxy,k) = 0.0 - if ( jlastxy == jm ) tmp3dfor2d(:,jlastxy, k) = 0.0 - enddo - call mp_swapirr( commglobal, grid%xy2d_to_yz2d%SendDesc, & - grid%xy2d_to_yz2d%RecvDesc, tmp3dfor2d, cosp ) - - deallocate(tmp3dfor2d) - - call mp_swapirr( commglobal, grid%ijk_xy_to_yz%SendDesc, & - grid%ijk_xy_to_yz%RecvDesc, delpxy, delp ) - -! -! State control variables first have to be transposed from XY to YZ -! - call mp_swapirr( commglobal, grid%uxy_to_u%SendDesc, & - grid%uxy_to_u%RecvDesc, vars%u, u ) - - call mp_swapirr( commglobal, grid%vxy_to_v%SendDesc, & - grid%vxy_to_v%RecvDesc, vars%v, v ) - - call mp_swapirr( commglobal, grid%ptxy_to_pt%SendDesc, & - grid%ptxy_to_pt%RecvDesc, vars%pt, pt, & - a2in = vars%pkz, a2out = pkz ) - - call mp_swapirr( commglobal, grid%pexy_to_pe%SendDesc, & - grid%pexy_to_pe%RecvDesc, pexy, pe ) - -! -! Allocate internal tracers -! - do mq = 1, nq - q_internal(mq)%is_r4 = vars%tracer(mq)%is_r4 - if ( vars%tracer(mq)%is_r4 ) then - allocate( q_internal(mq)%content_r4(im,jfirst:jlast,kfirst:klast) ) -! mp_swapirr_r4 not yet available - call mp_swapirr_r4( commglobal, grid%r4_xy_to_yz%SendDesc, & - grid%r4_xy_to_yz%RecvDesc, & - vars%tracer(mq)%content_r4, & - q_internal(mq)%content_r4 ) - else - allocate( q_internal(mq)%content(im,jfirst:jlast,kfirst:klast) ) - call mp_swapirr( commglobal, grid%ijk_xy_to_yz%SendDesc, & - grid%ijk_xy_to_yz%RecvDesc, & - vars%tracer(mq)%content, & - q_internal(mq)%content ) - endif - enddo - - else ! 1D decomposition --> arrays can be copied - -! -! In this case: kfirst=1, klast=km, ifirstxy=1 ilastxy=im -! jfirst=jfirstxy, jlast=jlastxy - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst,jlast - do i=1,im - u(i,j,k) = vars%u (i,j,k) - v(i,j,k) = vars%v (i,j,k) - pt(i,j,k) = vars%pt (i,j,k) - pkz(i,j,k) = vars%pkz(i,j,k) - delp(i,j,k) = delpxy(i,j,k) - enddo - enddo - enddo - -!$omp parallel do private(i,j,k,mq) - do mq = 1, nq - q_internal(mq)%is_r4 = vars%tracer(mq)%is_r4 - if ( vars%tracer(mq)%is_r4 ) then - q_internal(mq)%content_r4 => vars%tracer(mq)%content_r4 - else - q_internal(mq)%content => vars%tracer(mq)%content - endif - enddo - -! PHIS, PE can point directly to their XY equivalents in this case - phis => phisxy - pe => pexy - - do j=MAX(2,jfirstxy),MIN(jlastxy,jm-1) - cosp(:,j) = grid%cosp(j) - enddo - if ( jfirstxy == 1 ) cosp(:,jfirstxy) = 0.0 - if ( jlastxy == jm ) cosp(:,jlastxy ) = 0.0 - - endif - - -! Allocate temporary work arrays -! Change later to use pointers for SMP performance??? -! (prime candidates: uc, vc, delpf) - - allocate( worka(im,jfirst: jlast, kfirst:klast) ) - allocate( dp0(im,jfirst: jlast, kfirst:klast) ) - allocate( ptfx(im,jfirst: jlast, kfirst:klast) ) - allocate( ptfy(im,jfirst: jlast+1, kfirst:klast) ) - allocate(ptfx_accum(im,jfirst: jlast, kfirst:klast) ) - allocate(ptfy_accum(im,jfirst: jlast+1, kfirst:klast) ) - allocate( mfx(im,jfirst: jlast, kfirst:klast) ) - allocate( mfy(im,jfirst: jlast+1, kfirst:klast) ) - allocate( mfx_accum(im,jfirst: jlast, kfirst:klast) ) - allocate( mfy_accum(im,jfirst: jlast+1, kfirst:klast) ) - allocate( cx(im,jfirst-ng_d:jlast+ng_d,kfirst:klast) ) - allocate( cy(im,jfirst: jlast+1, kfirst:klast) ) - allocate( cx_accum(im,jfirst: jlast ,kfirst:klast) ) - allocate( cy_accum(im,jfirst: jlast ,kfirst:klast) ) - allocate( delpf(im,jfirst-ng_d:jlast+ng_d,kfirst:klast) ) - allocate( dpt(im,jfirst-1: jlast+1, kfirst:klast) ) - allocate( dwz(im,jfirst-1: jlast, kfirst:klast+1) ) - allocate( pkc(im,jfirst-1: jlast+1, kfirst:klast+1) ) - allocate( wz(im,jfirst-1: jlast+1, kfirst:klast+1) ) - allocate( pkcc(im,jfirst : jlast , kfirst:klast+1) ) - allocate( wzc(im,jfirst : jlast , kfirst:klast+1) ) - allocate( pkkp(im,jfirst:jlast,kfirst:klast+1)) - allocate( wzkp(im,jfirst:jlast,kfirst:klast+1)) - - allocate( wzxy(ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - allocate( tmpxy(ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - allocate( dp0xy(ifirstxy:ilastxy,jfirstxy:jlastxy,km ) ) - - allocate( gze (ifirstxy:ilastxy,jfirstxy:jlastxy,km+1) ) - allocate( phi (ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - allocate( del_PHI (ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - allocate( del_KE (ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - allocate( tot_PHI (ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - allocate( tot_KE (ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - allocate( tv (ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - - allocate( u0 (im,jfirst-ng_d:jlast+ng_s,kfirst:klast) ) - allocate( v0 (im,jfirst-ng_s:jlast+ng_d,kfirst:klast) ) - allocate( ubar (im,jfirst-ng_d:jlast+ng_s,kfirst:klast) ) - allocate( vbar (im,jfirst-ng_s:jlast+ng_d,kfirst:klast) ) - allocate( dupg (im,jfirst-ng_d:jlast+ng_s,kfirst:klast) ) - allocate( dvpg (im,jfirst-ng_s:jlast+ng_d,kfirst:klast) ) - allocate( duad (im,jfirst-ng_d:jlast+ng_s,kfirst:klast) ) - allocate( dvad (im,jfirst-ng_s:jlast+ng_d,kfirst:klast) ) - - allocate( ud_yz(im,jfirst-ng_d:jlast+ng_s,kfirst:klast) ) - allocate( vd_yz(im,jfirst-ng_s:jlast+ng_d,kfirst:klast) ) - allocate( ua_yz(im,jfirst-ng_d:jlast+ng_d,kfirst:klast) ) - allocate( va_yz(im,jfirst-ng_s:jlast+ng_d,kfirst:klast) ) - allocate( uc_yz(im,jfirst-ng_d:jlast+ng_d,kfirst:klast) ) - allocate( vc_yz(im,jfirst-2: jlast+2, kfirst:klast) ) - - allocate( dkedt_ho_yz(im,jfirst:jlast,kfirst:klast) ) - allocate( dkedt_dp_yz(im,jfirst:jlast,kfirst:klast) ) - allocate( dkedt_pg_yz(im,jfirst:jlast,kfirst:klast) ) - allocate( dkedt_ad_yz(im,jfirst:jlast,kfirst:klast) ) - allocate( dkedt_xy (ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - allocate( dkedt (ifirstxy:ilastxy,jfirstxy:jlastxy) ) - allocate( dthdtremap1(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - allocate( dthdtremap2(ifirstxy:ilastxy,jfirstxy:jlastxy) ) - allocate( dthconsv (ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - -! Initialize Budget Tracer Variables -! ---------------------------------- - BUDGETS = ( NPHI.ne.-999 ) .and. ( NKE.ne.-999 ) - if ( BUDGETS ) then - if ( vars%tracer(NPHI)%is_r4 ) then - tot_PHI = vars%tracer(NPHI)%content_r4 * delpxy - else - tot_PHI = vars%tracer(NPHI)%content * delpxy - endif - del_PHI = tot_PHI - - if ( vars%tracer(NKE )%is_r4 ) then - tot_KE = vars%tracer(NKE )%content_r4 * delpxy - else - tot_KE = vars%tracer(NKE )%content * delpxy - endif - del_KE = tot_KE - endif - - do k=kfirst,klast - do j=jfirst,jlast - pkz0(:,j,k) = pkz(:,j,k) - thdp0(:,j,k) = pt(:,j,k)*delp(:,j,k) - delp0(:,j,k) = delp(:,j,k) - u0(:,j,k) = u(:,j,k) - v0(:,j,k) = v(:,j,k) - enddo - enddo - -! --------------------------------------------------- - -! First touch pkc and wz??? (bufferpack is multitask in vertical but geop -! computations are parallel in j-loop) - - if ( km > 1 ) then ! not shallow water equations - - if( consv ) then -! Compute globally integrated Total Energy (te0) - -! WS: 2006.05.05 This section now in synch with last GFDL code -! NOTE: new benergy takes temperature as input - call FVstartclock(grid,"--BENERGY") - qqq2 = qqq - call benergy(grid, vars%u, vars%v, txy, delpxy, & - qqq, vars%pe, pelnxz, phisxy, & - eps, cp, rgas, tte, te0 ) - call FVstopclock(grid,"--BENERGY") - endif - - endif - -! Construct 1 Single Outer Loop for Dynamics and Advection -! -------------------------------------------------------- - bdt = ndt - dt = bdt / float(nsplit) - - if( nq > 0 ) then - -!$omp parallel do private(i, j, k) - do k=kfirst,klast - do j=jfirst,jlast - do i=1,im - ptfx_accum(i,j,k) = 0. - mfx_accum(i,j,k) = 0. - cx_accum(i,j,k) = 0. - cy_accum(i,j,k) = 0. - enddo - enddo - do j=jfirst,jlast+1 - do i=1,im - ptfy_accum(i,j,k) = 0. - mfy_accum(i,j,k) = 0. - enddo - enddo - enddo - - endif - - oma_yz = 0.0 - cpt_yz = 0.0 - thv_yz = 0.0 - - do 2000 n=1, nsplit - - if( nq > 0 ) then - -!$omp parallel do private(i, j, k) - do k=kfirst,klast - do j=jfirst,jlast - do i=1,im -! Save initial delp field before the small-time-step -! Initialize the CFL number accumulators: (cx, cy) -! Initialize total mass fluxes: (mfx, mfy) - dp0(i,j,k) = delp(i,j,k) - cx(i,j,k) = 0. - cy(i,j,k) = 0. - mfx(i,j,k) = 0. - enddo - enddo - do j=jfirst,jlast+1 - do i=1,im - mfy(i,j,k) = 0. - enddo - enddo - enddo - - endif - - ptfx = 0. - ptfy = 0. - -! Force Updates of pexy every timestep -! ------------------------------------ - ipe = 1 - -! Call the Lagrangian dynamical core using small time step -! -------------------------------------------------------- - call FVstartclock(grid,"--CDCORE") - - call cd_core(grid, nx, u, v, pt, & - delp, pe, pk, ipe, dt, & - ptop, umax, pi, radius, cp, & - kappa, icd, jcd, iord, jord, & - ipe, omega, phis, cx, cy, & - mfx, mfy, ptfx, ptfy, & - delpf, uc_yz, vc_yz, & - ubar, vbar, duad, dvad, dupg, dvpg, & - dum, dpt, worka, dwz, pkc, & - wz, phisxy, vars%pt, pkxy, pexy, & - pkcc, wzc, wzxy, delpxy, pkkp, wzkp ) - - call FVstopclock(grid,"--CDCORE") - -! --------------------------------------------------------- -! Compute Omega*Alpha -! --------------------------------------------------------- - -! Remove TimeStep from TH*DelP fluxes -! ----------------------------------- - call FVstartclock(grid,"--OMEGA") - ptfx = ptfx/dt - ptfy = ptfy/dt - -! Load TH and PE**Kappa (A-Grid) -! ------------------------------ - if (twod_decomp == 1) then - call mp_swapirr( commglobal, grid%ptxy_to_pt%SendDesc, & - grid%ptxy_to_pt%RecvDesc, vars%pt, pt ) - call mp_swapirr( commglobal, grid%pexy_to_pe%SendDesc, & - grid%pexy_to_pe%RecvDesc, pexy, pe ) - else - pe => pexy - do k=kfirst,klast - do j=jfirst,jlast - do i=1,im - pt(i,j,k) = vars%pt(i,j,k) - enddo - enddo - enddo - endif - pke = pe**kappa - -! Compute TH*DelP and P**Kappa (A-Grid) -! ------------------------------------- - do k=kfirst,klast - do j=jfirst,jlast - do i=1,im - pkz(i,j,k) = ( pke(i,k+1,j)-pke(i,k,j) ) / ( kappa * log(pe(i,k+1,j)/pe(i,k,j)) ) - thdp(i,j,k) = pt(i,j,k)*delp(i,j,k) - enddo - enddo - enddo - -! Compute Time-Averaged TH*DelP and P**Kappa (A-Grid) -! --------------------------------------------------- - do k=kfirst,klast - do j=jfirst,jlast - do i=1,im - pkzb(i,j,k) = 0.5_r8*( pkz0(i,j,k) + pkz (i,j,k) ) - thdpb(i,j,k) = 0.5_r8*( thdp0(i,j,k) + thdp(i,j,k) ) - enddo - enddo - enddo - -! Compute PTFX*D(PK)/Dx and PTFY*D(PK)/Dy at C-Grid Locations -! ----------------------------------------------------------- - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, pkzb ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, pkzb ) - do k=kfirst,klast - do j=jfirst,jlast - im1=im - do i=1,im - dpdx(i,j,k) = ptfx(i,j,k)*( pkzb(i,j,k)-pkzb(im1,j,k) ) - pbrx(i,j,k) = ptfx(i,j,k)*( pkzb(i,j,k)+pkzb(im1,j,k) )*0.5_r8 - im1=i - enddo - enddo - do j=max(2,jfirst),jlast - do i=1,im - dpdy(i,j,k) = ptfy(i,j,k)*( pkzb(i,j,k)-pkzb(i,j-1,k) ) - pbry(i,j,k) = ptfy(i,j,k)*( pkzb(i,j,k)+pkzb(i,j-1,k) )*0.5_r8 - enddo - enddo - enddo - -! Average Above C-Grid Quantities back to A-Grid Locations (Away from Poles) -! -------------------------------------------------------------------------- - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, dpdy ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, dpdy ) - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, pbry ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, pbry ) - - do k=kfirst,klast - do j=jfirst,jlast - i=im - do ip1=1,im - facx(i,j,k) = 0.5_r8*( dpdx(ip1,j,k)+dpdx(i,j,k) ) - i=ip1 - enddo - enddo - do j=max(2,jfirst),min(jm-1,jlast) - do i=1,im - facy(i,j,k) = 0.5_r8*( dpdy(i,j+1,k)+dpdy(i,j,k) ) - enddo - enddo - enddo - -! Compute Omega*Alpha*DelP at A-Grid Locations (Away from Poles) -! -------------------------------------------------------------- - if ( jfirst == 1 ) then - jpole = 1 - jstar = 2 - msgn = 1 - endif - if ( jlast == jm ) then - jpole = jm - jstar = jm - msgn = -1 - endif - - do k=kfirst,klast - do j=max(2,jfirst),min(jm-1,jlast) - do i=1,im - oma_yz(i,j,k) = oma_yz(i,j,k) + cp*( thdpb(i,j,k)*( pkz(i,j,k)-pkz0(i,j,k) )/dt + facx(i,j,k) + facy(i,j,k)/cosp(i,j) ) - enddo - enddo - -! Poles -! ----- - if ( jfirst == 1 .or. jlast == jm ) then - sump = 0.0_r8 - do i=1,im - sump = sump + thdpb(i,jpole,k)*( pkz(i,jpole,k)-pkz0(i,jpole,k) ) - enddo - sump = sump / (dt*im) - do i=1,im - oma_yz(i,jpole,k) = oma_yz(i,jpole,k) + cp*sump - enddo - sump = 0.0_r8 - do i=1,im - sump = sump + pbry(i,jstar,k) - pkzb(i,jpole,k)*ptfy(i,jstar,k) - enddo - sump = msgn*sump*rcap - do i=1,im - oma_yz(i,jpole,k) = oma_yz(i,jpole,k) + cp*sump - enddo - endif - - enddo ! End K-Loop - call FVstopclock(grid,"--OMEGA") - -! --------------------------------------------------------- -! Compute Energy Budgets -! --------------------------------------------------------- - - call FVstartclock(grid,"--BUDGETS") - if( BUDGETS ) then - - do k=kfirst,klast - do j=jfirst,jlast - i=im - do ip1=1,im - difx(i,j,k) = ( pbrx(ip1,j,k)-pbrx(i,j,k) ) - thvx(i,j,k) = ( ptfx(ip1,j,k)-ptfx(i,j,k) ) - i=ip1 - enddo - enddo - do j=max(2,jfirst),min(jm-1,jlast) - do i=1,im - dify(i,j,k) = ( pbry(i,j+1,k)-pbry(i,j,k) ) - thvy(i,j,k) = ( ptfy(i,j+1,k)-ptfy(i,j,k) ) - enddo - enddo - enddo - -! Compute Budget Diagnostics at A-Grid Locations (Away from Poles) -! ---------------------------------------------------------------- - if ( jfirst == 1 ) then - jpole = 1 - jstar = 2 - msgn = 1 - endif - if ( jlast == jm ) then - jpole = jm - jstar = jm - msgn = -1 - endif - - do k=kfirst,klast - do j=max(2,jfirst),min(jm-1,jlast) - do i=1,im - cpt_yz(i,j,k) = cpt_yz(i,j,k) - cp*( difx(i,j,k) + dify(i,j,k)/cosp(i,j) ) - thv_yz(i,j,k) = thv_yz(i,j,k) - ( thvx(i,j,k) + thvy(i,j,k)/cosp(i,j) ) - enddo - enddo - -! Poles -! ----- - if ( jfirst == 1 .or. jlast == jm ) then - sump = 0.0_r8 - do i=1,im - sump = sump + pbry(i,jstar,k) - enddo - sump = msgn*sump*rcap - do i=1,im - cpt_yz(i,jpole,k) = cpt_yz(i,jpole,k) - cp*sump - enddo - - sump = 0.0_r8 - do i=1,im - sump = sump + ptfy(i,jstar,k) - enddo - sump = msgn*sump*rcap - do i=1,im - thv_yz(i,jpole,k) = thv_yz(i,jpole,k) - sump - enddo - endif - - enddo ! End K-Loop - -! --------------------------------------------------------- -! Compute Component Energetics Tendencies Across CD_CORE -! --------------------------------------------------------- - - delpd = delp - delp0 - -! Pressure-Gradient Component -! --------------------------- - do j=max(2,jfirst),jlast ; ud_yz(:,j,:) = u0(:,j,:)*dupg(:,j,:) ; enddo - do j=max(2,jfirst),min(jm-1,jlast) ; vd_yz(:,j,:) = v0(:,j,:)*dvpg(:,j,:) ; enddo - - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, ud_yz ) - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, vd_yz ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, ud_yz ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, vd_yz ) - do k=kfirst,klast - call d2a2c_winds(grid, ud_yz(1,jfirst-ng_d,k), vd_yz(1,jfirst-ng_s,k), & - ua_yz(1,jfirst-ng_d,k), va_yz(1,jfirst-ng_s,k), & - uc_yz(1,jfirst-ng_d,k), vc_yz(1,jfirst-2 ,k), & - .false., uc_yz(1,jfirst-ng_d,k), vc_yz(1,jfirst-2 ,k)) - enddo - if ( jfirst == 1 ) then - jpole = 1 - jstar = 2 - ua_yz(:,jpole,:) = 2.0_r8 * ud_yz(:,jstar,:) - va_yz(:,jpole,:) = 2.0_r8 * vd_yz(:,jstar,:) - endif - if ( jlast == jm ) then - jpole = jm - jstar = jm-1 - ua_yz(:,jpole,:) = 2.0_r8 * ud_yz(:,jpole,:) - va_yz(:,jpole,:) = 2.0_r8 * vd_yz(:,jstar,:) - endif - dkedt_pg_yz(:,jfirst:jlast,:) = 0.5_r8 *( ua_yz(:,jfirst:jlast,:) + va_yz(:,jfirst:jlast,:) )*delp(:,jfirst:jlast,:) - -! Advective (Inertial) Component -! ------------------------------ - do j=max(2,jfirst),jlast ; ud_yz(:,j,:) = u0(:,j,:)*duad(:,j,:) ; enddo - do j=max(2,jfirst),min(jm-1,jlast) ; vd_yz(:,j,:) = v0(:,j,:)*dvad(:,j,:) ; enddo - - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, ud_yz ) - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, vd_yz ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, ud_yz ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, vd_yz ) - do k=kfirst,klast - call d2a2c_winds(grid, ud_yz(1,jfirst-ng_d,k), vd_yz(1,jfirst-ng_s,k), & - ua_yz(1,jfirst-ng_d,k), va_yz(1,jfirst-ng_s,k), & - uc_yz(1,jfirst-ng_d,k), vc_yz(1,jfirst-2 ,k), & - .false., uc_yz(1,jfirst-ng_d,k), vc_yz(1,jfirst-2 ,k)) - enddo - if ( jfirst == 1 ) then - jpole = 1 - jstar = 2 - ua_yz(:,jpole,:) = 2.0_r8 * ud_yz(:,jstar,:) - va_yz(:,jpole,:) = 2.0_r8 * vd_yz(:,jstar,:) - endif - if ( jlast == jm ) then - jpole = jm - jstar = jm-1 - ua_yz(:,jpole,:) = 2.0_r8 * ud_yz(:,jpole,:) - va_yz(:,jpole,:) = 2.0_r8 * vd_yz(:,jstar,:) - endif - dkedt_ad_yz(:,jfirst:jlast,:) = 0.5_r8 *( ua_yz(:,jfirst:jlast,:) + va_yz(:,jfirst:jlast,:) )*delp(:,jfirst:jlast,:) - -! Mean Wind Component -! ------------------- - do j=max(2,jfirst),jlast ; ud_yz(:,j,:) = 0.5_r8*u0(:,j,:)*u0(:,j,:) ; enddo - do j=max(2,jfirst),min(jm-1,jlast) ; vd_yz(:,j,:) = 0.5_r8*v0(:,j,:)*v0(:,j,:) ; enddo - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, ud_yz ) - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, vd_yz ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, ud_yz ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, vd_yz ) - do k=kfirst,klast - call d2a2c_winds(grid, ud_yz(1,jfirst-ng_d,k), vd_yz(1,jfirst-ng_s,k), & - ua_yz(1,jfirst-ng_d,k), va_yz(1,jfirst-ng_s,k), & - uc_yz(1,jfirst-ng_d,k), vc_yz(1,jfirst-2 ,k), & - .false., uc_yz(1,jfirst-ng_d,k), vc_yz(1,jfirst-2 ,k)) - enddo - if ( jfirst == 1 ) then - jpole = 1 - jstar = 2 - ua_yz(:,jpole,:) = 2.0_r8 * ud_yz(:,jstar,:) - va_yz(:,jpole,:) = 2.0_r8 * vd_yz(:,jstar,:) - endif - if ( jlast == jm ) then - jpole = jm - jstar = jm-1 - ua_yz(:,jpole,:) = 2.0_r8 * ud_yz(:,jpole,:) - va_yz(:,jpole,:) = 2.0_r8 * vd_yz(:,jstar,:) - endif - dkedt_dp_yz(:,jfirst:jlast,:) = 0.5_r8 *( ua_yz(:,jfirst:jlast,:) + va_yz(:,jfirst:jlast,:) )*delpd(:,jfirst:jlast,:) - -! Higher-Order Terms -! ------------------ - do j=max(2,jfirst),jlast ; ud_yz(:,j,:) = 0.5_r8*( dupg(:,j,:)+duad(:,j,:) )**2 ; enddo - do j=max(2,jfirst),min(jm-1,jlast) ; vd_yz(:,j,:) = 0.5_r8*( dvpg(:,j,:)+dvad(:,j,:) )**2 ; enddo - - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, ud_yz ) - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, vd_yz ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, ud_yz ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, vd_yz ) - do k=kfirst,klast - call d2a2c_winds(grid, ud_yz(1,jfirst-ng_d,k), vd_yz(1,jfirst-ng_s,k), & - ua_yz(1,jfirst-ng_d,k), va_yz(1,jfirst-ng_s,k), & - uc_yz(1,jfirst-ng_d,k), vc_yz(1,jfirst-2 ,k), & - .false., uc_yz(1,jfirst-ng_d,k), vc_yz(1,jfirst-2 ,k)) - enddo - if ( jfirst == 1 ) then - jpole = 1 - jstar = 2 - ua_yz(:,jpole,:) = 2.0_r8 * ud_yz(:,jstar,:) - va_yz(:,jpole,:) = 2.0_r8 * vd_yz(:,jstar,:) - endif - if ( jlast == jm ) then - jpole = jm - jstar = jm-1 - ua_yz(:,jpole,:) = 2.0_r8 * ud_yz(:,jpole,:) - va_yz(:,jpole,:) = 2.0_r8 * vd_yz(:,jstar,:) - endif - dkedt_ho_yz(:,jfirst:jlast,:) = 0.5_r8 *( ua_yz(:,jfirst:jlast,:) + va_yz(:,jfirst:jlast,:) )*delp(:,jfirst:jlast,:) - -! Pole Values -! ----------- - if ( jfirst == 1 .or. jlast == jm ) then - if ( jfirst == 1 ) then - jpole = 1 - jstar = 2 - endif - if ( jlast == jm ) then - jpole = jm - jstar = jm-1 - endif -! j = jstar - j = jpole - do k=kfirst,klast - sumho = 0.0_r8 - sumdp = 0.0_r8 - sumpg = 0.0_r8 - sumad = 0.0_r8 - do i=1,im - sumho = sumho + dkedt_ho_yz(i,j,k) - sumdp = sumdp + dkedt_dp_yz(i,j,k) - sumpg = sumpg + dkedt_pg_yz(i,j,k) - sumad = sumad + dkedt_ad_yz(i,j,k) - enddo - sumho = sumho /im - sumdp = sumdp /im - sumpg = sumpg /im - sumad = sumad /im - do i=1,im - dkedt_ho_yz(i,j,k) = sumho - dkedt_dp_yz(i,j,k) = sumdp - dkedt_pg_yz(i,j,k) = sumpg - dkedt_ad_yz(i,j,k) = sumad - enddo - enddo - endif - - endif ! End BUDGETS Test - call FVstopclock(grid,"--BUDGETS") - - -! Reset Initial Values -! -------------------- - do k=kfirst,klast - do j=jfirst,jlast - u0(:,j,k) = u(:,j,k) - v0(:,j,k) = v(:,j,k) - pkz0(:,j,k) = pkz(:,j,k) - thdp0(:,j,k) = thdp(:,j,k) - delp0(:,j,k) = delp(:,j,k) - enddo - enddo - -! Accumulate Fluxes -! ----------------- - ptfx_accum(:,:,:) =ptfx_accum(:,:,:) +ptfx(:,:,:) - ptfy_accum(:,:,:) =ptfy_accum(:,:,:) +ptfy(:,:,:) - mfx_accum(:,:,:) = mfx_accum(:,:,:) + mfx(:,:,:) - mfy_accum(:,:,:) = mfy_accum(:,:,:) + mfy(:,:,:) - cx_accum(:,:,:) = cx_accum(:,:,:) + cx(:,jfirst:jlast,:) - cy_accum(:,:,:) = cy_accum(:,:,:) + cy(:,jfirst:jlast,:) - - -! Perform small-time-step scalar transport using instantaneous CFL and mass fluxes -! -------------------------------------------------------------------------------- - if( nq .ne. 0 ) then - call FVstartclock(grid,"--TRAC2D") - call trac2d( grid, dp0, q_internal, cx, cy, & - mfx, mfy, STATE%iord, STATE%jord, fill, & - dum, worka ) - call FVstopclock(grid,"--TRAC2D") - endif - - -! Recover BUDGET Tracer Variables into xy-Decomposition -! ----------------------------------------------------- - call FVstartclock(grid,"--BUDGETS") - if ( BUDGETS ) then - if ( twod_decomp == 1 ) then - do mq = 1, nq - if( mq.eq.NPHI .or. mq.eq.NKE ) then - if ( vars%tracer(mq)%is_r4 ) then -! mp_swapirr_r4 not yet available - call mp_swapirr_r4(commglobal, grid%r4_yz_to_xy%SendDesc, & - grid%r4_yz_to_xy%RecvDesc, & - q_internal(mq)%content_r4, & - vars%tracer(mq)%content_r4 ) - else - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, & - q_internal(mq)%content, & - vars%tracer(mq)%content ) - endif - endif - enddo - else - do mq = 1, nq - if( mq.eq.NPHI .or. mq.eq.NKE ) then - if ( vars%tracer(mq)%is_r4 ) then - vars%tracer(mq)%content_r4 => q_internal(mq)%content_r4 - else - vars%tracer(mq)%content => q_internal(mq)%content - endif - endif - enddo - endif - -! Compute and Accumulate Budget Tracer Variable Tendencies -! -------------------------------------------------------- - if ( vars%tracer(NPHI)%is_r4 ) then - del_PHI = ( vars%tracer(NPHI)%content_r4 * delpxy - del_PHI ) - else - del_PHI = ( vars%tracer(NPHI)%content * delpxy - del_PHI ) - endif - tot_PHI = tot_PHI + del_PHI - - if ( vars%tracer(NKE )%is_r4 ) then - del_KE = ( vars%tracer(NKE )%content_r4 * delpxy - del_KE ) - else - del_KE = ( vars%tracer(NKE )%content * delpxy - del_KE ) - endif - tot_KE = tot_KE + del_KE - -! Accumulate Kinetic Energy Tendencies across CD_CORE -! --------------------------------------------------- - if ( twod_decomp == 1 ) then - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, dkedt_ad_yz, dkedt_xy ) - else - dkedt_xy = dkedt_ad_yz - endif - dkedt = 0.0 - do k=1,km - dkedt = dkedt + dkedt_xy(:,:,k) - enddo - dkedt = dkedt / (grav*dt) - dkedtad = dkedtad + dkedt - - - if ( twod_decomp == 1 ) then - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, dkedt_pg_yz, dkedt_xy ) - else - dkedt_xy = dkedt_pg_yz - endif - dkedt = 0.0 - do k=1,km - dkedt = dkedt + dkedt_xy(:,:,k) - enddo - dkedt = dkedt / (grav*dt) - dkedtpg = dkedtpg + dkedt - - - if ( twod_decomp == 1 ) then - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, dkedt_dp_yz, dkedt_xy ) - else - dkedt_xy = dkedt_dp_yz - endif - dkedt = 0.0 - do k=1,km - dkedt = dkedt + dkedt_xy(:,:,k) - enddo - dkedt = dkedt / (grav*dt) - dkedtdp = dkedtdp + dkedt - - if ( twod_decomp == 1 ) then - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, dkedt_ho_yz, dkedt_xy ) - else - dkedt_xy = dkedt_ho_yz - endif - dkedt = 0.0 - do k=1,km - dkedt = dkedt + dkedt_xy(:,:,k) - enddo - dkedt = dkedt / (grav*dt) - dkedtho = dkedtho + dkedt - -! Update D-Grid Kinetic Energy for HOT -! ------------------------------------ - - do j=max(2,jfirst),jlast ; ud_yz(:,j,:) = u(:,j,:)*u(:,j,:) ; enddo - do j=max(2,jfirst),min(jm-1,jlast) ; vd_yz(:,j,:) = v(:,j,:)*v(:,j,:) ; enddo - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, ud_yz ) - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, vd_yz ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, ud_yz ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, vd_yz ) - do k=kfirst,klast - call d2a2c_winds(grid, ud_yz(1,jfirst-ng_d,k), vd_yz(1,jfirst-ng_s,k), & - ua_yz(1,jfirst-ng_d,k), va_yz(1,jfirst-ng_s,k), & - uc_yz(1,jfirst-ng_d,k), vc_yz(1,jfirst-2 ,k), & - .false., uc_yz(1,jfirst-ng_d,k), vc_yz(1,jfirst-2 ,k)) - enddo - if ( jfirst == 1 ) then - jpole = 1 - jstar = 2 - ua_yz(:,jpole,:) = 2.0_r8 * ud_yz(:,jstar,:) - va_yz(:,jpole,:) = 2.0_r8 * vd_yz(:,jstar,:) - endif - if ( jlast == jm ) then - jpole = jm - jstar = jm-1 - ua_yz(:,jpole,:) = 2.0_r8 * ud_yz(:,jpole,:) - va_yz(:,jpole,:) = 2.0_r8 * vd_yz(:,jstar,:) - endif - dkedt_pg_yz(:,jfirst:jlast,:) = 0.25_r8 *( ua_yz(:,jfirst:jlast,:) + va_yz(:,jfirst:jlast,:) ) - - if ( jfirst == 1 .or. jlast == jm ) then - if ( jfirst == 1 ) then - jpole = 1 - jstar = 2 - endif - if ( jlast == jm ) then - jpole = jm - jstar = jm-1 - endif - do k=kfirst,klast - sump = 0.0_r8 - do i=1,im -! sump = sump + dkedt_pg_yz(i,jstar,k) - sump = sump + dkedt_pg_yz(i,jpole,k) - enddo - sump = sump/im - do i=1,im - dkedt_pg_yz(i,jpole,k) = sump - enddo - enddo - endif - - if ( twod_decomp == 1 ) then - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, dkedt_pg_yz, dkedt_xy ) - else - dkedt_xy = dkedt_pg_yz - endif - -! Update Latest Values of BUDGET Tracer Variables -! ----------------------------------------------- - gze(:,:,km+1) = phisxy - do k=km,1,-1 - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - gze(i,j,k) = gze(i,j,k+1) + cp*vars%pt(i,j,k)*( pkxy(i,j,k+1)-pkxy(i,j,k) ) - tv(i,j,k) = vars%pt(i,j,k) * ( ( pkxy(i,j,k+1)-pkxy(i,j,k) )/( kappa * log(pexy(i,k+1,j)/pexy(i,k,j)) ) ) - phi(i,j,k) = ( gze(i,j,k+1)*pexy(i,k+1,j)-gze(i,j,k)*pexy(i,k,j) )/delpxy(i,j,k) + (1+kappa)*cp*tv(i,j,k) - enddo - enddo - enddo - -! Update Budget Tracer Variables with Latest Values -! ------------------------------------------------- - if ( vars%tracer(NPHI)%is_r4 ) then - vars%tracer(NPHI)%content_r4 = phi - else - vars%tracer(NPHI)%content = phi - endif - del_PHI = phi * delpxy - - if ( vars%tracer(NKE)%is_r4 ) then - vars%tracer(NKE)%content_r4 = dkedt_xy - else - vars%tracer(NKE)%content = dkedt_xy - endif - del_KE = dkedt_xy * delpxy - -! Transpose Updated BUDGET Tracer Variables into yz-Decomposition -! --------------------------------------------------------------- - if ( twod_decomp == 1 ) then - do mq = 1, nq - if( mq.eq.NPHI .or. mq.eq.NKE ) then - if ( vars%tracer(mq)%is_r4 ) then -! mp_swapirr_r4 not yet available - call mp_swapirr_r4( commglobal, grid%r4_xy_to_yz%SendDesc, & - grid%r4_xy_to_yz%RecvDesc, & - vars%tracer(mq)%content_r4, & - q_internal(mq)%content_r4 ) - else - call mp_swapirr( commglobal, grid%ijk_xy_to_yz%SendDesc, & - grid%ijk_xy_to_yz%RecvDesc, & - vars%tracer(mq)%content, & - q_internal(mq)%content ) - endif - endif - enddo - else - do mq = 1, nq - if( mq.eq.NPHI .or. mq.eq.NKE ) then - if ( vars%tracer(mq)%is_r4 ) then - q_internal (mq)%content_r4 => vars%tracer(mq)%content_r4 - else - q_internal (mq)%content => vars%tracer(mq)%content - endif - endif - enddo - endif - endif ! End BUDGET Test - call FVstopclock(grid,"--BUDGETS") - -2000 continue - -! Compute Average of Accumulated Variables -! ---------------------------------------- - cx_accum = cx_accum / nsplit - cy_accum = cy_accum / nsplit - oma_yz = oma_yz / nsplit - - call FVstartclock(grid,"--BUDGETS") - if( BUDGETS ) then - dkedtad = dkedtad / nsplit - dkedtpg = dkedtpg / nsplit - dkedtdp = dkedtdp / nsplit - dkedtho = dkedtho / nsplit - cpt_yz = cpt_yz / nsplit - thv_yz = thv_yz / nsplit - endif - call FVstopclock(grid,"--BUDGETS") - -! Transpose ps, u, v, and q from yz to xy decomposition -! ----------------------------------------------------- -! -! Note: pt, pe and pk will have already been transposed through -! call to geopk in cd_core. geopk does not actually require -! secondary xy decomposition; direct 16-byte technique works just -! as well, perhaps better. However, transpose method is used on last -! call to avoid having to compute these three transposes now. -! - - call FVstartclock(grid,"--TRANSPOSE_FWD") - if ( twod_decomp == 1 ) then - -! Transpose Omega*Alpha - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, oma_yz, oma_xy ) - -! Transpose Convergence of CpT, THv - if( BUDGETS ) then - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, cpt_yz, convcpt, & - a2in=thv_yz, a2out=convthv ) - endif - -! Transpose u, v - call mp_swapirr( commglobal, grid%u_to_uxy%SendDesc, & - grid%u_to_uxy%RecvDesc, u, vars%u ) - call mp_swapirr( commglobal, grid%v_to_vxy%SendDesc, & - grid%v_to_vxy%RecvDesc, v, vars%v ) - -! Transpose accumulated courant numbers cx, cy -!$omp parallel do private(i,j,k) - do k = kfirst,klast - do j = jfirst,jlast - do i = 1,im - cx_accum(i,j,k) = cx_accum(i,j,k) / grid%dtdx(j) - enddo - enddo - enddo -!$omp parallel do private(i,j,k) - do k = kfirst,klast - do j = jfirst,jlast - do i = 1,im - cy_accum(i,j,k) = cy_accum(i,j,k) / grid%dtdy - enddo - enddo - enddo - call mp_swapirr(commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, cx_accum, cxxyz, & - a2in=cy_accum, a2out=cyxyz ) - -! Transpose Tracers - do mq = 1, nq - if ( q_internal(mq)%is_r4 ) THEN -! mp_swapirr_r4 not yet available - call mp_swapirr_r4(commglobal, grid%r4_yz_to_xy%SendDesc, & - grid%r4_yz_to_xy%RecvDesc, & - q_internal(mq)%content_r4, & - vars%tracer(mq)%content_r4 ) - deallocate( q_internal(mq)%content_r4 ) - else - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, & - q_internal(mq)%content, & - vars%tracer(mq)%content ) - deallocate( q_internal(mq)%content ) - endif - enddo - -! Horizontal mass fluxes -!$omp parallel do private(i,j,k) - do k = kfirst,klast - do j = jfirst,jlast - do i = 1,im - worka(i,j,k) = mfx_accum(i,j,k) * (grid%dl*radius*grid%cosp(j)) * (radius*grid%dp) / ndt ! Pa m^2 / s - enddo - enddo - enddo - call mp_swapirr(commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, worka, mfxxyz) - -!$omp parallel do private(i,j,k) - do k = kfirst,klast - do j = jfirst,jlast - do i = 1,im - worka(i,j,k) = mfy_accum(i,j,k) * (radius*grid%dp) * (grid%dl*radius) / ndt ! Pa m^2 / s cos(lat) factor is removed - enddo - enddo - enddo - call mp_swapirr(commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, worka, mfyxyz) - -! Horizontal PT fluxes -!$omp parallel do private(i,j,k) - do k = kfirst,klast - do j = jfirst,jlast - do i = 1,im - worka(i,j,k) = ptfx_accum(i,j,k) * (grid%dl*radius*grid%cosp(j)) * (radius*grid%dp) / ndt ! K Pa m^2 / s - enddo - enddo - enddo - call mp_swapirr(commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, worka, ptfxxyz) - -!$omp parallel do private(i,j,k) - do k = kfirst,klast - do j = jfirst,jlast - do i = 1,im - worka(i,j,k) = ptfy_accum(i,j,k) * (radius*grid%dp) * (grid%dl*radius) / ndt ! K Pa m^2 / s cos(lat) factor is removed - enddo - enddo - enddo - call mp_swapirr(commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, worka, ptfyxyz) - - - else ! 1D decomposition --> arrays can be copied - -! -! In this case: kfirst=1, klast=km, ifirstxy=1 ilastxy=im -! jfirst=jfirstxy, jlast=jlastxy - - do k=1,km - do j=jfirst,jlast - do i=1,im - oma_xy(i,j,k) = oma_yz(i,j,k) - enddo - enddo - enddo - - if( BUDGETS ) then - do k=1,km - do j=jfirst,jlast - do i=1,im - convcpt(i,j,k) = cpt_yz(i,j,k) - convthv(i,j,k) = thv_yz(i,j,k) - enddo - enddo - enddo - endif - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst,jlast - do i=1,im - vars%u(i,j,k) = u(i,j,k) - vars%v(i,j,k) = v(i,j,k) - enddo - enddo - enddo - -! Horizontal accumulate C-grid winds -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst,jlast - do i=1,im - cxxyz(i,j,k) = cx_accum(i,j,k) / grid%dtdx(j) - enddo - enddo - do j=jfirst,jlast - do i=1,im - cyxyz(i,j,k) = cy_accum(i,j,k) / grid%dtdy - enddo - enddo - enddo - -!$omp parallel do private(i,j,k,mq) - do mq = 1, nq -! Copying pointers back is not strictly necessary - if ( vars%tracer(mq)%is_r4 ) then - vars%tracer(mq)%content_r4 => q_internal(mq)%content_r4 - else - vars%tracer(mq)%content => q_internal(mq)%content - endif - enddo - -! Horizontal mass and PT fluxes -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst,jlast - do i=1,im - mfxxyz(i,j,k) = mfx_accum(i,j,k) * (grid%dl*radius*grid%cosp(j)) * (radius*grid%dp) / ndt ! Pa m^2 / s - ptfxxyz(i,j,k) =ptfx_accum(i,j,k) * (grid%dl*radius*grid%cosp(j)) * (radius*grid%dp) / ndt ! K Pa m^2 / s - enddo - enddo - do j=jfirst,jlast - do i=1,im - mfyxyz(i,j,k) = mfy_accum(i,j,k) * (radius*grid%dp) * (grid%dl*radius) / ndt ! Pa m^2 / s cos(lat) factor is removed - ptfyxyz(i,j,k) =ptfy_accum(i,j,k) * (radius*grid%dp) * (grid%dl*radius) / ndt ! K Pa m^2 / s cos(lat) factor is removed - enddo - enddo - enddo - - endif ! twod_decomp == 0/1 - call FVstopclock(grid,"--TRANSPOSE_FWD") - -! Recover Total Update for Omega*Alpha and BUDGET Tracers -! ------------------------------------------------------- - - oma_xy = oma_xy / delpxy - - call FVstartclock(grid,"--BUDGETS") - if ( BUDGETS ) then - if ( vars%tracer(NPHI)%is_r4 ) then - vars%tracer(NPHI)%content_r4 = tot_PHI / delpxy - else - vars%tracer(NPHI)%content = tot_PHI / delpxy - endif - - if ( vars%tracer(NKE )%is_r4 ) then - vars%tracer(NKE )%content_r4 = tot_KE / delpxy - else - vars%tracer(NKE )%content = tot_KE / delpxy - endif - endif - call FVstopclock(grid,"--BUDGETS") - - -! Perform vertical remapping for non-shallow water model -! ------------------------------------------------------ - if ( km > 1 ) then - -! Perform vertical remapping from Lagrangian control-volume to -! the Eulerian coordinate as specified by the routine set_eta. -! Note that this finite-volume dycore is otherwise independent of the vertical -! Eulerian coordinate. - -! -! te_map requires uxy, vxy, psxy, pexy, pkxy, phisxy, q3xy, and ptxy -! -! Compute Energetics After CD-CORE and Before TE-MAP -! -------------------------------------------------- - call FVstartclock(grid,"--BUDGETS") - if( BUDGETS ) then - call Energetics (state,vars%u,vars%v,vars%pt,pexy,phisxy,kenrg1,penrg1,tenrg1) - dthdtremap1 = 0.0 - do k=1,km - dthdtremap1 = dthdtremap1 + vars%pt(:,:,k)*(pexy(:,k+1,:)-pexy(:,k,:)) - enddo - endif - call FVstopclock(grid,"--BUDGETS") - - mfxxyz_ur = mfxxyz - mfyxyz_ur = mfyxyz - call FVstartclock(grid,"--REMAP") - call te_map(grid, consv, convt, psxy, oma_xy, & - pexy, delpxy, vars%pkz, pkxy, ndt, & - nx, vars%u, vars%v, vars%pt, vars%tracer, & - phisxy, cp, kappa, kord, pelnxz, & - te0, tmpxy, dp0xy, mfxxyz, mfyxyz, te_method, dthconsv, dtmp ) - call FVstopclock(grid,"--REMAP") - -! Compute Energetics After TE-MAP -! ------------------------------- - call FVstartclock(grid,"--BUDGETS") - if( BUDGETS ) then - dthdtremap2 = 0.0 - do k=1,km - dthdtremap2 = dthdtremap2 + ( vars%pt(:,:,k)-dthconsv(:,:,k) )*(pexy(:,k+1,:)-pexy(:,k,:)) - enddo - dthdtremap = (dthdtremap2-dthdtremap1) * P00**KAPPA / (GRAV*NDT) - - dthdtconsv = 0.0 - do k=1,km - dthdtconsv = dthdtconsv + dthconsv(:,:,k)*(pexy(:,k+1,:)-pexy(:,k,:)) - enddo - dthdtconsv = dthdtconsv * P00**KAPPA / (GRAV*NDT) - call Energetics (state,vars%u,vars%v,vars%pt,pexy,phisxy,kenrg2,penrg2,tenrg2) - endif - call FVstopclock(grid,"--BUDGETS") - - endif - - -! Compute Ertel's potential vorticity -! ----------------------------------- - call FVstartclock(grid,"--EPVD") - call epvd( grid, vars%u, vars%v, vars%pt, delpxy, grav, radius, omega, epvxyz ) - -! Compute vertical mass flux -! ----------------------------------- - call mfz_comp( grid, radius, grav, ndt, mfxxyz, mfyxyz, mfzxyz, delpxy0, delpxy ) - call FVstopclock(grid,"--EPVD") - -! -! Finally, store pexy (IKJ indexing) back into vars%pe (IJK) -! - do k=1,km+1 - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - vars%pe(i,j,k) = pexy(i,k,j) - enddo - enddo - enddo - -#if 0 - allocate( tmp2(ifirstxy:ilastxy,jfirstxy:jlastxy,km) ) - if( vars%tracer(1)%is_r4 ) then - qqq2%content_r4 = vars%tracer(1)%content_r4 - tmp2 = vars%pt*vars%pkz/(1.0+eps*qqq2%content_r4) - else - qqq2%content = vars%tracer(1)%content - tmp2 = vars%pt*vars%pkz/(1.0+eps*qqq2%content) - endif - do k=1,km+1 - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - vars%pe(i,j,k) = pexy(i,k,j) - pelnxz (i,k,j) = log(vars%pe(i,j,k)) - enddo - enddo - enddo - call benergy(grid, vars%u, vars%v, tmp2, delpxy, & - qqq2, vars%pe, pelnxz, phisxy, & - eps, cp, rgas, tte, te1 ) - if(grid%iam==0) write(6,*) 'Inside FVwrap, TE_beg: ',te0,' TE_end: ',te1,' Diff: ',te0-te1 - deallocate( tmp2 ) -#endif - - if ( twod_decomp == 1 ) then - deallocate( phis ) - deallocate( pe ) - endif - - deallocate( cosp ) - deallocate( pke ) - deallocate( pkz ) - deallocate( pkz0 ) - deallocate( pkzb ) - deallocate( thvx ) - deallocate( thvy ) - deallocate( difx ) - deallocate( dify ) - deallocate( pbrx ) - deallocate( pbry ) - deallocate( facx ) - deallocate( facy ) - deallocate( dpdx ) - deallocate( dpdy ) - deallocate( oma_yz ) - deallocate( cpt_yz ) - deallocate( thv_yz ) - - deallocate( thdp ) - deallocate( thdp0 ) - deallocate( thdpb ) - - deallocate( delp0 ) - deallocate( delpd ) - deallocate( dkedt ) - deallocate( dkedt_xy ) - deallocate( dkedt_ho_yz ) - deallocate( dkedt_dp_yz ) - deallocate( dkedt_pg_yz ) - deallocate( dkedt_ad_yz ) - deallocate( dthdtremap1 ) - deallocate( dthdtremap2 ) - deallocate( dthconsv ) - - deallocate( u0 ) - deallocate( v0 ) - deallocate( ubar ) - deallocate( vbar ) - deallocate( dupg ) - deallocate( dvpg ) - deallocate( duad ) - deallocate( dvad ) - - deallocate( ptfy ) - deallocate( ptfx ) - deallocate( ptfy_accum ) - deallocate( ptfx_accum ) - deallocate( mfy ) - deallocate( mfx ) - deallocate( mfy_accum ) - deallocate( mfx_accum ) - deallocate( cy ) - deallocate( cx ) - deallocate( cy_accum ) - deallocate( cx_accum ) - deallocate( dp0 ) - deallocate( delpf ) - deallocate( ua_yz ) - deallocate( va_yz ) - deallocate( uc_yz ) - deallocate( vc_yz ) - deallocate( ud_yz ) - deallocate( vd_yz ) - deallocate( dpt ) - deallocate( pkc ) - deallocate( dwz ) - deallocate( wz ) - deallocate( worka ) - deallocate( pkcc ) - deallocate( wzc ) - deallocate( pkkp ) - deallocate( wzkp ) - -! Other arrays - deallocate( delp ) - deallocate( dum ) - deallocate( pk ) - -! -! Deallocate the control variables - - deallocate( q_internal ) - deallocate( pt ) - deallocate( v ) - deallocate( u ) - -! -! Deallocate XY decomposition stuff -! - deallocate( delpxy0 ) - deallocate( delpxy ) - deallocate( pexy ) - deallocate( psxy ) - deallocate( wzxy ) - deallocate( tmpxy ) - deallocate( dp0xy ) - - deallocate( gze ) - deallocate( phi ) - deallocate( del_KE , tot_KE ) - deallocate( del_PHI, tot_PHI ) - deallocate( ua ) - deallocate( va ) - deallocate( tv ) - - return - -contains - - subroutine Energetics (state,ud,vd,thv,plexzy,phis,ke,pe,te) - use dynamics_vars, only : d2a3d - - type (T_FVDYCORE_STATE) :: STATE - real(8) ud(:,:,:) - real(8) vd(:,:,:) - real(8) thv(:,:,:) - real(8) ke(:,:) - real(8) pe(:,:) - real(8) te(:,:) - real(8) phis(:,:) - - real(8) plexzy(:,:,:) - real(8) kinetic, potential, sump - integer i,ifirst,ilast - integer j,jfirst,jlast - integer k,im,jm,km - - real(8), allocatable :: ud2(:,:,:) - real(8), allocatable :: vd2(:,:,:) - real(8), allocatable :: ua2(:,:,:) - real(8), allocatable :: va2(:,:,:) - - real(8), allocatable :: delp(:,:,:) - real(8), allocatable :: pk(:,:,:) - real(8), allocatable :: ple(:,:,:) - real(8), allocatable :: pke(:,:,:) - real(8), allocatable :: gztop(:,:) - - ifirst = lbound( ud,1 ) - ilast = ubound( ud,1 ) - jfirst = lbound( ud,2 ) - jlast = ubound( ud,2 ) - km = ubound( ud,3 ) - im = state%grid%im - jm = state%grid%jm - - allocate( gztop( ifirst:ilast, jfirst:jlast ) ) - allocate( delp ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( pk ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( ple ( ifirst:ilast, jfirst:jlast , 1:km+1 ) ) - allocate( pke ( ifirst:ilast, jfirst:jlast , 1:km+1 ) ) - allocate( ua2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( va2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( ud2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - allocate( vd2 ( ifirst:ilast, jfirst:jlast , 1:km ) ) - - do k=1,km+1 - do j=jfirst,jlast - do i=ifirst,ilast - ple(i,j,k) = plexzy(i,k,j) - enddo - enddo - enddo - -! Compute Model Top Height -! ------------------------ - pke = ple**kappa - gztop = phis - do k=km,1,-1 - gztop(:,:) = gztop(:,:) + cp*thv(:,:,k)*( pke(:,:,k+1)-pke(:,:,k) ) - delp(:,:,k) = ple(:,:,k+1)-ple(:,:,k) - pk(:,:,k) = ( pke(:,:,k+1)-pke(:,:,k) )/( kappa*log(ple(:,:,k+1)/ple(:,:,k)) ) - enddo - -! Compute D-Grid Kinetic Energy -! ----------------------------- - ud2 = ud*ud - vd2 = vd*vd - call d2a3d( state%grid, ud2, vd2, ua2, va2 ) - - if( state%grid%jfirstxy.eq.1 ) then - ua2(:,1,:) = ud2(:,2,:) - va2(:,1,:) = vd2(:,2,:) - endif - if( state%grid%jlastxy.eq.jm ) then - ua2(:,jlast,:) = ud2(:,jlast ,:) - va2(:,jlast,:) = vd2(:,jlast-1,:) - endif - -! Compute Energetics: Cp*Tv + K + PHI -! ------------------------------------ - ke = 0.0 - pe = 0.0 - do k=1,km - do j=jfirst,jlast - do i=ifirst,ilast - kinetic = 0.5_r8*( ua2(i,j,k) + va2(i,j,k) ) - potential = cp*thv(i,j,k)*pk(i,j,k) - ke(i,j) = ke(i,j) + kinetic*delp(i,j,k) - pe(i,j) = pe(i,j) + potential*delp(i,j,k) - enddo - enddo - enddo - ke(:,:) = ke(:,:)/grav - pe(:,:) = pe(:,:)/grav - te(:,:) = (phis(:,:)*ple(:,:,km+1)-gztop(:,:)*ple(:,:,1))/grav - - if( state%grid%jfirstxy.eq.1 ) then - call par_xsum ( state%grid, ke(ifirst:ilast,1), 1, sump ) -! call par_xsum ( state%grid, ke(ifirst:ilast,2), 1, sump ) - sump = sump/im - do i=ifirst,ilast - ke(i,1) = sump - enddo - endif - if( state%grid%jlastxy.eq.jm ) then - call par_xsum ( state%grid, ke(ifirst:ilast,jlast ), 1, sump ) -! call par_xsum ( state%grid, ke(ifirst:ilast,jlast-1), 1, sump ) - sump = sump/im - do i=ifirst,ilast - ke(i,jlast) = sump - enddo - endif - - deallocate ( gztop ) - deallocate ( delp ) - deallocate ( pk ) - deallocate ( ple ) - deallocate ( pke ) - deallocate ( ua2 ) - deallocate ( va2 ) - deallocate ( ud2 ) - deallocate ( vd2 ) - - return - end subroutine Energetics - -!EOC -end subroutine FVdycore_wrapper -!------------------------------------------------------------------------------ diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVperf_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVperf_module.F90 deleted file mode 100644 index bac97495d..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/FVperf_module.F90 +++ /dev/null @@ -1,143 +0,0 @@ -!=============================================================================== -! CVS: $Id$ -! CVS: $Source$ -! CVS: $Name$ -!=============================================================================== - -!----------------------------------------------------------------------- -! ESMA - Earth System Modeling Applications -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: FVperf_module --- Simple interfaces for performance profiling -! -! !INTERFACE: - -MODULE FVperf_module - -! !USES: - use dynamics_vars, only : T_FVDYCORE_GRID -#if defined(MAPL_MODE) - use MAPL ! MAPL base class -#elif defined(CAM_MODE) - use perf_mod -#else - use perf_mod -#endif -#if defined( SPMD ) - use mod_comm, only: mp_barrier -#endif - -CONTAINS - -! !DESCRIPTION: A hack to toggle between GEOS5 and CAM profiling -! -! The basic problem solved here is to access GENSTATE in GEOS\_MODE -! without being overly intrusive (e.g. putting GEOS\_MODE in every -! file in which MAPL_TimerOn is used. If GEOS\_MODE -! is defined, the GENSTATE must be initialized outside this file, -! the various timing markers registered with GenericStateClockAdd, -! and the genstate in this module manual set. If CAM\_MODE is -! defined, the user may use FVstartclock/FVstopclock exactly like -! the CAM utilities t\_startf and t\_stopf. -! -! This module will be removed as soon as there is consensus on a -! unified profiling utility. -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: FVstartclock --- start the clock -! -! !INTERFACE: - subroutine FVstartclock(grid,marker) -! !USES: - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(inout) :: grid - character(LEN=*) , intent(in) :: marker -!EOP -!----------------------------------------------------------------------- -!BOC -#if defined(MAPL_MODE) - call MAPL_TimerOn(grid%FVgenstate,marker) -#elif defined(CAM_MODE) - call t_startf(marker) -#else - call t_startf(marker) -#endif -!EOC - end subroutine FVstartclock -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: FVstopclock --- stop the clock -! -! !INTERFACE: - subroutine FVstopclock(grid,marker) -! !USES: - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(inout) :: grid - character(LEN=*) , intent(in) :: marker -!EOP -!----------------------------------------------------------------------- -!BOC -#if defined(MAPL_MODE) - call MAPL_TimerOff(grid%FVgenstate,marker) -#elif defined(CAM_MODE) - call t_stopf(marker) -#else - call t_stopf(marker) -#endif -!EOC - end subroutine FVstopclock -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: FVbarrierclock --- instrumented timing barrier -! -! !INTERFACE: - subroutine FVbarrierclock(grid,marker) -! !USES: - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(inout) :: grid - character(LEN=*) , intent(in) :: marker -!EOP -!----------------------------------------------------------------------- -!BOC -#if defined(MAPL_MODE) -#if ( defined SPMD ) && ( defined TIMING_BARRIERS ) - call MAPL_TimerOn(grid%FVgenstate,marker) - call mp_barrier() - call MAPL_TimerOff(grid%FVgenstate,marker) -#endif -#elif defined(CAM_MODE) -#if ( defined SPMD ) - if (t_profile_onf()) then - if (t_barrier_onf()) then - call t_startf(marker) - call mp_barrier() - call t_stopf(marker) - endif - endif -#endif -#else -#if ( defined SPMD ) - if (t_profile_onf()) then - if (t_barrier_onf()) then - call t_startf(marker) - call mp_barrier() - call t_stopf(marker) - endif - endif -#endif -#endif -!EOC - end subroutine FVbarrierclock -!----------------------------------------------------------------------- - -END MODULE FVperf_module - - diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/G3_AVRX.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/G3_AVRX.F90 deleted file mode 100644 index c75d4291a..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/G3_AVRX.F90 +++ /dev/null @@ -1,245 +0,0 @@ - subroutine G3_AVRX ( U,IM,JM,LM,S,lattice ) - use G3_MPI_Util_Mod - implicit none - type ( dynamics_lattice_type ) lattice - INTEGER IM,JM,LM - REAL(kind=8) U(IM,JM,LM) - REAL(kind=8) S(lattice%imglobal+2,JM) - - integer status(mpi_status_size) - integer stats(mpi_status_size,0:lattice%nx-1) - integer statr(mpi_status_size,0:lattice%nx-1) - - integer sendquest(0:lattice%nx-1) - integer recvquest(0:lattice%nx-1) - integer ierror,peid - - logical first, flag - data first /.true./ - - INTEGER FORWARD, BACKWARD - PARAMETER (FORWARD=-1, BACKWARD=1) - - REAL(kind=8) ONE - REAL(kind=8) ZERO - REAL(kind=8) SMIN - PARAMETER ( ONE=1.0) - PARAMETER (ZERO=0.0) - - real(kind=8), allocatable :: sendbuf(:,:) - real(kind=8), allocatable :: recvbuf(:,:) - real(kind=8), allocatable :: z(:,:) - real(kind=8), allocatable :: b(:,:) - integer, allocatable :: j2(:) - - INTEGER I,J,L, J1(JM*LM), L1(JM*LM) - INTEGER NFFTS - INTEGER IM0 - DATA IM0/0/ - - integer n,num,rem,isum,lsum,len,len0 - integer, save :: ix(19) - real(kind=8), allocatable, save :: tr(:) - - if (lattice%imglobal.ne.im0) then - if(im0.ne.0) deallocate ( tr ) - allocate ( tr(lattice%imglobal*2) ) - call fftfax (lattice%imglobal,ix,tr) - im0=lattice%imglobal - endif - -! Compute Number of FFTs to Perform and Load Data into Buffer -! ----------------------------------------------------------- - allocate ( sendbuf(im,jm*lm) ) - - nffts = 0 - do j=1,jm - smin = minval( s(:,j) ) - if( smin.lt.0.9999 ) then - do L=1,lm - nffts = nffts + 1 - j1(nffts) = j - L1(nffts) = L - do i=1,im - sendbuf(i,nffts) = u(i,j,L) - enddo - enddo - endif - enddo - - num = nffts/lattice%nx - rem = nffts-lattice%nx*num - - len0 = num ! Define number of FFTs on myid - if( lattice%pei.le.rem-1 ) len0 = num+1 ! Define number of FFTs on myid - -#if 0 - if( first ) then - if( lattice%myid.eq.0 ) then - print *, 'FFT Load Balance for Upper-Air Field:' - print *, '-------------------------------------' - endif - do n=0,lattice%nx*lattice%ny-1 - if( n.eq.lattice%myid ) then - write(6,1000) lattice%myid,lattice%pei,lattice%pej,nffts,num,rem,len0 - if( mod(n+1,lattice%nx).eq.0 ) print * - endif - call my_barrier (lattice%comm) - enddo - if( lattice%myid.eq.lattice%nx*lattice%ny-1 ) print * - first = .false. - endif - 1000 format(1x,'absolute PE id: ',i3,' relative (pei,pej): ',i2,',',i2,' nffts: ',i6,2x, & - 'num: ',i6,2x,'rem: ',i6,2x,'len0: ',i6) -#endif - -! Distribute Data Across PEs in X-direction -! ----------------------------------------- - if( nffts.ne.0 ) then - - allocate ( j2(len0) ) - allocate ( z(lattice%imglobal+2,len0 ) ) - allocate ( b(lattice%imglobal+2,len0*2) ) - - isum = 0 - lsum = 0 - do n = 0,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - len = num - if( n.le.rem-1 ) len = num+1 - sendquest(n) = mpi_request_null - if( len.ne.0 ) then - if( peid.ne.lattice%myid ) then - call mpi_isend ( sendbuf(1,1+lsum),im*len,mpi_double_precision,peid,peid,lattice%comm,sendquest(n),ierror ) - else - do L=1,len0 - j2(L) = j1(L+lsum) - do i=1,im - z(i+isum,L) = sendbuf(i,L+lsum) - enddo - enddo - endif - endif - isum = isum + lattice%im(n) - lsum = lsum + len - enddo - -! Receive Data and Perform FFT -! ---------------------------- - if( len0.ne.0 ) then - - allocate ( recvbuf( lattice%imglobal*len0,0:lattice%nx-1 ) ) - do n = 0,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - if( peid.ne.lattice%myid ) then - call mpi_irecv ( recvbuf(1,n),lattice%im(n)*len0,mpi_double_precision,peid,lattice%myid,lattice%comm,recvquest(n),ierror ) - else - recvquest(n) = mpi_request_null - endif - enddo - - call mpi_waitall ( lattice%nx,sendquest(0:lattice%nx-1),stats(1,0),ierror ) - call mpi_waitall ( lattice%nx,recvquest(0:lattice%nx-1),statr(1,0),ierror ) - - isum = 0 - do n = 0,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - if( peid.ne.lattice%myid ) then - lsum = 0 - do L=1,len0 - do i=1,lattice%im(n) - lsum = lsum+1 - z(i+isum,L) = recvbuf(lsum,n) - enddo - enddo - endif - isum = isum + lattice%im(n) - enddo - - do L=1,len0 - z(lattice%imglobal+1,L) = 0.0 - z(lattice%imglobal+2,L) = 0.0 - enddo - -! Perform FFT -! ----------- - call rfftmlt( Z,B,TR,IX,1,lattice%imglobal+2,lattice%imglobal,len0,FORWARD ) - do L=1,len0 - do i=1,lattice%imglobal+2 - z(i,L) = z(i,L)*s(i,j2(L)) - enddo - enddo - call rfftmlt( Z,B,TR,IX,1,lattice%imglobal+2,lattice%imglobal,len0,BACKWARD ) - -! Distribute Filtered Data Back to source PEs -! ------------------------------------------- - deallocate ( sendbuf ) - deallocate ( recvbuf ) - allocate ( sendbuf( lattice%imglobal*len0,0:lattice%nx-1 ) ) - isum = 0 - do n = 0,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - if( peid.ne.lattice%myid ) then - - lsum = 0 - do L=1,len0 - do i=1,lattice%im(n) - lsum = lsum+1 - sendbuf(lsum,n) = z(i+isum,L) - enddo - enddo - call mpi_isend ( sendbuf(1,n),lsum,mpi_double_precision,peid,peid,lattice%comm,sendquest(n),ierror ) - - else - sendquest(n) = mpi_request_null - endif - isum = isum + lattice%im(n) - enddo - - endif ! End len0.ne.0 check - -! Receive Filtered Data -! --------------------- - allocate ( recvbuf(im,nffts) ) - isum = 0 - lsum = 0 - do n = 0,lattice%nx-1 - peid = n + lattice%pej*lattice%nx - len = num - if( n.le.rem-1 ) len = num+1 - recvquest(n) = mpi_request_null - if( len.ne.0 ) then - if( peid.ne.lattice%myid ) then - call mpi_irecv ( recvbuf(1,1+lsum),im*len,mpi_double_precision,peid,lattice%myid,lattice%comm,recvquest(n),ierror ) - else - do L=1,len0 - do i=1,im - recvbuf(i,L+lsum) = z(i+isum,L) - enddo - enddo - endif - endif - isum = isum + lattice%im(n) - lsum = lsum + len - enddo - - call mpi_waitall ( lattice%nx,sendquest(0:lattice%nx-1),stats(1,0),ierror ) - call mpi_waitall ( lattice%nx,recvquest(0:lattice%nx-1),statr(1,0),ierror ) - -! Reconstruct Filtered Field -! -------------------------- - do n=1,nffts - do i=1,im - u(i,j1(n),L1(n)) = recvbuf(i,n) - enddo - enddo - - deallocate ( z,b,j2 ) - deallocate ( sendbuf ) - deallocate ( recvbuf ) - else - deallocate ( sendbuf ) - endif - - return - end diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/benergy.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/benergy.F90 deleted file mode 100644 index b0082cf70..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/benergy.F90 +++ /dev/null @@ -1,377 +0,0 @@ -#define DGRID - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: benergy --- Calculate the total energy (based on GFDL) -! -! !INTERFACE: - - subroutine benergy(grid, u, v, t3, delp, & - qqq, pe, peln, phis, & - r_vir, cp, rg, tte, te0 ) - -! !USES: - - use shr_kind_mod, only: r8 => shr_kind_r8 - use dynamics_vars, only : T_FVDYCORE_GRID, T_TRACERS - -#if defined( SPMD ) - use mod_comm, only: commglobal, mp_send3d, mp_recv3d -#endif - implicit none - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid ! YZ decomposition - -! U-winds - real(r8), intent(in) :: u(grid%ifirstxy:grid%ilastxy, & - grid%jfirstxy:grid%jlastxy, & - grid%km) -! V-winds - real(r8), intent(in) :: v(grid%ifirstxy:grid%ilastxy, & - grid%jfirstxy:grid%jlastxy, & - grid%km) - -! Temperature (K) - real(r8), intent(in) :: t3(grid%ifirstxy:grid%ilastxy, & - grid%jfirstxy:grid%jlastxy, & - grid%km) - -! Delta pressure - real(r8), intent(in) :: delp(grid%ifirstxy:grid%ilastxy, & - grid%jfirstxy:grid%jlastxy, & - grid%km) - -! Specific humidity - type(T_TRACERS), intent(in) :: qqq - -! Edge pressure - real(r8), intent(in) :: pe(grid%ifirstxy:grid%ilastxy, & - grid%jfirstxy:grid%jlastxy, & - grid%km+1) - -! Edge pressure - real(r8), intent(in) :: peln(grid%ifirstxy:grid%ilastxy, & - grid%km+1, & - grid%jfirstxy:grid%jlastxy) - -! Surface heights - real(r8), intent(in) :: phis(grid%ifirstxy:grid%ilastxy, & - grid%jfirstxy:grid%jlastxy) - - real(r8), intent(in) :: r_vir ! Virtual effect constant ( rwv/rg-1 ) - real(r8), intent(in) :: cp ! C_p ( = rg / cappa ) - real(r8), intent(in) :: rg ! Gas constant for dry air - -! !OUTPUT PARAMETERS: - -! column integrated Total Energy - real(r8), intent(out) :: tte(grid%jm) -! globally integrated total energy - real(r8), intent(out) :: te0 - -! !DESCRIPTION: -! Determines the column and globally integrated total energy -! -! !REVISION HISTORY: -! -! SJL 99.04.13 : Delivered as release 0.9.8 -! WS 99.05.18 : Added im, jm, km, te, dz as arguments -! WS 99.05.25 : Replaced IMR by IM, JMR by JM-1; removed fvcore.h -! WS 99.10.11 : Ghosted U, now fully limited to jfirst:jlast -! WS 99.11.23 : Pruned te, additional cleaning -! WS 00.05.14 : Renamed ghost indices as per Kevin's definitions -! WS 00.07.13 : Changed PILGRIM API -! WS 00.08.28 : Cosmetic changes -! AAM 00.08.28 : Added kfirst,klast -! WS 00.12.01 : Replaced MPI_ON with SPMD; hs now distributed -! AAM 01.06.15 : Changes for zero diff -! WS 01.12.10 : Ghosted PT -! WS 01.12.31 : Ghosted U,V -! WS 02.07.04 : Fixed 2D decomposition bug dest/src for mp_send3d -! WS 03.10.22 : pmgrid removed (now spmd_dyn) -! WS 03.12.03 : added grid as input argument -! WS 04.10.07 : Removed dependency on spmd_dyn; info now in GRID -! WS 06.05.02 : Rewritten for XY decomposition based on GFDL-code -! WS 06.06.21 : Extensive debugging of revised version -! LT 06.12.13 : Compute A-Grid Kinetic Energy -! WS 09.04.01 : Upgraded to PILGRIM from cam3_6_33 -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! Local - real (r8), parameter :: D0_0 = 0.0_r8 - real (r8), parameter :: D0_125 = 0.125_r8 - real (r8), parameter :: D0_25 = 0.25_r8 - real (r8), parameter :: D0_5 = 0.5_r8 - real (r8), parameter :: D1_0 = 1.0_r8 - - integer :: im, jm, km, ifirstxy, ilastxy, jfirstxy, jlastxy - integer :: iam, myidxy_x, myidxy_y, nprxy_x, nprxy_y, dest, src ! SPMD related - integer :: i, j, k, js1g0, js2g0, jn1g0, jn1g1, jn2g0, jtot - - real (r8) :: u2(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy+1) - real (r8) :: v2(grid%ifirstxy:grid%ilastxy+1,grid%jfirstxy:grid%jlastxy) - - real (r8) :: tm(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) - real (r8) :: bte(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) - real (r8) :: te_sp(grid%ifirstxy:grid%ilastxy,grid%km) - real (r8) :: te_np(grid%ifirstxy:grid%ilastxy,grid%km) - real (r8) :: gztop(grid%ifirstxy:grid%ilastxy) - real (r8) :: xsum(grid%jfirstxy:grid%jlastxy) - real (r8) :: sp_sum(grid%km), np_sum(grid%km) - real (r8) :: tm_sp(grid%km), tm_np(grid%km) - real (r8) :: tmp - - real (r8) :: te(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy, & - grid%km) - real (r8) :: dz(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy, & - grid%km) - real(r8) :: veast(grid%jfirstxy:grid%jlastxy,grid%km) ! East halo - real(r8) :: unorth(grid%ifirstxy:grid%ilastxy,grid%km) ! North halo - - im = grid%im - jm = grid%jm - km = grid%km - - ifirstxy = grid%ifirstxy - ilastxy = grid%ilastxy - jfirstxy = grid%jfirstxy - jlastxy = grid%jlastxy - - iam = grid%iam - myidxy_x = grid%myidxy_x - myidxy_y = grid%myidxy_y - nprxy_x = grid%nprxy_x - nprxy_y = grid%nprxy_y - - js1g0 = max(1,jfirstxy) - js2g0 = max(2,jfirstxy) - jn2g0 = min(jm-1,jlastxy) - jn1g0 = min(jm,jlastxy) - jn1g1 = min(jm,jlastxy+1) - - jtot = jlastxy - jfirstxy + 1 - -#if defined(SPMD) - call mp_send3d( commglobal, iam-nprxy_x, iam+nprxy_x, im, jm, km, & - ifirstxy, ilastxy, jfirstxy, jlastxy, 1, km, & - ifirstxy, ilastxy, jfirstxy, jfirstxy, 1, km, u ) - call mp_recv3d( commglobal, iam+nprxy_x, im, jm, km, & - ifirstxy, ilastxy, jlastxy+1, jlastxy+1, 1, km, & - ifirstxy, ilastxy, jlastxy+1, jlastxy+1, 1, km, unorth ) - - if (nprxy_x > 1) then - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirstxy, ilastxy, jfirstxy, jlastxy, 1, km, & - ifirstxy, ifirstxy, jfirstxy, jlastxy, 1, km, v ) - call mp_recv3d( commglobal, src, im, jm, km, & - ilastxy+1, ilastxy+1, jfirstxy, jlastxy, 1, km, & - ilastxy+1, ilastxy+1, jfirstxy, jlastxy, 1, km, veast ) - else -!$omp parallel do private(j, k) - do k = 1,km - do j=jfirstxy,jlastxy - veast(j,k) = v(1,j,k) - enddo - enddo - endif -#else - !$omp parallel do private(j, k) - do k = 1,km - do j=1,jm - veast(j,k) = v(1,j,k) - enddo - enddo -#endif - - -!----------------------------------------------------------------------------------------------- - - -!$omp parallel do private(i, j, k, u2, v2, tm) - do k=1,km -! -! Check the poles for consistent values - - do j=js2g0,jlastxy - do i=ifirstxy,ilastxy -#ifdef DGRID - u2(i,j) = u(i,j,k)**2 ! D-Grid KE -#else - u2(i,j) = u(i,j,k) ! A-Grid KE -#endif - enddo - enddo - - if ( jlastxy /= jm ) then ! Pull information out of northern halo - do i=ifirstxy,ilastxy -#ifdef DGRID - u2(i,jlastxy+1) = unorth(i,k)**2 -#else - u2(i,jlastxy+1) = unorth(i,k) -#endif - enddo - endif - - do j=js2g0,jn2g0 - do i=ifirstxy,ilastxy -#ifdef DGRID - v2(i,j) = v(i,j,k)**2 -#else - v2(i,j) = v(i,j,k) -#endif - enddo -#ifdef DGRID - v2(ilastxy+1,j) = veast(j,k)**2 ! eastern halo -#else - v2(ilastxy+1,j) = veast(j,k) ! eastern halo -#endif - enddo - - do j=js2g0,jn2g0 - do i=ifirstxy,ilastxy -#ifdef DGRID - te(i,j,k) = D0_25*((u2(i,j)+u2(i,j+1)) + & - v2(i,j)+v2(i+1,j)) -#else - te(i,j,k) = D0_125*( (u2(i,j)+u2(i,j+1))**2 & - + (v2(i,j)+v2(i+1,j))**2 ) -#endif - enddo - enddo - - if ( qqq%is_r4 ) then - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - tm(i,j) = t3(i,j,k)*(D1_0+r_vir*qqq%content_r4(i,j,k)) - enddo - enddo - else - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - tm(i,j) = t3(i,j,k)*(D1_0+r_vir*qqq%content(i,j,k)) - enddo - enddo - endif - - do j=js2g0,jn2g0 - do i=ifirstxy, ilastxy - te(i,j,k) = delp(i,j,k) * ( te(i,j,k) + cp*tm(i,j) ) - enddo - enddo - - if ( jfirstxy == 1 ) then - do i=ifirstxy,ilastxy -#ifdef DGRID - te_sp(i,k) = u2(i,2) + v2(i,2) -#else - te_sp(i,k) = D0_5*u2(i,2)**2 -#endif - enddo - tm_sp(k) = tm(ifirstxy,1) ! All tm(:,1) should be the same - endif - - if ( jlastxy == jm ) then - do i=ifirstxy,ilastxy -#ifdef DGRID - te_np(i,k)= u2(i,jm) + v2(i,jm-1) -#else - te_np(i,k)= D0_5*u2(i,jm)**2 -#endif - enddo - tm_np(k) = tm(ifirstxy,jm) ! All tm(:,jm) should be the same - endif - - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - dz(i,j,k) = rg*tm(i,j) - enddo - enddo - enddo - - - if ( jfirstxy == 1 ) then - call par_xsum( grid, te_sp, km, sp_sum ) - -!$omp parallel do private(i, k, tmp) - do k=1,km - tmp = delp(ifirstxy,1,k) * (D0_5*sp_sum(k)/real(im,r8) + & - cp*tm_sp(k)) - do i=ifirstxy,ilastxy - te(i,1,k) = tmp - enddo - enddo - endif - if ( jlastxy == jm ) then - call par_xsum( grid, te_np, km, np_sum ) - -!$omp parallel do private(i, k, tmp) - do k=1,km - tmp = delp(ifirstxy,jm,k) * (D0_5*np_sum(k)/real(im,r8) +& - cp*tm_np(k)) - do i=ifirstxy,ilastxy - te(i,jm,k) = tmp - enddo - enddo - endif - - bte = D0_0 -!$omp parallel do private(i,j,k,gztop) - do j=jfirstxy,jlastxy -! Perform vertical integration - do i=ifirstxy,ilastxy - gztop(i) = phis(i,j) - do k=1,km - gztop(i) = gztop(i) + dz(i,j,k)*(peln(i,k+1,j)-peln(i,k,j)) - enddo - enddo - - if (j == 1) then -! gztop(:) should all have identical values WS 2006.06.22: this checks out -! SP - tte(1) = pe(ifirstxy,1,km+1)*phis(ifirstxy,1) - pe(ifirstxy,1,1)*gztop(ifirstxy) - do k=1,km - tte(1) = tte(1) + te(ifirstxy,1,k) - enddo - tte(1) = grid%acap * tte(1) - elseif (j == jm) then -! gztop(:) should all have identical values WS 2006.06.22: this checks out -! NP - tte(jm) = pe(ifirstxy,jm,km+1)*phis(ifirstxy,jm) - pe(ifirstxy,jm,1)*gztop(ifirstxy) - do k=1,km - tte(jm) = tte(jm) + te(ifirstxy,jm,k) - enddo - tte(jm) = grid%acap * tte(jm) - else -! Interior - - do i=ifirstxy,ilastxy - bte(i,j) = pe(i,j,km+1)*phis(i,j) - pe(i,j,1)*gztop(i) - enddo - - do k=1,km - do i=ifirstxy,ilastxy - bte(i,j) = bte(i,j) + te(i,j,k) - enddo - enddo - endif - enddo - call par_xsum(grid, bte, jtot, xsum) - -!$omp parallel do private(j) - do j=js2g0,jn2g0 - tte(j) = xsum(j)*grid%cosp(j) - enddo - - call par_vecsum(jm, jfirstxy, jlastxy, tte, te0, grid%commxy_y, grid%nprxy_y) - -! print *, "myidxy_x/y:", myidxy_x, myidxy_y, "The total energy is", te0 - -!EOC - end subroutine benergy -!----------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/cd_core.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/cd_core.F90 deleted file mode 100644 index dba79538e..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/cd_core.F90 +++ /dev/null @@ -1,1246 +0,0 @@ - -! $Id$ - - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: cd_core --- Dynamical core for both C- and D-grid Lagrangian -! dynamics -! -! !INTERFACE: - - subroutine cd_core(grid, nx, u, v, pt, & - delp, pe, pk, ns, dt, & - ptopin, umax, pi, ae, cp, akap, & - iord_c, jord_c, iord_d, jord_d, ipe, & - om, hs, cx3 , cy3, & - mfx, mfy, ptfx , ptfy , & - delpf, uc, vc, & - ubar,vbar, duadv, dvadv, dupg, dvpg, & - ptc, dpt, ptk, & - wz3, pkc, wz, hsxy, ptxy, pkxy, & - pexy, pkcc, wzc, wzxy, delpxy, & - pkkp, wzkp ) - -! !USES: - use shr_kind_mod, only: r8 => shr_kind_r8 - use sw_core, only : d2a2c_winds, c_sw, d_sw - use pft_module, only : fftfax, pft2d, pft_cf, pftinit - use dynamics_vars, only : T_FVDYCORE_GRID - use FVperf_module, only : FVstartclock, FVstopclock, FVbarrierclock - -#if defined( SPMD ) - use mod_comm, only: commglobal, mp_send4d_ns, mp_recv4d_ns, & - mp_send2_ns, mp_recv2_ns, & - mp_send3d_2, mp_recv3d_2, & - mp_send3d, mp_recv3d, mp_swapirr - -#define CPP_PRT_PREFIX if(iam==0) -#else -#define CPP_PRT_PREFIX -#endif - -#if defined( OFFLINE_DYN ) - use metdata, only: get_met_fields, met_winds_on_walls -#endif - - 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 - -! !INPUT PARAMETERS: - - type (T_FVDYCORE_GRID), intent(inout) :: grid! grid (for YZ decomp) - integer, intent(in) :: nx ! # of split pieces in longitude direction - integer, intent(in) :: ipe ! ipe=1: end of cd_core() - ! ipe=-1: start of cd_core() - ! ipe=0 : - integer, intent(in) :: ns ! Number of internal time steps (splitting) - integer, intent(in) :: iord_c, jord_c ! scheme order on C grid in X and Y dir. - integer, intent(in) :: iord_d, jord_d ! scheme order on D grid in X and Y dir. - - real(r8), intent(in) :: pi - real(r8), intent(in) :: ae ! Radius of the Earth (m) - real(r8), intent(in) :: om ! rotation rate - real(r8), intent(in) :: ptopin - real(r8), intent(in) :: umax - real(r8), intent(in) :: dt !small time step in seconds - real(r8), intent(in) :: cp - real(r8), intent(in) :: akap - -! Input time independent arrays: - real(r8), intent(in) :: & - hs(grid%im,grid%jfirst:grid%jlast) !surface geopotential - real(r8), intent(in) :: & - hsxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) !surface geopotential XY-decomp. - -! !INPUT/OUTPUT PARAMETERS: - - real(r8), intent(inout) :: & - u(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_s,grid%kfirst:grid%klast) ! u-Wind (m/s) - real(r8), intent(inout) :: & - v(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) ! v-Wind (m/s) - - real(r8), intent(inout) :: & - delp(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ! Delta pressure (pascal) - real(r8), intent(inout) :: & - pt(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast)! Scaled-Pot. temp. - -! Input/output: accumulated winds & mass fluxes on c-grid for large- -! time-step transport - real(r8), intent(inout) :: & - cx3(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast)! Accum. Courant no. in X - real(r8), intent(inout) :: & - cy3(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) ! Accumulated Courant no. in Y - real(r8), intent(inout) :: & - mfx(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ! Mass flux in X (unghosted) - real(r8), intent(inout) :: & - mfy(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) ! Mass flux in Y - real(r8), intent(inout) :: & - ptfx(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ! Mass-weighted PT flux in X (unghosted) - real(r8), intent(inout) :: & - ptfy(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) ! Mass-weighted PT flux in Y - -! Input/output work arrays: - real(r8), intent(inout) :: & - delpf(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) ! filtered delp - real(r8), intent(inout) :: & - uc(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) ! u-Winds on C-grid - real(r8), intent(inout) :: & - vc(grid%im,grid%jfirst-2: grid%jlast+2, grid%kfirst:grid%klast) ! v-Winds on C-grid - - real(r8), intent(inout) :: & - ptc(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - real(r8), intent(inout) :: & - ptk(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - real(r8), intent(inout) :: & - dpt(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast) - real(r8), intent(inout) :: & - wz3(grid%im,grid%jfirst-1:grid%jlast ,grid%kfirst:grid%klast+1) - real(r8), intent(inout) :: & - pkc(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast+1) - real(r8), intent(inout) :: & - wz(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast+1) - real(r8), intent(inout) :: & - pkcc(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) - real(r8), intent(inout) :: & - wzc(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) - real(r8), intent(inout) :: & - wzxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) - real(r8), intent(inout) :: & - delpxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - real(r8), intent(inout) :: & - pkkp(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) - real(r8), intent(inout) :: & - wzkp(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) - - -! !OUTPUT PARAMETERS: - real(r8), intent(out) :: & - pe(grid%im,grid%kfirst:grid%klast+1,grid%jfirst:grid%jlast) ! Edge pressure (pascal) - real(r8), intent(out) :: & - pk(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) ! Pressure to the kappa - real(r8), intent(out) :: & - ptxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! Potential temperature XY decomp - real(r8), intent(out) :: & - pkxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) ! P-to-the-kappa XY decomp - real(r8), intent(out) :: & - pexy(grid%ifirstxy:grid%ilastxy,grid%km+1,grid%jfirstxy:grid%jlastxy) ! Edge pressure XY decomp - - real(r8), intent(out) :: ubar (grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_s,grid%kfirst:grid%klast) - real(r8), intent(out) :: vbar (grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) - real(r8), intent(out) :: dupg (grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_s,grid%kfirst:grid%klast) - real(r8), intent(out) :: dvpg (grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) - real(r8), intent(out) :: duadv(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_s,grid%kfirst:grid%klast) - real(r8), intent(out) :: dvadv(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) - -! ! !DESCRIPTION: -! Perform a dynamical update for one small time step; the small -! time step is limitted by the fastest wave within the Lagrangian control- -! volume -! -! !REVISION HISTORY: -! SJL 99.01.01: Original SMP version -! WS 99.04.13: Added jfirst:jlast concept -! SJL 99.07.15: Merged c_core and d_core to this routine -! WS 99.09.07: Restructuring, cleaning, documentation -! WS 99.10.18: Walkthrough corrections; frozen for 1.0.7 -! WS 99.11.23: Pruning of some 2-D arrays -! SJL 99.12.23: More comments; general optimization; reduction -! of redundant computation & communication -! WS 00.05.14: Modified ghost indices per Kevin's definition -! WS 00.07.13: Changed PILGRIM API -! WS 00.08.28: Cosmetic changes: removed old loop limit comments -! AAM 00.08.30: Introduced kfirst,klast -! WS 00.12.01: Replaced MPI_ON with SPMD; hs now distributed -! WS 01.04.11: PILGRIM optimizations for begin/endtransfer -! WS 01.05.08: Optimizations in the call of c_sw and d_sw -! AAM 01.06.27: Reinstituted 2D decomposition for use in ccm -! WS 01.12.10: Ghosted PT, code now uses mod_comm primitives -! WS 01.12.31: Removed vorticity damping, ghosted U,V,PT -! WS 02.01.15: Completed transition to mod_comm -! WS 02.07.04: Fixed 2D decomposition bug dest/src for mp_send3d -! WS 02.09.04: Integrated fvgcm-1_3_71 zero diff. changes by Lin -! WS 03.07.22: Removed HIGH_P option; this is outdated -! WS 03.10.15: Fixed hack of 00.04.13 for JORD>1 JCD=1, in clean way -! WS 03.12.03: Added grid as argument, some dynamics_vars removed -! WS 04.08.25: Interface simplified with GRID argument -! WS 04.10.07: Removed dependency on spmd_dyn; info now in GRID -! WS 05.05.24: Incorporated OFFLINE_DYN; merge of CAM/GEOS5 -! PW 05.07.26: Changes for Cray X1 -! PW 05.10.12: More changes for Cray X1(E), avoiding array segment copying -! WS 06.09.08: Isolated magic numbers as F90 parameters -! WS 06.09.15: PI now passed as argument -! CC 07.01.29: Corrected calculation of OMEGA -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! Local 2D arrays: - real(r8) :: wk(grid%im+2,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8) :: wk1(grid%im,grid%jfirst-1:grid%jlast+1) - real(r8) :: wk2(grid%im+1,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8) :: wk3(grid%im,grid%jfirst-1:grid%jlast+1) - - real(r8) :: p1d(grid%im) - -! fvitt cell centered u- and v-Winds (m/s) - real(r8) :: u_cen(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) - real(r8) :: v_cen(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) - real(r8) ua(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) - real(r8) va(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) - -! Local scalars - - real(r8), parameter :: D0_0 = 0.0_r8 - real(r8), parameter :: D0_1 = 0.1_r8 - real(r8), parameter :: D0_5 = 0.5_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D4_0 = 4.0_r8 - real(r8), parameter :: D8_0 = 8.0_r8 - real(r8), parameter :: D10_0 = 10.0_r8 - real(r8), parameter :: D128_0 = 128.0_r8 - real(r8), parameter :: D180_0 = 180.0_r8 - real(r8), parameter :: D1E5 = 1.0e5_r8 - - real(r8), parameter :: ratmax = 0.81_r8 - real(r8), parameter :: tiny = 1.0e-10_r8 - - real(r8) :: press - real(r8) :: rat, ycrit - real(r8) :: dt5 - - integer :: im, jm, km ! problem dimensions - integer :: nq ! # of tracers to be advected by trac2d - integer :: ifirstxy,ilastxy ! xy-decomp. longitude ranges - integer :: jfirstxy,jlastxy ! xy-decomp. latitude ranges - integer :: ng_c ! ghost latitudes on C grid - integer :: ng_d ! ghost lats on D (Max NS dependencies, ng_d >= ng_c) - integer :: ng_s ! max(ng_c+1,ng_d) significant if ng_c = ng_d - - integer :: jfirst - integer :: jlast - integer :: kfirst - integer :: klast - integer :: klastp ! klast, except km+1 when klast=km - - integer :: iam - integer :: npr_y - - integer i, j, k - integer js1g1, js2g0, js2g1 - integer jn2g0, jn1g1 - integer js2gc, jn2gc, jn1gc - integer iord , jord - integer ktot, ktotp - - real(r8) :: tau, fac, pk4 - -#if defined( SPMD ) - integer dest, src -#endif - - logical :: reset_winds = .false. - logical :: everytime = .true. - -!****************************************************************** -!****************************************************************** -! -! IMPORTANT CODE OPTIONS - SEE BELOW -! -!****************************************************************** -!****************************************************************** - -! Option for which version of geopk to use with yz decomposition. -! If geopk16byte is true, version geopk16 is used. It computes local partial sums in z -! and then communicates those sums to combine them. It can use 16-byte arithmetic -! to preserve bit-for-bit accuracy (DSIZE=16) or 8-byte arithmetic for speed (DSIZE=8). -! The communication is semi-global in z. -! If geopk16byte=false, variables are transposed to/from xy decomposition -! for use in geopk. -! On last small timestep (ipe=1) for D-grid, the version of geopk that uses transposes -! is called regardless, as some transposed quantities are required for -! the te_map phase. -! For non-SPMD mode, geopk[cd]16 are set to false. - - logical geopkc16, geopkd16 - - geopkc16 = .false. - geopkd16 = .false. -#if defined( SPMD ) - if (grid%geopk16byte) then - geopkc16 = .true. - if (ipe /= 1) geopkd16 = .true. - endif -#endif - -!****************************************************************** - call FVstartclock(grid,'---PRE_C_CORE') - - im = grid%im - jm = grid%jm - km = grid%km - nq = grid%nq - - ng_c = grid%ng_c - ng_d = grid%ng_d - ng_s = grid%ng_s - - jfirst = grid%jfirst - jlast = grid%jlast - kfirst = grid%kfirst - klast = grid%klast - klastp = grid%klastp - - iam = grid%iam - npr_y = grid%npr_y - - ifirstxy = grid%ifirstxy - ilastxy = grid%ilastxy - jfirstxy = grid%jfirstxy - jlastxy = grid%jlastxy - - ktot = klast - kfirst + 1 - ktotp = ktot + 1 - -#if defined( SPMD ) - call FVstartclock(grid,'----PRE_C_CORE_COMM') - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, u ) - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, v ) - call FVstopclock(grid,'----PRE_C_CORE_COMM') -#endif - -! Set general loop limits -! jfirst >= 1; jlast <= jm - js1g1 = max(1,jfirst-1) - js2g0 = max(2,jfirst) - js2g1 = max(2,jfirst-1) - jn2g0 = min(jm-1,jlast) - jn1g1 = min(jm,jlast+1) - -! -! Not currently used, but may be useful for subsequent optimization -! - js2gc = max(2,jfirst-ng_c) - jn2gc = min(jm-1,jlast+ng_c) - jn1gc = min(jm,jlast+ng_c) - - - if( abs(grid%dt0-dt) > D0_1 ) then - - grid%dt0 = dt - dt5 = D0_5*dt - - grid%rdy = D1_0/(ae*grid%dp) - grid%dtdy = dt *grid%rdy - grid%dtdy5 = dt5*grid%rdy - grid%dydt = (ae*grid%dp) / dt - grid%tdy5 = D0_5/grid%dtdy - - do j=2,jm-1 - grid%dx(j) = grid%dl*ae*grid%cosp(j) - grid%rdx(j) = D1_0 / grid%dx(j) - grid%dtdx(j) = dt /grid% dx(j) - grid%dxdt(j) = grid%dx(j) / dt - grid%dtdx2(j) = D0_5*grid%dtdx(j) - grid%dtdx4(j) = D0_5*grid%dtdx2(j) - grid%dycp(j) = ae*grid%dp/grid%cosp(j) - grid%cy(j) = grid%rdy * grid%acosp(j) - enddo - - do j=2,jm - grid%dxe(j) = ae*grid%dl*grid%cose(j) - grid%rdxe(j) = D1_0 / grid%dxe(j) - grid%dtdxe(j) = dt / grid%dxe(j) - grid%dtxe5(j) = D0_5*grid%dtdxe(j) - grid%txe5(j) = D0_5/grid%dtdxe(j) - grid%cye(j) = D1_0 / (ae*grid%cose(j)*grid%dp) - grid%dyce(j) = ae*grid%dp/grid%cose(j) - enddo - -! C-grid -#ifndef WACCM_MOZART - grid%zt_c = abs(umax*dt5) / (grid%dl*ae) -#else - grid%zt_c = cos( D10_0 * pi / D180_0 ) -#endif - -! D-grid -#ifndef WACCM_MOZART - grid%zt_d = abs(umax*dt) / (grid%dl*ae) -#else - grid%zt_d = cos( D10_0 * pi / D180_0 ) -#endif - - if ( ptopin /= grid%ptop) then - write(6,*) 'PTOP as input to cd_core != ptop from T_FVDYCORE_GRID' - stop - endif - -!----------------------------------------- -! Divergence damping coeff. dx(2)*dy/(TAU) -!----------------------------------------- - do k=kfirst,klast - press = D0_5 * ( grid%ak(k)+grid%ak(k+1) + & - (grid%bk(k)+grid%bk(k+1))*D1E5 ) - tau = D8_0 * (D1_0+ tanh(D1_0*log(grid%ptop/press)) ) - tau = max(D1_0, tau) / (D128_0*abs(dt)) - do j=js2g0,jn1g1 - fac = tau * ae / grid%cose(j) - grid%cdx(j,k) = fac*grid%dp - grid%cdy(j,k) = fac*grid%dl - enddo - enddo - endif - - if ( ipe == -1 .or. ns == 1 ) then ! starting cd_core - call FVstartclock(grid,'----C_DELP_LOOP') -!$omp parallel do private(i, j, k, wk, wk2) -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ PARALLEL DO PRIVATE (I, J, K, WK, WK2) -#endif - do k=kfirst,klast - do j=jfirst,jlast - do i=1,im - delpf(i,j,k) = delp(i,j,k) - enddo - enddo - call pft2d( delpf(1,js2g0,k), grid%sc, & - grid%dc, im, jn2g0-js2g0+1, & - wk, wk2 ) - enddo -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ END PARALLEL DO -#endif - call FVstopclock(grid,'----C_DELP_LOOP') - - endif - -#if defined( SPMD ) - call FVstartclock(grid,'----PRE_C_CORE_COMM') - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, u ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, v ) - - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, pt ) - if ( ipe == -1 .or. ns == 1 ) then ! starting cd_core - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, delpf ) - endif ! end if ipe = -1 check - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, pt ) - if ( ipe == -1 .or. ns == 1 ) then ! starting cd_core - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, delpf ) - endif ! end if ipe = -1 check - call FVstopclock(grid,'----PRE_C_CORE_COMM') -#endif - -! -! Get the cell centered winds if needed for the sub-step -! -#if ( defined OFFLINE_DYN ) - if ( ( (ipe .eq. -1) .or. (everytime) ) .and. (.not. met_winds_on_walls()) ) then - call get_met_fields( grid, u_cen, v_cen ) - reset_winds = .true. - else - reset_winds = .false. - endif -#endif - -! Get D-grid V-wind at the poles and interpolate winds to A- and C-grids and Filter - -!$omp parallel do private(i, j, k, wk, wk2) -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ PARALLEL DO PRIVATE (I, J, K, WK, WK2) -#endif - do k=kfirst,klast - call d2a2c_winds(grid, u(1,jfirst-ng_d,k), v(1,jfirst-ng_s,k), & - ua(1,jfirst-ng_d,k), va(1,jfirst-ng_s,k), & - uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & - reset_winds, u_cen(1,jfirst-ng_d,k), v_cen(1,jfirst-ng_s,k)) - - call pft2d ( uc(1,js2g0,k), grid%sc, grid%dc, im, jn2g0-js2g0+1, wk, wk2 ) - call pft2d ( vc(1,js2g0,k), grid%se, grid%de, im, jlast-js2g0+1, wk, wk2 ) - - enddo -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ END PARALLEL DO -#endif - -! Fill C-grid advecting winds Halo regions -! vc only needs to be ghosted at jlast+1 - dest = iam-1 - src = iam+1 - if ( mod(iam,npr_y) == 0 ) dest = -1 - if ( mod(iam+1,npr_y) == 0 ) src = -1 - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, uc ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, uc ) - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, 2, 2, vc ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, 2, 2, vc ) - call FVstopclock(grid,'---PRE_C_CORE') - - call FVbarrierclock(grid,'sync_c_core') - call FVstartclock(grid,'---C_CORE') - -!$omp parallel do private(i, j, k, iord, jord) - -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ PARALLEL DO PRIVATE (K, IORD, JORD) -#endif - - do k=kfirst,klast ! This is the main parallel loop. - - if ( k <= km/8 ) then - iord = 1 - jord = 1 - else - iord = iord_c - jord = jord_c - endif - -!----------------------------------------------------------------- -! Call the vertical independent part of the dynamics on the C-grid -!----------------------------------------------------------------- - - call c_sw( grid, u(1,jfirst-ng_d,k), v(1,jfirst-ng_s,k), & - pt(1,jfirst-ng_d,k), delp(1,jfirst,k), & - ua(1,jfirst-ng_d,k), va(1,jfirst-ng_s,k), & - uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & - ptc(1,jfirst,k), delpf(1,jfirst-ng_d,k), & - ptk(1,jfirst,k), tiny, iord, jord) - enddo -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ END PARALLEL DO -#endif - - call FVstopclock(grid,'---C_CORE') - -! MPI note: uc, vc, ptk, and ptc computed within the above k-look from jfirst to jlast -! Needed by D-core: uc(jfirst-ng_d:jlast+ng_d), vc(jfirst:jlast+1) - - call FVbarrierclock(grid,'sync_c_geop') - if (geopkc16) then - -! -! Stay in yz space and use semi-global z communications and 16-byte reals -! - - call geopk16(grid, pe, ptk, pkcc, wzc, hs, ptc, & - 0, cp, akap) - -! -! Geopk does not need j ghost zones of pkc and wz -! - -!$omp parallel do private(i, j, k) - do k = kfirst, klast+1 - do j = jfirst, jlast - do i = 1, im - pkc(i,j,k) = pkcc(i,j,k) - wz(i,j,k) = wzc(i,j,k) - enddo - enddo - enddo - - else - - call FVstartclock(grid,'---C_GEOP') - - if (grid%twod_decomp == 1) then - -! -! Transpose to xy decomposition -! - -#if defined( SPMD ) - call FVstartclock(grid,'----YZ_TO_XY_C_GEOP') - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, ptk, delpxy, & - a2in=ptc, a2out=ptxy ) - call FVstopclock(grid,'----YZ_TO_XY_C_GEOP') -#endif - - else - -!$omp parallel do private(i, j, k) - do k = kfirst, klast - do j = jfirst, jlast - do i = 1, im - delpxy(i,j,k) = ptk(i,j,k) - ptxy(i,j,k) = ptc(i,j,k) - enddo - enddo - enddo - - endif - - call geopk(grid, pexy, delpxy, pkxy, wzxy, hsxy, ptxy, & - cp, akap, nx) - - if (grid%twod_decomp == 1) then -! -! Transpose back to yz decomposition. -! pexy is not output quantity on this call. -! pkkp and wzkp are holding arrays, whose specific z-dimensions -! are required by Pilgrim. -! Z edge ghost points (klast+1) are automatically filled in -! - -#if defined( SPMD ) - - call FVstartclock(grid,'----XY_TO_YZ_C_GEOP') - call mp_swapirr(commglobal, grid%pkxy_to_pkc%SendDesc, & - grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & - a2in=wzxy, a2out=wzkp) - call FVstopclock(grid,'----XY_TO_YZ_C_GEOP') - -!$omp parallel do private(i, j, k) - do k = kfirst, klast+1 - do j = jfirst, jlast - do i = 1, im - pkc(i,j,k) = pkkp(i,j,k) - enddo - enddo - enddo - -!$omp parallel do private(i, j, k) - do k = kfirst, klast+1 - do j = jfirst, jlast - do i = 1, im - wz(i,j,k) = wzkp(i,j,k) - enddo - enddo - enddo - -#endif - - else - -!$omp parallel do private(i, j, k) - do k = kfirst, klast+1 - do j = jfirst, jlast - do i = 1, im - pkc(i,j,k) = pkxy(i,j,k) - wz(i,j,k) = wzxy(i,j,k) - enddo - enddo - enddo - - endif - - call FVstopclock(grid,'---C_GEOP') - - endif ! geopkc16 - - call FVbarrierclock(grid,'sync_pre_d_core') - call FVstartclock(grid,'---PRE_D_CORE') - -! Upon exit from geopk, the quantities pe, pkc and wz will have been -! updated at klast+1 - - -#if defined( SPMD ) -! -! pkc & wz need to be ghosted only at jfirst-1 -! - call FVstartclock(grid,'----PRE_D_CORE_COMM') - dest = iam+1 - src = iam-1 - if ( mod(iam+1,npr_y) == 0 ) dest = -1 - if ( mod(iam,npr_y) == 0 ) src = -1 - call mp_send3d_2( commglobal, dest, src, im, jm, km+1, & - 1, im, jfirst-1, jlast+1, kfirst, klast+1, & - 1, im, jlast, jlast, kfirst, klast+1, pkc, wz) - call FVstopclock(grid,'----PRE_D_CORE_COMM') -#endif - - - call FVstartclock(grid,'----C_U_LOOP') -! Beware k+1 references directly below (AAM) -! -!$omp parallel do private(i, j, k, p1d, wk, wk2) - -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ PARALLEL DO PRIVATE (I, J, K, P1D, WK, WK2) -#endif - do k=kfirst,klast - do j=js2g0,jn2g0 - do i=1,im - p1d(i) = pkc(i,j,k+1) - pkc(i,j,k) - enddo - - uc(1,j,k) = uc(1,j,k) + grid%dtdx2(j) * ( & - (wz(im,j,k+1)-wz(1,j,k))*(pkc(1,j,k+1)-pkc(im,j,k)) & - + (wz(im,j,k)-wz(1,j,k+1))*(pkc(im,j,k+1)-pkc(1,j,k))) & - / (p1d(1)+p1d(im)) - do i=2,im - uc(i,j,k) = uc(i,j,k) + grid%dtdx2(j) * ( & - (wz(i-1,j,k+1)-wz(i,j,k))*(pkc(i,j,k+1)-pkc(i-1,j,k)) & - + (wz(i-1,j,k)-wz(i,j,k+1))*(pkc(i-1,j,k+1)-pkc(i,j,k))) & - / (p1d(i)+p1d(i-1)) - enddo - - enddo - call pft2d(uc(1,js2g0,k), grid%sc, grid%dc, im, jn2g0-js2g0+1, wk, wk2 ) - if ( jfirst == 1 ) then ! Clean up - do i=1,im - uc(i,1,k) = D0_0 - enddo - endif - if ( jlast == jm ) then ! Clean up - do i=1,im - uc(i,jm,k) = D0_0 - enddo - endif - - enddo -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ END PARALLEL DO -#endif - call FVstopclock(grid,'----C_U_LOOP') - -#if defined( SPMD ) - call FVstartclock(grid,'----PRE_D_CORE_COMM') - call mp_recv3d_2( commglobal, src, im, jm, km+1, & - 1, im, jfirst-1, jlast+1, kfirst, klast+1, & - 1, im, jfirst-1, jfirst-1, kfirst, klast+1, pkc, wz) - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, uc ) - call FVstopclock(grid,'----PRE_D_CORE_COMM') -#endif - - call FVstartclock(grid,'----C_V_PGRAD') -! -! Beware k+1 references directly below (AAM) -! -!$omp parallel do private(i, j, k, wk, wk1 ) - -! pkc and wz need only to be ghosted jfirst-1 - -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ PARALLEL DO PRIVATE (I, J, K, WK, WK1 ) -#endif - do k=kfirst,klast - do j=js1g1,jlast - do i=1,im - wk1(i,j) = pkc(i,j,k+1) - pkc(i,j,k) - enddo - enddo - - do j=js2g0,jlast - do i=1,im - vc(i,j,k) = vc(i,j,k) + grid%dtdy5/(wk1(i,j)+wk1(i,j-1)) * & - ( (wz(i,j-1,k+1)-wz(i,j,k))*(pkc(i,j,k+1)-pkc(i,j-1,k)) & - + (wz(i,j-1,k)-wz(i,j,k+1))*(pkc(i,j-1,k+1)-pkc(i,j,k)) ) - enddo - enddo - - call pft2d(vc(1,js2g0,k), grid%se, & - grid%de, im, jlast-js2g0+1, wk, wk1 ) - enddo -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ END PARALLEL DO -#endif - - call FVstopclock(grid,'----C_V_PGRAD') - -#if defined( SPMD ) - call FVstartclock(grid,'----PRE_D_CORE_COMM') - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, uc ) - -! vc only needs to be ghosted at jlast+1 - dest = iam-1 - src = iam+1 - if ( mod(iam,npr_y) == 0 ) dest = -1 - if ( mod(iam+1,npr_y) == 0 ) src = -1 - call mp_send3d( commglobal, dest, src, im, jm, km, & - 1, im, jfirst-2, jlast+2, kfirst, klast, & - 1, im, jfirst, jfirst, kfirst, klast, vc ) - call mp_recv3d( commglobal, src, im, jm, km, & - 1, im, jfirst-2, jlast+2, kfirst, klast, & - 1, im, jlast+1, jlast+1, kfirst, klast, vc ) - call FVstopclock(grid,'----PRE_D_CORE_COMM') -#endif - - call FVstopclock(grid,'---PRE_D_CORE') - - call FVbarrierclock(grid,'sync_d_core') - - call FVstartclock(grid,'---D_CORE') - -!$omp parallel do private(i, j, k, iord, jord) -#if !defined(USE_OMP) -!CSD$ PARALLEL DO PRIVATE (K, IORD, JORD) -#endif - - do k=kfirst,klast - - if( k <= km/8 ) then - if( k == 1 ) then - iord = 1 - jord = 1 - else - iord = min(2, iord_d) - jord = min(2, jord_d) - endif - else - iord = iord_d - jord = jord_d - endif - -!----------------------------------------------------------------- -! Call the vertical independent part of the dynamics on the D-grid -!----------------------------------------------------------------- - - call d_sw( grid, u(1,jfirst-ng_d,k), v(1,jfirst-ng_s,k), & - uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & - pt(1,jfirst-ng_d,k), delp(1,jfirst,k), & - delpf(1,jfirst-ng_d,k), cx3(1,jfirst-ng_d,k), & - cy3(1,jfirst,k), & - mfx(1,jfirst,k), mfy(1,jfirst,k), & - ptfx(1,jfirst,k), ptfy(1,jfirst,k), & - grid%cdx(js2g0:,k), grid%cdy(js2g0:,k), & - iord, jord, tiny ) - - enddo - -#if !defined(USE_OMP) -!CSD$ END PARALLEL DO -#endif - - call FVstopclock(grid,'---D_CORE') - - call FVbarrierclock(grid,'sync_d_geop') - if (geopkd16) then - -! -! Stay in yz space and use semi-global z communications and 16-byte reals - - call geopk16(grid, pe, delp, pkcc, wzc, hs, pt, & - ng_d, cp, akap) - -! -! Geopk does not need j ghost zones of pkc and wz -! - -!$omp parallel do private(i, j, k) - do k = kfirst, klast+1 - do j = jfirst, jlast - do i = 1, im - pkc(i,j,k) = pkcc(i,j,k) - wz(i,j,k) = wzc(i,j,k) - enddo - enddo - enddo - - - else - - call FVstartclock(grid,'---D_GEOP') - - if (grid%twod_decomp == 1) then -! -! Transpose to xy decomposition -! - -#if defined( SPMD ) - -!$omp parallel do private(i,j,k) - do k=kfirst,klast - do j=jfirst,jlast - do i=1,im - ptc(i,j,k) = pt(i,j,k) - enddo - enddo - enddo - - call FVstartclock(grid,'----YZ_TO_XY_D_GEOP') - call mp_swapirr( commglobal, grid%ijk_yz_to_xy%SendDesc, & - grid%ijk_yz_to_xy%RecvDesc, delp, delpxy, & - a2in=ptc, a2out=ptxy ) - call FVstopclock(grid,'----YZ_TO_XY_D_GEOP') -#endif - - else - -!$omp parallel do private(i,j,k) - do k=kfirst,klast - do j=jfirst,jlast - do i=1,im - delpxy(i,j,k) = delp(i,j,k) - ptxy(i,j,k) = pt(i,j,k) - enddo - enddo - enddo - - endif - - call geopk(grid, pexy, delpxy, pkxy, wzxy, hsxy, ptxy, & - cp, akap, nx) - - if (grid%twod_decomp == 1) then -! -! Transpose back to yz decomposition -! Z edge ghost points (klast+1) are automatically filled in -! pexy is output quantity on last small timestep -! - -#if defined( SPMD ) - - call FVstartclock(grid,'----XY_TO_YZ_D_GEOP') - call mp_swapirr(commglobal, grid%pkxy_to_pkc%SendDesc, & - grid%pkxy_to_pkc%RecvDesc, pkxy, pkkp, & - a2in=wzxy, a2out=wzkp ) - call FVstopclock(grid,'----XY_TO_YZ_D_GEOP') - -!$omp parallel do private(i, j, k) - do k = kfirst, klast+1 - do j = jfirst, jlast - do i = 1, im - pkc(i,j,k) = pkkp(i,j,k) - enddo - enddo - enddo - -!$omp parallel do private(i, j, k) - do k = kfirst, klast+1 - do j = jfirst, jlast - do i = 1, im - wz(i,j,k) = wzkp(i,j,k) - enddo - enddo - enddo -#endif - - else - -!$omp parallel do private(i, j, k) - do k = kfirst, klast+1 - do j = jfirst, jlast - do i = 1, im - pkc(i,j,k) = pkxy(i,j,k) - wz(i,j,k) = wzxy(i,j,k) - enddo - enddo - enddo - - endif - - call FVstopclock(grid,'---D_GEOP') - - endif ! geopkd16 - -! -! Upon exit from geopk, the quantities pe, pkc and wz will have been -! updated at klast+1 - - call FVbarrierclock(grid,'sync_pre_d_pgrad') - call FVstartclock(grid,'---PRE_D_PGRAD') - -#if defined( SPMD ) - call FVstartclock(grid,'----PRE_D_PGRAD_COMM_1') -! Exchange boundary regions on north and south for pkc and wz - call mp_send2_ns( commglobal, im, jm, km+1, jfirst, jlast, & - kfirst, klast+1, 1, pkc, wz) - call FVstopclock(grid,'----PRE_D_PGRAD_COMM_1') -#endif - - if ( ipe /= 1 ) then ! not the last call -! -! Perform some work while sending data on the way -! - - call FVstartclock(grid,'----D_DELP_LOOP') - -!$omp parallel do private(i, j, k, wk, wk2) - -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ PARALLEL DO PRIVATE (I, J, K, WK, WK2) -#endif - do k=kfirst,klast - do j=jfirst,jlast - do i=1,im - delpf(i,j,k) = delp(i,j,k) - enddo - enddo - call pft2d( delpf(1,js2g0,k), grid%sc, & - grid%dc, im, jn2g0-js2g0+1, & - wk, wk2 ) - enddo -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ END PARALLEL DO -#endif - call FVstopclock(grid,'----D_DELP_LOOP') - - else -! Last call -!$omp parallel do private(i, j, k) - do k=kfirst,klast+1 - do j=jfirst,jlast - do i=1,im - pk(i,j,k) = pkc(i,j,k) - enddo - enddo - enddo - endif - -#if defined( SPMD ) - call FVstartclock(grid,'----PRE_D_PGRAD_COMM_1') - call mp_recv2_ns( commglobal, im, jm, km+1, jfirst, jlast, & - kfirst, klast+1, 1, pkc, wz) - if ( ipe /= 1 ) then ! not the last call - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, delpf ) - endif - call FVstopclock(grid,'----PRE_D_PGRAD_COMM_1') -#endif - - -! -! Beware k+1 references directly below (AAM) -! -!$omp parallel do private(i, j, k) - - do k=kfirst,klast - do j=js1g1,jn1g1 ! dpt needed NS - do i=1,im ! wz, pkc ghosted NS - dpt(i,j,k)=(wz(i,j,k+1)+wz(i,j,k))*(pkc(i,j,k+1)-pkc(i,j,k)) - enddo - enddo - enddo - -! GHOSTING: wz (input) NS ; pkc (input) NS - - call FVstopclock(grid,'---PRE_D_PGRAD') - call FVstartclock(grid,'---D_PGRAD_1') - -!$omp parallel do private(i, j, k, wk3, wk1) -#if !defined(USE_OMP) -!CSD$ PARALLEL DO PRIVATE (I, J, K, WK3, WK1) -#endif - do k=kfirst,klast+1 - - if (k == 1) then - do j=js2g0,jlast - do i=1,im - wz3(i,j,1) = D0_0 - wz(i,j,1) = D0_0 - enddo - enddo - pk4 = D4_0*grid%ptop**akap - do j=js2g0,jn1g1 - do i=1,im - pkc(i,j,1) = pk4 - enddo - enddo - go to 4500 - endif - - do j=js2g1,jn2g0 ! wk3 needed S - wk3(1,j) = (wz(1,j,k)+wz(im,j,k)) * & - (pkc(1,j,k)-pkc(im,j,k)) - do i=2,im - wk3(i,j) = (wz(i,j,k)+wz(i-1,j,k)) * & - (pkc(i,j,k)-pkc(i-1,j,k)) - enddo - enddo - - do j=js2g1,jn2g0 - do i=1,im-1 - wk1(i,j) = wk3(i,j) + wk3(i+1,j) - enddo - wk1(im,j) = wk3(im,j) + wk3(1,j) ! wk3 ghosted S - enddo - - if ( jfirst == 1 ) then - do i=1,im - wk1(i, 1) = D0_0 - enddo - endif - - if ( jlast == jm ) then - do i=1,im - wk1(i,jm) = D0_0 - enddo - endif - - do j=js2g0,jlast ! wk1 ghosted S - do i=1,im - wz3(i,j,k) = wk1(i,j) + wk1(i,j-1) - enddo - enddo - -! N-S walls - - do j=js2g0,jn1g1 ! wk1 needed N - do i=1,im ! wz, pkc ghosted NS - wk1(i,j) = (wz(i,j,k)+wz(i,j-1,k))*(pkc(i,j,k)-pkc(i,j-1,k)) - enddo - enddo - - do j=js2g0,jn1g1 ! wk3 needed N - wk3(1,j) = wk1(1,j) + wk1(im,j) ! wk1 ghosted N - do i=2,im - wk3(i,j) = wk1(i,j) + wk1(i-1,j) ! wk1 ghosted N - enddo - enddo - - do j=js2g0,jn2g0 - do i=1,im - wz(i,j,k) = wk3(i,j) + wk3(i,j+1) ! wk3 ghosted N - enddo - enddo - - do j=js1g1,jn1g1 - wk1(1,j) = pkc(1,j,k) + pkc(im,j,k) - do i=2,im - wk1(i,j) = pkc(i,j,k) + pkc(i-1,j,k) - enddo - enddo - - do j=js2g0,jn1g1 - do i=1,im - pkc(i,j,k) = wk1(i,j) + wk1(i,j-1) - enddo - enddo -4500 continue - enddo - -#if !defined(USE_OMP) -!CSD$ END PARALLEL DO -#endif - call FVstopclock(grid,'---D_PGRAD_1') - call FVstartclock(grid,'---D_PGRAD_2') - -! GHOSTING: dpt (loop 4000) NS ; pkc (loop 4500) N -! -! Beware k+1 references directly below (AAM) -! -!$omp parallel do private(i, j, k, wk, wk1, wk2, wk3) -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ PARALLEL DO PRIVATE (i, j, k, wk, wk1, wk2, wk3) -#endif - do 6000 k=kfirst,klast - - do j=js1g1,jn1g1 - wk1(1,j) = dpt(1,j,k) + dpt(im,j,k) - do i=2,im - wk1(i,j) = dpt(i,j,k) + dpt(i-1,j,k) - enddo - enddo - - do j=js2g0,jn1g1 - do i=1,im - wk2(i,j) = wk1(i,j) + wk1(i,j-1) - wk(i,j) = pkc(i,j,k+1) - pkc(i,j,k) - enddo - enddo - - do j=js2g0,jlast - do i=1,im-1 - wk3(i,j) = uc(i,j,k) + grid%dtdxe(j)/(wk(i,j) + wk(i+1,j)) * (wk2(i,j)-wk2(i+1,j)+wz3(i,j,k+1)-wz3(i,j,k)) - duadv(i,j,k) = uc(i,j,k) - dupg (i,j,k) = wk3(i,j) - uc(i,j,k) - enddo - wk3 (im,j) = uc(im,j,k) + grid%dtdxe(j)/(wk(im,j) + wk(1,j)) * (wk2(im,j)-wk2(1,j)+wz3(im,j,k+1)-wz3(im,j,k)) - duadv(im,j,k) = uc(im,j,k) - dupg (im,j,k) = wk3(im,j) - uc(im,j,k) - enddo - - do j=js2g0,jn2g0 ! Assumes wk2 ghosted on N - do i=1,im - wk1(i,j) = vc(i,j,k) + grid%dtdy/(wk(i,j)+wk(i,j+1)) * (wk2(i,j)-wk2(i,j+1)+wz(i,j,k+1)-wz(i,j,k)) - dvadv(i,j,k) = vc(i,j,k) - dvpg (i,j,k) = wk1(i,j) - vc(i,j,k) - enddo - enddo - - call pft2d( wk3 (1,js2g0), grid%se, grid%de, im, jlast-js2g0+1, wk, wk2 ) - call pft2d( wk1 (1,js2g0), grid%sc, grid%dc, im, jn2g0-js2g0+1, wk, wk2 ) - - call pft2d( dupg (1,js2g0,k), grid%se, grid%de, im, jlast-js2g0+1, wk, wk2 ) - call pft2d( dvpg (1,js2g0,k), grid%sc, grid%dc, im, jn2g0-js2g0+1, wk, wk2 ) - call pft2d( duadv(1,js2g0,k), grid%se, grid%de, im, jlast-js2g0+1, wk, wk2 ) - call pft2d( dvadv(1,js2g0,k), grid%sc, grid%dc, im, jn2g0-js2g0+1, wk, wk2 ) - - do j=js2g0,jn2g0 - do i=1,im - ubar(i,j,k) = u(i,j,k) + 0.5_r8*( dupg(i,j,k)+duadv(i,j,k) ) - vbar(i,j,k) = v(i,j,k) + 0.5_r8*( dvpg(i,j,k)+dvadv(i,j,k) ) - v(i,j,k) = v(i,j,k) + wk1(i,j) - u(i,j,k) = u(i,j,k) + wk3(i,j) - enddo - enddo - - if ( jlast == jm ) then - do i=1,im - ubar(i,jlast,k) = u(i,jlast,k) + 0.5_r8*( dupg(i,jlast,k)+duadv(i,jlast,k) ) - u(i,jlast,k) = u(i,jlast,k) + wk3(i,jlast) - enddo - endif - -6000 continue -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ END PARALLEL DO -#endif - call FVstopclock(grid,'---D_PGRAD_2') - -#if defined( SPMD ) - if ( ipe /= 1 ) then - call FVstartclock(grid,'---PRE_D_PGRAD_COMM_2') - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_d, delpf ) - call FVstopclock(grid,'---PRE_D_PGRAD_COMM_2') - endif -#endif - -! Ghost Final D-Grid Wind Variables for use in D2A2C and other Utilities -! ---------------------------------------------------------------------- - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, u ) - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, v ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_s, ng_d, u ) - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng_d, ng_s, v ) - - return -!EOC - end subroutine cd_core -!----------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/diag_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/diag_module.F90 deleted file mode 100644 index 062e0e94f..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/diag_module.F90 +++ /dev/null @@ -1,221 +0,0 @@ -!----------------------------------------------------------------------- -! -! BOP -! -! !MODULE: -module diag_module -! -! !DESCRIPTION -! Utilities which perform special calculations for diagnostics -! Currently only compute\_vdot\_grad to calculate total derivative -! -! !PUBLIC MEMBER FUNCTIONS - public :: compute_vdot_gradp - -! !REVISION HISTORY: -! 05.09.10 Rasch Creation of compute_vdot_gradp -! 05.10.18 Sawyer Revisions for 2D decomp, placed in module -! 07.01.29 Chen Removed pft2d calculation for OMGA (is in cd_core) -! 09.04.01 Sawyer Upgraded to PILGRIM from cam3_6_33 -! -! EOP -!----------------------------------------------------------------------- - private - -CONTAINS - - subroutine compute_vdot_gradp(grid, dt, frac, cx, cy, pexy, omgaxy ) - - use shr_kind_mod, only : r8 => shr_kind_r8 - use dynamics_vars, only : T_FVDYCORE_GRID -#if defined( SPMD ) - use mod_comm, only: commglobal, mp_send3d, mp_recv3d, mp_swapirr -#endif - - implicit none - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - real(r8), intent(in):: dt - real(r8), intent(in):: frac - - real(r8), intent(in):: cx(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - real(r8), intent(in):: cy(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) - real(r8), target, intent(in):: & - pexy(grid%ifirstxy:grid%ilastxy,grid%km+1,grid%jfirstxy:grid%jlastxy) ! P (pascal) at layer edges - real(r8), target, intent(inout):: & - omgaxy(grid%ifirstxy:grid%ilastxy,grid%km,grid%jfirstxy:grid%jlastxy) ! vert. press. velocity (pa/sec) - -! Local - integer :: im ! dimension in east-west - integer :: jm ! dimension in North-South - integer :: km ! number of Lagrangian layers - integer :: jfirst ! starting latitude index for MPI - integer :: jlast ! ending latitude index for MPI - integer :: kfirst ! starting level index for MPI - integer :: klast ! ending level index for MPI - integer :: js2g0 ! j==1 not included - integer :: jn2g0 ! j==jm not included - - real(r8) :: pm(grid%im, grid%jfirst-1:grid%jlast+1) - real(r8) :: grad(grid%im, grid%jfirst:grid%jlast+1) - real(r8) :: fac, sum1 - - real(r8), pointer :: pe(:,:,:) ! YZ version of edge pressures - real(r8), pointer :: omga(:,:,:) ! YZ version of vert. vel. - - real(r8), parameter :: half = 0.5_r8 - real(r8), parameter :: zero = 0.0_r8 - - integer :: i,j,k - -#if defined( SPMD ) - integer :: iam, dest, src, npr_y - real(r8) :: penorth(grid%im, grid%kfirst:grid%klast+1) - real(r8) :: pesouth(grid%im, grid%kfirst:grid%klast+1) -#endif - - im = grid%im - jm = grid%jm - km = grid%km - jfirst = grid%jfirst - jlast = grid%jlast - kfirst = grid%kfirst - klast = grid%klast - js2g0 = grid%js2g0 - jn2g0 = grid%jn2g0 - - fac = half / (dt * frac) - -#if defined( SPMD ) - if ( grid%twod_decomp == 1 ) then - allocate(pe(im,kfirst:klast+1,jfirst:jlast)) - allocate(omga(im,kfirst:klast,jfirst:jlast)) - call mp_swapirr( commglobal, grid%ikj_xy_to_yz%SendDesc, & - grid%ikj_xy_to_yz%RecvDesc, omgaxy, omga) - call mp_swapirr( commglobal, grid%pexy_to_pe%SendDesc, & - grid%pexy_to_pe%RecvDesc, pexy, pe ) - else - pe => pexy - omga => omgaxy - endif - iam = grid%iam - npr_y = grid%npr_y - dest = iam+1 - src = iam-1 - if ( mod(iam+1,npr_y) == 0 ) dest = -1 - if ( mod(iam,npr_y) == 0 ) src = -1 - -! -! Have to give more thought to the source and destination for 2D -! - call mp_send3d(commglobal, dest, src, im, km+1, jm, & - 1, im, kfirst, klast+1, jfirst, jlast, 1, & - im, kfirst, klast+1, jlast, jlast, pe) - call mp_recv3d(commglobal, src, im, km+1, jm, & - 1, im, kfirst, klast+1, jfirst-1, jfirst-1, & - 1, im, kfirst, klast+1, jfirst-1, jfirst-1, pesouth) - call mp_send3d(commglobal, src, dest, im, km+1, jm, & - 1, im, kfirst, klast+1, jfirst, jlast, & - 1, im, kfirst, klast+1, jfirst, jfirst, pe) - call mp_recv3d(commglobal, dest, im, km+1, jm, & - 1, im, kfirst, klast+1, jlast+1, jlast+1, & - 1, im, kfirst, klast+1, jlast+1, jlast+1, penorth) -#else - pe => pexy - omga => omgaxy -#endif - -!$omp parallel do private(i,j,k,pm,grad, sum1) - do k=kfirst,klast - -! Compute layer mean p - do j=jfirst,jlast - do i=1,im - pm(i,j) = half * ( pe(i,k,j) + pe(i,k+1,j) ) - enddo - enddo - -#if defined( SPMD ) - if ( jfirst/=1 ) then - do i=1,im - pm(i,jfirst-1) = half * ( pesouth(i,k) + pesouth(i,k+1)) - enddo - endif - - if ( jlast/=jm ) then - do i=1,im - pm(i,jlast+1) = half * ( penorth(i,k) + penorth(i,k+1)) - enddo - endif -#endif - - do j=js2g0,jn2g0 - i=1 - grad(i,j) = fac * cx(i,j,k) * (pm(i,j)-pm(im,j)) - do i=2,im - grad(i,j) = fac * cx(i,j,k) * (pm(i,j)-pm(i-1,j)) - enddo - enddo - - do j=js2g0,jn2g0 - do i=1,im-1 - omga(i,k,j) = omga(i,k,j) + grad(i,j) + grad(i+1,j) - enddo - i=im - omga(i,k,j) = omga(i,k,j) + grad(i,j) + grad(1,j) - enddo - - do j=js2g0,min(jm,jlast+1) - do i=1,im - grad(i,j) = fac * cy(i,j,k) * (pm(i,j)-pm(i,j-1)) - enddo - enddo - - do j=js2g0,jn2g0 - do i=1,im - omga(i,k,j) = omga(i,k,j) + grad(i,j) + grad(i,j+1) - enddo - enddo - -! Note: Since V*grad(P) at poles are harder to compute accurately we use the average of sourding points -! to be used as input to physics. - - if ( jfirst==1 ) then - sum1 = zero - do i=1,im - sum1 = sum1 + omga(i,k,2) - enddo - sum1 = sum1 / real(im,r8) - do i=1,im - omga(i,k,1) = sum1 - enddo - endif - - if ( jlast==jm ) then - sum1 = zero - do i=1,im - sum1 = sum1 + omga(i,k,jm-1) - enddo - sum1 = sum1 / real(im,r8) - do i=1,im - omga(i,k,jm) = sum1 - enddo - endif - enddo - -#if defined( SPMD) - if ( grid%twod_decomp == 1 ) then -! -! Transpose back to XY (if 1D, the changes to omgaxy were made in place) -! - call mp_swapirr(commglobal, grid%ikj_yz_to_xy%SendDesc, & - grid%ikj_yz_to_xy%RecvDesc, omga, omgaxy) - deallocate( pe ) - deallocate( omga ) - endif -#endif - - end subroutine compute_vdot_gradp - -end module diag_module diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/dynamics_vars.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/dynamics_vars.F90 deleted file mode 100644 index 2f8b6d509..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/dynamics_vars.F90 +++ /dev/null @@ -1,2305 +0,0 @@ -module dynamics_vars -!BOP -! -! !MODULE: dynamics_vars --- GEOS5/CAM fvcore internal variables -! -! !USES: - use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 -#if defined( MAPL_MODE ) - use ESMF - use MAPL - use G3_MPI_Util_Mod -#endif - -! - use decompmodule, only: decomptype - use ghostmodule, only: ghosttype -#if defined(SPMD) - use parutilitiesmodule, only: parpatterntype, REAL4, INT4 -#endif - -! !PUBLIC MEMBER FUNCTIONS: - public dynamics_init, dynamics_clean - public a2d3d, d2a3d, b2d3d, d2b3d, c2a3d - -! !PUBLIC DATA MEMBERS: - - public T_TRACERS, T_FVDYCORE_VARS, T_FVDYCORE_GRID, T_FVDYCORE_STATE - - type T_TRACERS - logical :: is_r4 - real(r8), dimension(:,:,: ), pointer :: content => NULL() - real(r4), dimension(:,:,: ), pointer :: content_r4 => NULL() - end type T_TRACERS - -! T_FVDYCORE_VARS contains the prognostic variables for FVdycore - type T_FVDYCORE_VARS - real(r8), dimension(:,:,: ), pointer :: U => NULL() ! U winds (D-grid) - real(r8), dimension(:,:,: ), pointer :: V => NULL() ! V winds (D-grid) - real(r8), dimension(:,:,: ), pointer :: PT => NULL() ! scaled virtual pot. temp. - real(r8), dimension(:,:,: ), pointer :: PE => NULL() ! Pressure at layer edges - real(r8), dimension(:,:,: ), pointer :: PKZ => NULL() ! P^kappa mean - type(T_TRACERS), dimension(:), pointer :: tracer => NULL() ! Tracers - end type T_FVDYCORE_VARS - -! T_FVDYCORE_GRID contains information about the horizontal and vertical -! discretization, unlike in ARIES where these data are split into HORZ_GRID -! and VERT_GRID. The reason for this: currently all of this information is -! initialized in one call to FVCAM dynamics_init. - - type T_FVDYCORE_GRID -! -#if defined( MAPL_MODE ) - type (MAPL_MetaComp), pointer :: FVgenstate - type (ESMF_Grid) :: GRIDXY ! The 'horizontal' grid (2D decomp only) - type (ESMF_Grid) :: GRIDYZ ! The latitude-level grid - type (dynamics_lattice_type) :: lattice -#endif - -! -! PILGRIM communication information (was in spmd_dyn) -! - integer :: twod_decomp = 0 ! 1 for multi-2D decompositions, 0 otherwise - - integer :: myid_y = 0 ! subdomain index (0-based) in latitude (y) - integer :: myid_z = 0 ! subdomain index (0 based) in level (z) - integer :: npr_y = 1 ! number of subdomains in y - integer :: npr_z = 1 ! number of subdomains in z - - integer :: myidxy_x = 0 ! subdomain index (0-based) in longitude (x) (second. decomp.) - integer :: myidxy_y = 0 ! subdomain index (0 based) in latitude (y) (second. decomp.) - integer :: nprxy_x = 1 ! number of subdomains in x (second. decomp.) - integer :: nprxy_y = 1 ! number of subdomains in y (second. decomp.) - integer :: iam = 0 ! - - integer :: mod_method = 0 ! 1 for mpi derived types with transposes, 0 for contiguous buffers - integer :: mod_geopk = 0 ! 1 for mpi derived types with transposes, 0 for contiguous buffers - integer :: mod_gatscat = 0 ! 1 for mpi derived types with transposes, 0 for contiguous buffers - - type(decomptype) :: strip2d, strip2dx, strip3dxyz, strip3dxzy, & - strip3dxyzp, strip3zaty, strip3dxzyp, & - strip3yatz, strip3yatzp, strip3zatypt, & - strip3kxyz, strip3kxzy, strip3kxyzp, strip3kxzyp, & - strip3dyz, checker3kxy - - integer :: comm_y ! communicator in latitude - integer :: comm_z ! communicator in vertical - integer :: commxy_x ! communicator in longitude (xy second. decomp.) - integer :: commxy_y ! communicator in latitude (xy second. decomp.) - logical :: geopk16byte ! method for geopotential calculation with 2D decomp. - -#if defined(SPMD) - type (ghosttype) :: ghostu_yz, ghostv_yz, ghostpt_yz, & - ghostpe_yz, ghostpkc_yz - type (parpatterntype) :: u_to_uxy, uxy_to_u, v_to_vxy, vxy_to_v, & - ikj_yz_to_xy, ikj_xy_to_yz, ijk_yz_to_xy, & - ijk_xy_to_yz, pe_to_pexy, pexy_to_pe, & - pt_to_ptxy, ptxy_to_pt, pkxy_to_pkc, & - r4_xy_to_yz, r4_yz_to_xy, q3_to_qxy3, qxy3_to_q3, & - xy2d_to_yz2d, yz2d_to_xy2d, scatter_3d, gather_3d, & - g_2dxy_r8, g_2dxy_r4, g_2dxy_i4, & - s_2dxy_r8, s_2dxy_r4, s_2dxy_i4, & - g_3dxyz_r8, g_3dxyz_r4, g_3dxyzp_r8, g_3dxyzp_r4, & - s_3dxyz_r8, s_3dxyz_r4, s_3dxyzp_r8, s_3dxyzp_r4 -#endif - -! -! END PILGRIM communication information -! - - integer :: JFIRST ! Start latitude (exclusive) - integer :: JLAST ! End latitude (exclusive) - -! - integer :: NG_C ! Ccore ghosting - integer :: NG_D ! Dcore ghosting - integer :: NG_S ! Staggered grid ghosting for - ! certain arrays, max(ng_c+1,ng_d) -! -! For 2D decomposition (currently not used) -! - integer :: IFIRSTXY ! Start longitude (exclusive) - integer :: ILASTXY ! End longitude (exclusive) - integer :: JFIRSTXY ! Start latitude (exclusive) - integer :: JLASTXY ! End latitude (exclusive) -! - integer :: IM ! Full longitude dim - integer :: JM ! Full latitude dim (including poles) -! - real(r8) :: DL - real(r8) :: DP - real(r8) :: ACAP - real(r8) :: RCAP -! - real(r8), dimension(:), pointer :: COSP => NULL() ! Cosine of lat angle -- volume mean - real(r8), dimension(:), pointer :: SINP => NULL() ! Sine of lat angle -- volume mean - real(r8), dimension(:), pointer :: COSE => NULL() ! Cosine at finite volume edge - real(r8), dimension(:), pointer :: SINE => NULL() ! Sine at finite volume edge - real(r8), dimension(:), pointer :: ACOSP => NULL() ! Reciprocal of cosine of lat angle -! - real(r8), dimension(:), pointer :: ACOSU => NULL() ! Reciprocal of cosine of lat angle (staggered) -! - real(r8), dimension(:), pointer :: COSLON => NULL() ! Cosine of longitudes - volume center - real(r8), dimension(:), pointer :: SINLON => NULL() ! Sine of longitudes - volume center - real(r8), dimension(:), pointer :: COSL5 => NULL() ! Cosine of longitudes - volume center - real(r8), dimension(:), pointer :: SINL5 => NULL() ! Sine of longitudes - volume center - -! -! Variables which are used repeatedly in CD_CORE -! - - integer :: js2g0 - integer :: jn2g0 - integer :: jn1g1 - - real(r8), pointer :: trigs(:) => NULL() - real(r8), pointer :: fc(:) => NULL() - real(r8), pointer :: f0(:) => NULL() - real(r8), pointer :: dc(:,:) => NULL() - real(r8), pointer :: de(:,:) => NULL() - real(r8), pointer :: sc(:) => NULL() - real(r8), pointer :: se(:) => NULL() - real(r8), pointer :: cdx(:,:) => NULL() - real(r8), pointer :: cdy(:,:) => NULL() - real(r8), pointer :: dtdx(:) => NULL() - real(r8), pointer :: dtdxe(:) => NULL() - real(r8), pointer :: txe5(:) => NULL() - real(r8), pointer :: dtxe5(:) => NULL() - real(r8), pointer :: dyce(:) => NULL() - real(r8), pointer :: dx(:) => NULL() - real(r8), pointer :: rdx(:) => NULL() - real(r8), pointer :: cy(:) => NULL() - real(r8), pointer :: dtdx2(:) => NULL() - real(r8), pointer :: dtdx4(:) => NULL() - real(r8), pointer :: dxdt(:) => NULL() - real(r8), pointer :: dxe(:) => NULL() - real(r8), pointer :: cye(:) => NULL() - real(r8), pointer :: dycp(:) => NULL() - real(r8), pointer :: rdxe(:) => NULL() - - real(r8) :: rdy, dtdy, dydt, dtdy5, tdy5 - real(r8) :: dt0 = 0 - - integer :: ifax(13) - - real(r8) :: zt_c - real(r8) :: zt_d - -! -! This part refers to the vertical grid -! - integer :: KM ! Numer of levels - integer :: KMAX ! KM+1 (?) -! -! For 2D decomposition (currently not used) -! - integer :: KFIRST ! Start level (exclusive) - integer :: KLAST ! End level (exclusive) - integer :: KLASTP ! klast+1, except km+1 when klastp=km+1 -! -! - integer :: KORD ! monotonicity order for mapping (te_map) - integer :: KS ! Number of true pressure levels (out of KM+1) - real(r8) :: PTOP ! pressure at top (ak(1)) - real(r8) :: PINT ! initial pressure (ak(km+1)) - real(r8), dimension(:), pointer :: AK ! Sigma mapping - real(r8), dimension(:), pointer :: BK ! Sigma mapping - -! -! Tracers -! - integer :: NQ ! Number of advected tracers - integer :: NTOTQ ! Total number of tracers (NQ <= NC) - end type T_FVDYCORE_GRID - -! Constants used by fvcore - type T_FVDYCORE_CONSTANTS - real(r8) :: pi - real(r8) :: omega ! angular velocity of earth's rotation - real(r8) :: cp ! heat capacity of air at constant pressure - real(r8) :: ae ! radius of the earth (m) - real(r8) :: rair ! Gas constant of the air - real(r8) :: cappa ! Cappa? - real(r8) :: zvir ! RWV/RAIR-1 - end type T_FVDYCORE_CONSTANTS - - integer, parameter :: NUM_FVDYCORE_ALARMS = 3 - integer, parameter :: NUM_TIMES = 8 - - type T_FVDYCORE_STATE -!!! private - type (T_FVDYCORE_VARS) :: VARS - type (T_FVDYCORE_GRID ) :: GRID - type (T_FVDYCORE_CONSTANTS) :: CONSTANTS -#if defined( MAPL_MODE ) - type (ESMF_Clock), pointer :: CLOCK - type (ESMF_Alarm) :: ALARMS(NUM_FVDYCORE_ALARMS) -#endif - integer(kind=8) :: RUN_TIMES(4,NUM_TIMES) - logical :: DOTIME, DODYN - real(r8) :: DT ! Large time step - real(r8) :: CHECK_DT ! Time step to check maxmin - integer :: ICD, JCD ! Algorithm orders (C Grid) - integer :: IORD, JORD ! Algorithm orders (D Grid) - integer :: KORD ! Vertical order - integer :: TE_METHOD ! method for total energy mapping (te_map) - logical :: CONSV ! dycore conserves tot. en. - integer :: NSPLIT - integer :: NUM_CALLS - end type T_FVDYCORE_STATE - -! -! !DESCRIPTION: -! -! This module provides variables which are specific to the Lin-Rood -! dynamical core. Most of them were previously SAVE variables in -! different routines and were set with an "if (first)" statement. -! -! \begin{tabular}{|l|l|} \hline \hline -! lr\_init & Initialize the Lin-Rood variables \\ \hline -! lr\_clean & Deallocate all internal data structures \\ \hline -! \hline -! \end{tabular} -! -! !REVISION HISTORY: -! 01.06.06 Sawyer Consolidated from various code snippets -! 01.07.12 Sawyer Removed CCM common blocks comtim.h and commap.h -! 03.06.25 Sawyer Cleaned up, used ParPatternCopy (Create) -! 03.07.23 Sawyer Removed dependencies on params.h, constituents -! 03.08.05 Sawyer Removed rayf_init and hswf_init, related vars -! 03.09.17 Sawyer Removed unneeded ghost definitions -! 03.10.22 Sawyer pmgrid removed (now spmd_dyn) -! 03.11.18 Sawyer Removed set_eta (ak, bk, now read from restart) -! 03.12.04 Sawyer Moved T_FVDYCORE_GRID here (removed some vars) -! 04.08.25 Sawyer Removed all module data members, now GRID only -! 04.10.06 Sawyer Added spmd_dyn vars here; ESMF transpose vars -! 05.04.12 Sawyer Added support for r4/r8 tracers -! 05.05.24 Sawyer CAM/GEOS5 merge (removed GEOS_mod dependencies) -! 05.06.10 Sawyer Scaled down version for CAM (no ESMF) -! 05.11.10 Sawyer Removed dyn_interface (now in dyn_comp) -! 06.03.01 Sawyer Removed m_ttrans, q_to_qxy, qxy_to_q, etc. -! 06.05.09 Sawyer Added CONSV to dyn_state (conserve energy) -! 06.08.27 Sawyer Removed unused ESMF code for RouteHandle -! -!EOP -!----------------------------------------------------------------------- - real(r8), parameter :: D0_0 = 0.0_r8 - real(r8), parameter :: D0_5 = 0.5_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D2_0 = 2.0_r8 - real(r8), parameter :: D4_0 = 4.0_r8 - real(r8), parameter :: D180_0 = 180.0_r8 - real(r8), parameter :: ratmax = 0.81_r8 - - -contains - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: dynamics_init --- initialize the lin-rood dynamical core -! -! !INTERFACE: - subroutine dynamics_init( dt_in, jord_in, im_in, jm_in, km_in, & - pi_in, ae_in, om_in, nq_in, ntotq_in, & - ks_in, ifirstxy_in, ilastxy_in, & - jfirstxy_in, jlastxy_in, & - jfirst_in, jlast_in, & - kfirst_in, klast_in, & - nprxy_x_in, nprxy_y_in, & - npryz_y_in, npryz_z_in, & - imxy_in, jmxy_in, jmyz_in, kmyz_in, & - ak_in, bk_in, unit, & - grid ) -! !USES: - implicit none - -! !INPUT PARAMETERS: - real(r8), intent(in) :: dt_in ! Initial time step - integer, intent(in) :: jord_in ! Horz. scheme # - integer, intent(in) :: im_in, jm_in, km_in ! Global dims - real(r8), intent(in) :: pi_in ! Pi - real(r8), intent(in) :: ae_in ! Earth radius - real(r8), intent(in) :: om_in ! Earth angular velocity - integer, intent(in) :: nq_in ! No. adv. tracers - integer, intent(in) :: ntotq_in ! No. total tracers - integer, intent(in) :: ks_in ! True # pressure levels - integer, intent(in) :: ifirstxy_in, ilastxy_in ! Interval - integer, intent(in) :: jfirstxy_in, jlastxy_in ! Interval - integer, intent(in) :: jfirst_in, jlast_in ! Interval - integer, intent(in) :: kfirst_in, klast_in ! Interval - integer, intent(in) :: nprxy_x_in ! XY decomp - Nr in X - integer, intent(in) :: nprxy_y_in ! XY decomp - Nr in Y - integer, intent(in) :: npryz_y_in ! YZ decomp - Nr in Y - integer, intent(in) :: npryz_z_in ! YZ decomp - Nr in Z - - integer, dimension(:), intent(in) :: imxy_in - integer, dimension(:), intent(in) :: jmxy_in - integer, dimension(:), intent(in) :: jmyz_in - integer, dimension(:), intent(in) :: kmyz_in - - real(r8), dimension(:), intent(in) :: ak_in - real(r8), dimension(:), intent(in) :: bk_in - - integer, intent(in) :: unit - -! !INPUT/OUTPUT PARAMETERS: - type(T_FVDYCORE_GRID), intent(inout) :: grid ! Resulting grid - include 'mpif.h' - -! !DESCRIPTION: -! -! Initialize Lin-Rood specific variables -! -! !REVISION HISTORY: -! -! 01.06.06 Sawyer Create -! 03.07.31 Sawyer Added the 'layout' arguments -! 03.08.05 Sawyer Removed hswf_init and rayf_init -! 04.08.25 Sawyer Added GRID, contains all information -! 04.10.04 Sawyer Added init_spmd here -! 06.03.01 Sawyer Removed argument m_ttrans_in -! 06.11.27 Sawyer Removed argument layout (no longer used) -! 06.11.29 Sawyer Constant PI now passed as argument -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -!!! real(r8) :: pi !WS 29.11.2006 -- uncomment this for zero diffs - integer :: rc - integer :: n1,n2 - -! Set the basic grid variables - - grid%im = im_in - grid%jm = jm_in - grid%km = km_in - grid%kmax = km_in + 1 - grid%nq = nq_in - grid%ntotq = ntotq_in - grid%ks = ks_in - grid%ifirstxy = ifirstxy_in - grid%ilastxy = ilastxy_in - grid%jfirstxy = jfirstxy_in - grid%jlastxy = jlastxy_in - grid%jfirst = jfirst_in - grid%jlast = jlast_in - grid%kfirst = kfirst_in - grid%klast = klast_in - if ( klast_in == km_in ) then - grid%klastp = km_in+1 - else - grid%klastp = klast_in - endif - -!WS 29.11.2006 -- uncomment this for zero diffs -!!! pi = D4_0 * atan(D1_0) -!!! call dynpkg_init( pi, ae_in, om_in, dt_in, im_in, & - call dynpkg_init( pi_in, ae_in, om_in, dt_in, im_in, & - jm_in, jord_in, grid ) - -! -! Level-dependent variables (was in vert_init, now removed) -! - ALLOCATE(GRID%AK(km_in+1)) - ALLOCATE(GRID%BK(km_in+1)) - - GRID%AK = AK_IN - GRID%BK = BK_IN - GRID%PTOP = GRID%AK(1) - GRID%PINT = GRID%AK(ks_in+1) - -#if defined( SPMD ) - call spmd_vars_init( nprxy_x_in, nprxy_y_in, & - npryz_y_in, npryz_z_in, & - imxy_in, jmxy_in, jmyz_in, kmyz_in, nq_in, & - grid ) -#endif - - call create_dynamics_lattice ( grid%lattice,mpi_comm_world,im_in,jm_in,km_in,nprxy_x_in,nprxy_y_in ) - - n1 = grid%lattice%im(grid%lattice%pei) - n2 = ilastxy_in-ifirstxy_in+1 - if( n1.ne.n2 ) call my_exit (101) - n1 = grid%lattice%jm(grid%lattice%pej) - n2 = jlastxy_in-jfirstxy_in+1 - if( n1.ne.n2 ) call my_exit (102) - - return - -CONTAINS - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: dynpkg_init --- Initialization for dynamics package -! -! !INTERFACE: -subroutine dynpkg_init( pi, ae, om, dt, im, jm, jord, grid ) - -! !USES: - use pft_module, only : pftinit, pft2d, pft_cf - implicit none - -! !INPUT PARAMETERS: - real(r8) , intent(in) :: pi - real(r8) , intent(in) :: ae - real(r8) , intent(in) :: om - real(r8) , intent(in) :: dt - integer, intent(in) :: im - integer, intent(in) :: jm - integer, intent(in) :: jord - -! !INPUT/OUTPUT PARAMETERS: - type( T_FVDYCORE_GRID ), intent(inout) :: grid - - -! !DESCRIPTION: -! -! {\bf Purpose:} Initialization of the FV specific GRID vars -! -! !REVISION HISTORY: -! 00.01.10 Grant Creation using code from SJ Lin -! 01.03.26 Sawyer Added ProTeX documentation -! 01.06.06 Sawyer Modified for dynamics_vars -! 04.08.25 Sawyer Now updates GRID -! 05.06.30 Sawyer Added initializations from cd_core -! 06.09.15 Sawyer PI now passed as argument -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer :: i, j, imh, js2g0, jn2g0, jn1g1, js2gc, jn1gc - real(r8) :: zam5, zamda - real(r8) :: ph5 ! This is to ensure 64-bit for any choice of r8 - - real(r8), pointer :: coslon(:), sinlon(:), cosl5(:), sinl5(:) - real(r8), pointer :: cosp(:), sinp(:), cose(:), sine(:), acosp(:), acosu(:) - -! -! Local variables from cd_core -! - - integer :: icffta - real(r8) :: rcffta - - real(r8) :: rat, ycrit, dt5 - -! -! Start initialization -! - grid%dl = (pi+pi)/im - grid%dp = pi/(jm-1) - - allocate(grid%cosp(jm)) - allocate(grid%sinp(jm)) - allocate(grid%cose(jm)) - allocate(grid%sine(jm)) - allocate(grid%acosp(jm)) - allocate(grid%acosu(jm)) - - allocate(grid%coslon(im)) - allocate(grid%sinlon(im)) - allocate(grid%cosl5(im)) - allocate(grid%sinl5(im)) - - cosp => grid%cosp - sinp => grid%sinp - cose => grid%cose - sine => grid%sine - acosp => grid%acosp - acosu => grid%acosu - - coslon => grid%coslon - sinlon => grid%sinlon - cosl5 => grid%cosl5 - sinl5 => grid%sinl5 - - do j=2,jm - ph5 = -D0_5*pi + ((j-1)-D0_5)*(pi/(jm-1)) - sine(j) = sin(ph5) - enddo - - cosp( 1) = D0_0 - cosp(jm) = D0_0 - - do j=2,jm-1 - cosp(j) = (sine(j+1)-sine(j)) / grid%dp - enddo - -! Define cosine at edges.. - - do j=2,jm - cose(j) = D0_5 * (cosp(j-1) + cosp(j)) - enddo - cose(1) = cose(2) - - do j=2,jm-1 - acosu(j) = D2_0 / (cose(j) + cose(j+1)) - enddo - - sinp( 1) = -D1_0 - sinp(jm) = D1_0 - - do j=2,jm-1 - sinp(j) = D0_5 * (sine(j) + sine(j+1)) - enddo - - -! -! Pole cap area and inverse - grid%acap = im*(D1_0+sine(2)) / grid%dp - grid%rcap = D1_0 / grid%acap - - imh = im/2 - if(im .ne. 2*imh) then - write(6,*) 'im must be an even integer' - stop - endif - -! Define logitude at the center of the volume -! i=1, Zamda = -pi - - do i=1,imh - zam5 = ((i-1)-D0_5) * grid%dl - cosl5(i) = cos(zam5) - cosl5(i+imh) = -cosl5(i) - sinl5(i) = sin(zam5) - sinl5(i+imh) = -sinl5(i) - zamda = (i-1)*grid%dl - coslon(i) = cos(zamda) - coslon(i+imh) = -coslon(i) - sinlon(i) = sin(zamda) - sinlon(i+imh) = -sinlon(i) - enddo - - do j=2,jm-1 - acosp(j) = D1_0 / cosp(j) - enddo - acosp( 1) = grid%rcap * im - acosp(jm) = grid%rcap * im - -#if defined( SPMD ) -! -! Calculate the ghost region sizes for the SPMD version (tricky stuff) -! - grid%ng_c = 2 ! Avoid the case where ng_c = 1 - grid%ng_d = min( abs(jord), 3) ! SJL: number of max ghost latitudes - grid%ng_d = max( grid%ng_d, 2) - grid%ng_s = max( grid%ng_c+1, grid%ng_d ) -#else - grid%ng_c = 0 - grid%ng_d = 0 ! No ghosting necessary for pure SMP runs - grid%ng_s = 0 -#endif - -! -! cd_core initializations -! - - allocate(grid%dtdx(jm)) ; grid%dtdx(:) = 1 ! To prevent divide by zero at poles - allocate(grid%dtdx2(jm)) - allocate(grid%dtdx4(jm)) - allocate(grid%dtdxe(jm)) - allocate(grid%dxdt(jm)) - allocate(grid%dxe(jm)) - allocate(grid%cye(jm)) - allocate(grid%dycp(jm)) - allocate(grid%rdxe(jm)) - allocate(grid%txe5(jm)) - allocate(grid%dtxe5(jm)) - allocate(grid%dyce(jm)) - allocate(grid%dx(jm)) - allocate(grid%rdx(jm)) - allocate(grid%cy(jm)) - - js2g0 = max(2,grid%jfirst) - jn2g0 = min(jm-1,grid%jlast) - jn1g1 = min(jm,grid%jlast+1) - js2gc = max(2,grid%jfirst-grid%ng_c) ! NG lats on S (starting at 2) - jn1gc = min(jm,grid%jlast+grid%ng_c) ! ng_c lats on N (ending at jm) - - grid%js2g0 = js2g0 - grid%jn2g0 = jn2g0 - grid%jn1g1 = jn1g1 - - allocate(grid%sc(js2g0:jn2g0)) - allocate(grid%se(js2g0:jn1g1)) - allocate(grid%dc(im,js2g0:jn2g0)) - allocate(grid%de(im,js2g0:jn1g1)) - - call pftinit(im) - -! Determine ycrit such that effective DX >= DY - rat = real(im,r8)/real(2*(jm-1),r8) - ycrit = acos( min(ratmax, rat) ) * (D180_0/pi) - - call pft_cf(im, jm, js2g0, jn2g0, jn1g1, & - grid%sc, grid%se, grid%dc, grid%de, & - grid%cosp, grid%cose, ycrit) - - allocate( grid%cdx(js2g0:jn1g1,grid%kfirst:grid%klast) ) - allocate( grid%cdy(js2g0:jn1g1,grid%kfirst:grid%klast) ) - -! 000304 bug fix: ng_s not ng_d - allocate( grid%f0(grid%jfirst-grid%ng_s-1:grid%jlast+grid%ng_d) ) - allocate( grid%fc(js2gc:jn1gc) ) - -! 000304 bug fix - do j=max(1,grid%jfirst-grid%ng_s-1),min(jm,grid%jlast+grid%ng_d) - grid%f0(j) = (om+om)*grid%sinp(j) - enddo - -! Compute coriolis parameter at cell corners. - do j=js2gc, jn1gc ! Not the issue with ng_c = ng_d - grid%fc(j) = D0_5*(grid%f0(j) + grid%f0(j-1)) - enddo - -!!! grid%dt0 = dt - grid%dt0 = D0_0 - dt5 = D0_5*dt - - grid%rdy = D1_0/(ae*grid%dp) - grid%dtdy = dt *grid%rdy - grid%dtdy5 = dt5*grid%rdy - grid%dydt = (ae*grid%dp) / dt - grid%tdy5 = D0_5/grid%dtdy - - return -!EOC -end subroutine dynpkg_init -!----------------------------------------------------------------------- - -#if defined(SPMD) -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: spmd_vars_init --- Initialization of SPMD-related variables -! -! !INTERFACE: -subroutine spmd_vars_init( nprxy_x_in, nprxy_y_in, & - npryz_y_in, npryz_z_in, & - imxy_in, jmxy_in, jmyz_in, kmyz_in, nq_in, & - grid ) - -! !USES: - use decompmodule, only: decompcreate, decompfree - use ghostmodule, only : ghostcreate - use parutilitiesmodule, only : gid, gsize, commglobal, & - parpatterncreate, parsplit - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: nprxy_x_in ! XY decomp - Nr in X - integer, intent(in) :: nprxy_y_in ! XY decomp - Nr in Y - integer, intent(in) :: npryz_y_in ! YZ decomp - Nr in Y - integer, intent(in) :: npryz_z_in ! YZ decomp - Nr in Z - - integer, dimension(:), intent(in) :: imxy_in - integer, dimension(:), intent(in) :: jmxy_in - integer, dimension(:), intent(in) :: jmyz_in - integer, dimension(:), intent(in) :: kmyz_in - integer, intent(in) :: nq_in - -! !INPUT/OUTPUT PARAMETERS: - type( T_FVDYCORE_GRID ), intent(inout) :: grid - -! !DESCRIPTION: -! -! {\bf Purpose:} Initialization of the SPMD related variables. -! This has to be done in this module since certain variables -! (in particular the ghost sizes {\tt ng\_d, ng\_s} are first -! defined here. -! -! !REVISION HISTORY: -! 02.11.08 Sawyer Creation -! 03.05.07 Sawyer Use ParPatternCopy for q_to_qxy, etc. -! 03.07.23 Sawyer Removed dependency on constituents module -! 03.09.10 Sawyer Reactivated u_to_uxy, etc, redefined pe2pexy -! 03.11.19 Sawyer Merged in CAM code with mod_method -! 04.08.25 Sawyer Added GRID as argument -! 04.09.30 Sawyer Initial ESMF routehandlers -! 04.10.04 Sawyer Added INIT_SPMD functionality -! 06.08.27 Sawyer Removed ESMF routehandles -- non-current -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -#if defined( MAPL_MODE ) - character(len=ESMF_MAXSTR), parameter :: IAm='spmd_vars_init' -#endif - -! !LOCAL VARIABLES: - type(decomptype) :: global2d, local2d - - integer :: im, jm, km ! Global dims - integer :: ifirstxy, ilastxy ! Interval - integer :: jfirstxy, jlastxy ! Interval - integer :: jfirst, jlast ! Interval - integer :: kfirst, klast ! Interval - integer :: ng_s, ng_c, ng_d ! Ghost widths - integer :: rc ! return code - integer :: rank_y, rank_z, rankxy_x, rankxy_y ! Currently not used - integer :: size_y, size_z, sizexy_x, sizexy_y ! Currently not used - - integer :: xdist(1), ydistk(1), zdist1(1), zdistxy(1) ! non-distributed dims - integer, allocatable :: xdist_global(:), ydist_global(:) - integer, allocatable :: zdist(:) ! number of levels per subdomain - integer :: ier ! error flag - -! -! Grab crucial variables from Grid -! - im = grid%im - jm = grid%jm - km = grid%km - - ifirstxy = grid%ifirstxy - ilastxy = grid%ilastxy - jfirstxy = grid%jfirstxy - jlastxy = grid%jlastxy - - jfirst = grid%jfirst - jlast = grid%jlast - kfirst = grid%kfirst - klast = grid%klast - - ng_s = grid%ng_s - ng_c = grid%ng_c - ng_d = grid%ng_d - - -! -! This section of code used to be in INIT_SPMD (FVdycore_GridCompMod) -! - grid%iam = gid - - grid%npr_y = npryz_y_in - grid%npr_z = npryz_z_in - grid%nprxy_x = nprxy_x_in - grid%nprxy_y = nprxy_y_in - - grid%myid_z = gid/grid%npr_y - grid%myid_y = gid - grid%myid_z*grid%npr_y - grid%myidxy_y = gid/grid%nprxy_x - grid%myidxy_x = gid - grid%myidxy_y*grid%nprxy_x - -! Split communicators - - call parsplit(commglobal, grid%myid_z, gid, grid%comm_y, rank_y, size_y) - call parsplit(commglobal, grid%myid_y, gid, grid%comm_z, rank_z, size_z) - call parsplit(commglobal, grid%myidxy_y, gid, grid%commxy_x, rankxy_x, sizexy_x) - call parsplit(commglobal, grid%myidxy_x, gid, grid%commxy_y, rankxy_y, sizexy_y) - -! -! WS: create decompositions for NCAR data structures -! - allocate (xdist_global(nprxy_x_in)) - allocate (ydist_global(nprxy_y_in)) - allocate (zdist (npryz_z_in)) - xdist(1) = im -! -! Create PILGRIM decompositions (see decompmodule) -! - xdist_global = 0 - ydist_global = 0 - xdist_global(1) = im - ydist_global(1) = jm - zdistxy(1) = km - call decompcreate( nprxy_x_in, nprxy_y_in, xdist_global, & - ydist_global, global2d ) - call decompcreate( nprxy_x_in, nprxy_y_in, imxy_in, jmxy_in, local2d ) - - call decompcreate( 1, npryz_y_in, xdist, jmyz_in, grid%strip2d ) - call decompcreate( 1, npryz_y_in, npryz_z_in, xdist, & - jmyz_in, kmyz_in, grid%strip3dxyz ) - call decompcreate( "xzy", 1, npryz_z_in, grid%npr_y, xdist, & - kmyz_in, jmyz_in, grid%strip3dxzy ) - -! For y communication within z subdomain (klast version) - zdist1(1) = kmyz_in(grid%myid_z+1) - call decompcreate( 1, npryz_y_in, 1, xdist, jmyz_in, zdist1, & - grid%strip3yatz ) - -! For z communication within y subdomain - - ydistk(1) = jmyz_in(grid%myid_y+1) - call decompcreate( 1, 1, npryz_z_in, xdist, ydistk, kmyz_in, & - grid%strip3zaty ) - -! Arrays dimensioned plev+1 - - zdist(:) = kmyz_in(:) - zdist(npryz_z_in) = kmyz_in(npryz_z_in) + 1 - call decompcreate( 1, npryz_y_in, npryz_z_in, xdist, jmyz_in, zdist,& - grid%strip3dxyzp ) - call decompcreate( "xzy", 1, npryz_z_in, npryz_y_in, & - xdist, zdist, jmyz_in, grid%strip3dxzyp ) - -! Arrays dimensioned plev+1, within y subdomain - - ydistk(1) = jmyz_in(grid%myid_y+1) - call decompcreate( "xzy", 1, npryz_z_in, 1, xdist, zdist, ydistk, & - grid%strip3zatypt ) - -! For y communication within z subdomain (klast+1 version) - zdist1(1) = kmyz_in(grid%myid_z+1)+1 - call decompcreate( 1, npryz_y_in, 1, xdist, jmyz_in, zdist1, & - grid%strip3yatzp ) - -! For the 2D XY-YZ data transfer, we need a short 3D array - zdist(:) = 1 ! One copy on each z PE set - call decompcreate( 1, npryz_y_in, npryz_z_in, & - xdist, jmyz_in, zdist, grid%strip3dyz ) - -! Secondary xy decomposition -! - if (grid%twod_decomp == 1) then - zdistxy(1) = npryz_z_in ! All npr_z copies on 1 PE - call decompcreate( nprxy_x_in, nprxy_y_in, 1, & - imxy_in, jmxy_in, zdistxy, grid%checker3kxy ) - zdistxy(1) = km - call decompcreate( nprxy_x_in, nprxy_y_in, 1, & - imxy_in, jmxy_in, zdistxy, grid%strip3kxyz ) - call decompcreate( "xzy", nprxy_x_in, 1, nprxy_y_in, & - imxy_in, zdistxy, jmxy_in, grid%strip3kxzy ) - - zdistxy(1) = zdistxy(1) + 1 - call decompcreate( nprxy_x_in, nprxy_y_in, 1, & - imxy_in, jmxy_in, zdistxy, grid%strip3kxyzp ) - call decompcreate( "xzy", nprxy_x_in, 1, nprxy_y_in, & - imxy_in, zdistxy, jmxy_in, grid%strip3kxzyp ) - zdistxy(1) = jlastxy - jfirstxy + 1 - call decompcreate( nprxy_x_in, 1, imxy_in, zdistxy, grid%strip2dx ) - endif - - deallocate(zdist) - deallocate(ydist_global) - deallocate(xdist_global) -! -! End of section imported from INIT_SPMD (FVdycore_GridCompMod) -! - - if ( grid%twod_decomp == 1 ) then -! Initialize ghost regions -! - !!! call t_startf('ghost_creation') - call ghostcreate( grid%strip3dxyz, gid, im, 1, im, .true., & - jm, jfirst-ng_d, jlast+ng_s, .false., & - km, kfirst, klast, .false., grid%ghostu_yz ) - call ghostcreate( grid%strip3dxyz, gid, im, 1, im, .true., & - jm, jfirst-ng_s, jlast+ng_d, .false., & - km, kfirst, klast, .false., grid%ghostv_yz ) - call ghostcreate( grid%strip3dxyz, gid, im, 1, im, .true., & - jm, jfirst-ng_d, jlast+ng_d, .false., & - km, kfirst, klast, .false., grid%ghostpt_yz ) - call ghostcreate( grid%strip3dxzyp, gid, im, 1, im, .true., & - km+1, kfirst, klast+1, .false., & - jm, jfirst, jlast, .false., grid%ghostpe_yz) - call ghostcreate( grid%strip3dxyzp, gid, im, 1, im, .true., & - jm, jfirst, jlast, .false., & - km+1, kfirst, klast+1, .false., grid%ghostpkc_yz) - !!! call t_stopf('ghost_creation') - -! Initialize transposes -! - !!! call t_startf('transpose_creation') - call parpatterncreate(commglobal, grid%ghostu_yz, grid%strip3kxyz, & - grid%u_to_uxy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxyz,grid%ghostu_yz, & - grid%uxy_to_u, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%ghostv_yz, grid%strip3kxyz, & - grid%v_to_vxy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxyz, grid%ghostv_yz, & - grid%vxy_to_v, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3dxyz, grid%strip3kxyz,& - grid%ijk_yz_to_xy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxyz, grid%strip3dxyz,& - grid%ijk_xy_to_yz, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3dxzy, grid%strip3kxzy,& - grid%ikj_yz_to_xy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxzy, grid%strip3dxzy,& - grid%ikj_xy_to_yz, mod_method=grid%mod_method) - - -! -! Note PE <-> PEXY has been redefined for PEXY ijk, but PE ikj -! - call parpatterncreate(commglobal, grid%ghostpe_yz, grid%strip3kxzyp, & - grid%pe_to_pexy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxzyp, grid%ghostpe_yz, & - grid%pexy_to_pe, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%ghostpt_yz, grid%strip3kxyz, & - grid%pt_to_ptxy, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3kxyz, grid%ghostpt_yz, & - grid%ptxy_to_pt, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3dxyz, grid%strip3kxyz, & - grid%r4_yz_to_xy, mod_method=grid%mod_method, & - T = REAL4 ) - call parpatterncreate(commglobal, grid%strip3kxyz, grid%strip3dxyz, & - grid%r4_xy_to_yz, mod_method=grid%mod_method, & - T = REAL4 ) - call parpatterncreate(commglobal, grid%strip3kxyzp, grid%ghostpkc_yz, & - grid%pkxy_to_pkc, mod_method=grid%mod_method) -! -! These are for 'transposing' 2D arrays from XY YZ - call parpatterncreate(commglobal, grid%checker3kxy, grid%strip3dyz, & - grid%xy2d_to_yz2d, mod_method=grid%mod_method) - call parpatterncreate(commglobal, grid%strip3dyz, grid%checker3kxy, & - grid%yz2d_to_xy2d, mod_method=grid%mod_method) - !!! call t_stopf('transpose_creation') - - endif - -#if !defined( MAPL_MODE ) -! -! Define scatter and gather patterns for 2D and 3D unghosted arrays -! - - call parpatterncreate( commglobal, global2d, local2d, grid%s_2dxy_r8, & - mod_method=grid%mod_gatscat ) - call parpatterncreate( commglobal, local2d, global2d, grid%g_2dxy_r8, & - mod_method=grid%mod_gatscat ) - - call parpatterncreate( commglobal, global2d, local2d, grid%s_2dxy_r4, & - mod_method=grid%mod_gatscat, T = REAL4 ) - call parpatterncreate( commglobal, local2d, global2d, grid%g_2dxy_r4, & - mod_method=grid%mod_gatscat, T = REAL4 ) - - call parpatterncreate( commglobal, global2d, local2d, grid%s_2dxy_i4, & - mod_method=grid%mod_gatscat, T = INT4 ) - call parpatterncreate( commglobal, local2d, global2d, grid%g_2dxy_i4, & - mod_method=grid%mod_gatscat, T = INT4 ) - -! -! 3D XYZ patterns, will replace XZY patterns eventually -! - call parpatterncreate( grid%s_2dxy_r8, grid%s_3dxyz_r8, km ) - call parpatterncreate( grid%g_2dxy_r8, grid%g_3dxyz_r8, km ) - call parpatterncreate( grid%s_2dxy_r8, grid%s_3dxyzp_r8, km+1 ) - call parpatterncreate( grid%g_2dxy_r8, grid%g_3dxyzp_r8, km+1 ) - - call parpatterncreate( grid%s_2dxy_r4, grid%s_3dxyz_r4, km ) - call parpatterncreate( grid%g_2dxy_r4, grid%g_3dxyz_r4, km ) - call parpatterncreate( grid%s_2dxy_r4, grid%s_3dxyzp_r4, km+1 ) - call parpatterncreate( grid%g_2dxy_r4, grid%g_3dxyzp_r4, km+1 ) - -#endif - - call decompfree( global2d ) - call decompfree( local2d ) - - return -!EOC -end subroutine spmd_vars_init -!----------------------------------------------------------------------- -#endif - -!EOC - end subroutine dynamics_init -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: dynamics_clean -- clean up Lin-Rood-specific variables -! -! !INTERFACE: - subroutine dynamics_clean(grid) - -! !USES: - implicit none - -! !INPUT/OUTPUT PARAMETERS: - type(T_FVDYCORE_GRID), intent(inout) :: grid ! Resulting grid - - -! !DESCRIPTION: -! -! Clean up (deallocate) Lin-Rood-specific variables -! -! !REVISION HISTORY: -! -! 01.06.06 Sawyer Creation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! Temporary data structures - - if(associated(GRID%SINLON )) deallocate(GRID%SINLON) - if(associated(GRID%COSLON )) deallocate(GRID%COSLON) - if(associated(GRID%SINL5 )) deallocate(GRID%SINL5) - if(associated(GRID%COSL5 )) deallocate(GRID%COSL5) - - if(associated(GRID%ACOSP )) deallocate(GRID%ACOSP) - if(associated(GRID%ACOSU )) deallocate(GRID%ACOSU) - if(associated(GRID%SINP )) deallocate(GRID%SINP) - if(associated(GRID%COSP )) deallocate(GRID%COSP) - if(associated(GRID%SINE )) deallocate(GRID%SINE) - if(associated(GRID%COSE )) deallocate(GRID%COSE) - if(associated(GRID%AK )) deallocate(GRID%AK) - if(associated(GRID%BK )) deallocate(GRID%BK) - -! -! cd_core variables -! - if(associated( grid%dtdx )) deallocate(grid%dtdx) - if(associated( grid%dtdx2 )) deallocate(grid%dtdx2) - if(associated( grid%dtdx4 )) deallocate(grid%dtdx4) - if(associated( grid%dtdxe )) deallocate(grid%dtdxe) - if(associated( grid%dxdt )) deallocate(grid%dxdt) - if(associated( grid%dxe )) deallocate(grid%dxe) - if(associated( grid%cye )) deallocate(grid%cye) - if(associated( grid%dycp )) deallocate(grid%dycp) - if(associated( grid%rdxe )) deallocate(grid%rdxe) - if(associated( grid%txe5 )) deallocate(grid%txe5) - if(associated( grid%dtxe5 )) deallocate(grid%dtxe5) - if(associated( grid%dyce )) deallocate(grid%dyce) - if(associated( grid%dx )) deallocate(grid%dx) - if(associated( grid%rdx )) deallocate(grid%rdx) - if(associated( grid%cy )) deallocate(grid%cy) - - if(associated( grid%sc )) deallocate(grid%sc) - if(associated( grid%se )) deallocate(grid%se) - if(associated( grid%dc )) deallocate(grid%dc) - if(associated( grid%de )) deallocate(grid%de) - - if(associated( grid%cdx )) deallocate(grid%cdx) - if(associated( grid%cdy )) deallocate(grid%cdy) - - if(associated( grid%f0 )) deallocate(grid%f0) - if(associated( grid%fc )) deallocate(grid%fc) - -#if defined( MAPL_MODE ) - call ESMF_GridDestroy (GRID%GRIDYZ) -#endif - -#if defined(SPMD) - call spmd_vars_clean(grid) -#endif - return -!EOC - end subroutine dynamics_clean -!----------------------------------------------------------------------- - -#if defined(SPMD) -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: spmd_vars_clean --- Clean the SPMD-related variables -! -! !INTERFACE: -subroutine spmd_vars_clean(grid) - -! !USES: - use ghostmodule, only : ghostfree - use parutilitiesmodule, only : commglobal, parpatternfree - implicit none - -!------------------------------Commons---------------------------------- - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(inout) :: grid - -! -! !DESCRIPTION: -! -! {\bf Purpose:} Clean the SPMD related variables. -! -! !REVISION HISTORY: -! 02.11.08 Sawyer Creation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! - - if ( grid%twod_decomp == 1 ) then -! Clean the ghost regions -! - call ghostfree( grid%ghostu_yz ) - call ghostfree( grid%ghostv_yz ) - call ghostfree( grid%ghostpt_yz ) - call ghostfree( grid%ghostpe_yz ) - call ghostfree( grid%ghostpkc_yz ) -! Clean transposes -! - call parpatternfree(commglobal, grid%u_to_uxy) - call parpatternfree(commglobal, grid%uxy_to_u) - call parpatternfree(commglobal, grid%v_to_vxy) - call parpatternfree(commglobal, grid%vxy_to_v) - call parpatternfree(commglobal, grid%ijk_yz_to_xy) - call parpatternfree(commglobal, grid%ijk_xy_to_yz) - call parpatternfree(commglobal, grid%ikj_xy_to_yz) - call parpatternfree(commglobal, grid%ikj_yz_to_xy) - call parpatternfree(commglobal, grid%pe_to_pexy) - call parpatternfree(commglobal, grid%pexy_to_pe) - call parpatternfree(commglobal, grid%pt_to_ptxy) - call parpatternfree(commglobal, grid%ptxy_to_pt) - call parpatternfree(commglobal, grid%r4_xy_to_yz) - call parpatternfree(commglobal, grid%r4_yz_to_xy) - call parpatternfree(commglobal, grid%pkxy_to_pkc) - call parpatternfree(commglobal, grid%xy2d_to_yz2d) - call parpatternfree(commglobal, grid%yz2d_to_xy2d) - endif - return -!EOC -end subroutine spmd_vars_clean -#endif - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: a2d3d -- 2nd order A-to-D grid transform (3D) XY decomp -! INOUT array is i,j,k, and is modified in place -! -! !INTERFACE: - - subroutine a2d3d( grid, u, v ) - -! !USES: - -#if defined( SPMD ) - use parutilitiesmodule, only : parcollective3d, sumop, gid - use mod_comm, only: commglobal, commglobal, mp_send3d, mp_recv3d -#endif - - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(inout) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !DESCRIPTION: -! -! This routine performs a second order interpolation of -! three-dimensional wind fields on a A grid to an D grid. -! In place calculation! -! -! !REVISION HISTORY: -! WS 03.08.27 : Creation from d2a3d -! WS 03.10.22 : pmgrid removed (now spmd_dyn) -! WS 04.08.25 : simplified interfaces with grid (only for XY!!!) -! WS 04.10.06 : removed spmd_dyn, all those vars. now from grid -! -!EOP -!----------------------------------------------------------------------- -!BOC - - integer :: im ! Dimensions longitude (total) - integer :: jm ! Dimensions latitude (total) - integer :: km ! Dimensions vertical (total) - integer :: ifirst ! longitude strip start - integer :: ilast ! longitude strip finish - integer :: jfirst ! latitude strip start - integer :: jlast ! latitude strip finish - integer :: iam ! process identifier - integer :: myidxy_y, myidxy_x, nprxy_x - integer :: comm_y, commxy_y, commxy_x - - real(r8), parameter :: UNDEFINED = 1.0D15 - - integer :: i, j, k, itot, jtot - real(r8) :: vwest(grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) :: usouth(grid%ifirstxy:grid%ilastxy,grid%km) - -#if defined( SPMD ) - integer dest, src -#endif - - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - myidxy_x = grid%myidxy_x - myidxy_y = grid%myidxy_y - nprxy_x = grid%nprxy_x - - comm_y = grid%comm_y - commxy_x = grid%commxy_x - commxy_y = grid%commxy_y - - itot = ilast-ifirst+1 - jtot = jlast-jfirst+1 - -#if defined( SPMD ) -! Send one latitude to the north - call mp_send3d( commglobal, iam+nprxy_x, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jlast, jlast, 1, km, u ) - call mp_recv3d( commglobal, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jfirst-1, jfirst-1, 1, km, & - ifirst, ilast, jfirst-1, jfirst-1, 1, km, usouth ) -#endif - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jlast, jfirst+1, -1 - do i=ifirst,ilast - u(i,j,k) = D0_5*(u(i,j-1,k) + u(i,j,k)) - enddo - enddo - enddo - -#if defined( SPMD ) - if ( jfirst > 1 ) then -!$omp parallel do private(i, k) - do k=1,km - do i=ifirst,ilast - u(i,jfirst,k) = D0_5 * ( u(i,jfirst,k) + usouth(i,k) ) - enddo - enddo - endif -#endif - - if ( jfirst == 1 ) then -!$omp parallel do private(i,k) - do k=1,km - do i=ifirst,ilast - u(i,1,k) = UNDEFINED - enddo - enddo - endif - -! -! V-winds -! - -! Pack vwest with wrap-around condition - -!$omp parallel do private(j,k) - do k = 1,km - do j=jfirst,jlast - vwest(j,k) = v(ilast,j,k) - enddo - enddo - -#if defined( SPMD ) - if (itot /= im) then - dest = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ilast, ilast, jfirst, jlast, 1, km, v ) - call mp_recv3d( commglobal, src, im, jm, km, & - ifirst-1, ifirst-1, jfirst, jlast, 1, km, & - ifirst-1, ifirst-1, jfirst, jlast, 1, km, vwest ) - endif -#endif - -! -! Beware: ilast is en route, don't alter its value -! - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst, jlast - do i=ilast,ifirst+1,-1 - v(i,j,k) = D0_5*(v(i-1,j,k) + v(i,j,k)) - enddo - enddo - enddo -! -! Clean up shop -! - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst, jlast - v(ifirst,j,k)= D0_5*(vwest(j,k) + v(ifirst,j,k)) - enddo - enddo - - return -!EOC - end subroutine a2d3d -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: d2a3d -- 2nd order D-to-A grid transform (3D) XY decomp. -! Output array is i,j,k -! -! !INTERFACE: - - subroutine d2a3d( grid, u, v, ua, va ) - -! !USES: - -#if defined( SPMD ) - use parutilitiesmodule, only : parcollective3d, sumop - use mod_comm, only: commglobal, mp_send3d, mp_recv3d -#endif - - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - real(r8), intent(in) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(in) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: ua(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(inout) :: va(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - - -! !DESCRIPTION: -! -! This routine performs a second order -! interpolation of three-dimensional wind -! fields on a D grid to an A grid. Only for an XY decomposition! -! -! !REVISION HISTORY: -! WS 00.12.22 : Creation from d2a3d -! AAM 01.06.13 : Generalized to 2D decomposition -! WS 02.04.25 : Newest mod_comm interfaces -! WS 03.08.27 : Minimal alterations to interface, renamed d2a3d -! WS 03.10.22 : pmgrid removed (now spmd_dyn) -! WS 04.08.25 : simplified interfaces with grid (only for XY!!!) -! WS 04.10.06 : removed spmd_dyn, all those vars. now from grid -! -!EOP -!----------------------------------------------------------------------- -!BOC - integer :: im ! Dimensions longitude (total) - integer :: jm ! Dimensions latitude (total) - integer :: km ! Dimensions level (total) - integer :: ifirst ! longitude strip start - integer :: ilast ! longitude strip finish - integer :: jfirst ! latitude strip start - integer :: jlast ! latitude strip finish - integer :: iam, myidxy_y, nprxy_x, commxy_x - - real(r8), pointer :: coslon(:) ! Cosine in longitude - real(r8), pointer :: sinlon(:) ! Sine in longitude - - integer imh, i, j, k, itot, jtot, ltot, lbegin, lend, ik - - real(r8) :: un(grid%km), vn(grid%km), us(grid%km), vs(grid%km) - real(r8) :: veast(grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) :: unorth(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) :: uvaglob(grid%im,grid%km,4) - real(r8) :: uvaloc(grid%ifirstxy:grid%ilastxy,grid%km,4) - real(r8) :: uaglob(grid%im),vaglob(grid%im) - -#if defined( SPMD ) - integer dest, src, incount, outcount -#endif - -! -! Retrieve values from grid -! - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - nprxy_x = grid%nprxy_x - commxy_x = grid%commxy_x - myidxy_y = grid%myidxy_y - - coslon =>grid%coslon - sinlon =>grid%sinlon - - itot = ilast-ifirst+1 - jtot = jlast-jfirst+1 - - imh = im/2 - -#if defined( SPMD ) -! Set ua on A-grid - call mp_send3d( commglobal, iam-nprxy_x, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jfirst, jfirst, 1, km, u ) - call mp_recv3d( commglobal, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, unorth ) - - if ( jlast .lt. jm ) then -!$omp parallel do private(i, k) - - do k=1,km - do i=ifirst,ilast - ua(i,jlast,k) = D0_5 * ( u(i,jlast,k) + unorth(i,k) ) - enddo - enddo - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst, jlast-1 - do i=ifirst,ilast - ua(i,j,k) = D0_5*(u(i,j,k) + u(i,j+1,k)) - enddo - enddo - enddo - -! Set va on A-grid - -!$omp parallel do private(j,k) - - do k = 1,km - do j=jfirst,jlast - veast(j,k) = v(ifirst,j,k) - enddo - enddo - -#if defined( SPMD ) - if (itot .ne. im) then - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ifirst, jfirst, jlast, 1, km, v ) - call mp_recv3d( commglobal, src, im, jm, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, veast ) - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst, jlast - do i=ifirst,ilast-1 - va(i,j,k) = D0_5*(v(i,j,k) + v(i+1,j,k)) - enddo - va(ilast,j,k) = D0_5*(v(ilast,j,k) + veast(j,k)) - enddo - enddo - -!$omp parallel do private(i,ik,k) - - do ik=1,4 - do k=1,km - do i=1,im - uvaglob(i,k,ik) = D0_0 - enddo - enddo - enddo - - if (jfirst .eq. 1) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvaloc(i,k,1) = ua(i,2,k) - uvaloc(i,k,2) = va(i,2,k) - uvaglob(i,k,1) = ua(i,2,k) - uvaglob(i,k,2) = va(i,2,k) - enddo - enddo - lbegin = 1 - lend = 2 - endif - - if (jlast .eq. jm) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvaloc(i,k,3) = ua(i,jm-1,k) - uvaloc(i,k,4) = va(i,jm-1,k) - uvaglob(i,k,3) = ua(i,jm-1,k) - uvaglob(i,k,4) = va(i,jm-1,k) - enddo - enddo - lbegin = 3 - lend = 4 - endif - if (jtot .eq. jm) lbegin=1 - -#if defined( SPMD ) - if (itot .ne. im) then - if (jfirst .eq. 1 .or. jlast .eq. jm) then - ltot = lend-lbegin+1 - call parcollective3d(commxy_x, sumop, im, km, ltot, uvaglob(1,1,lbegin)) - endif - endif -#endif - - if ( jfirst .eq. 1 ) then -! Projection at SP -!$omp parallel do private(i,k,uaglob,vaglob) - do k=1,km - us(k) = D0_0 - vs(k) = D0_0 - do i=1,imh - us(k) = us(k) + (uvaglob(i+imh,k,1)-uvaglob(i,k,1))*sinlon(i) & - + (uvaglob(i,k,2)-uvaglob(i+imh,k,2))*coslon(i) - vs(k) = vs(k) + (uvaglob(i+imh,k,1)-uvaglob(i,k,1))*coslon(i) & - + (uvaglob(i+imh,k,2)-uvaglob(i,k,2))*sinlon(i) - enddo - - us(k) = us(k)/im - vs(k) = vs(k)/im - do i=1,imh - uaglob(i) = -us(k)*sinlon(i) - vs(k)*coslon(i) - vaglob(i) = us(k)*coslon(i) - vs(k)*sinlon(i) - uaglob(i+imh) = -uaglob(i) - vaglob(i+imh) = -vaglob(i) - enddo - do i=ifirst,ilast - ua(i,1,k) = uaglob(i) - va(i,1,k) = vaglob(i) - enddo - enddo - endif - - if ( jlast .eq. jm ) then -! Projection at NP -!$omp parallel do private(i,k,uaglob,vaglob) - do k=1,km - un(k) = D0_0 - vn(k) = D0_0 - do i=1,imh - un(k) = un(k) + (uvaglob(i+imh,k,3)-uvaglob(i,k,3))*sinlon(i) & - + (uvaglob(i+imh,k,4)-uvaglob(i,k,4))*coslon(i) - vn(k) = vn(k) + (uvaglob(i,k,3)-uvaglob(i+imh,k,3))*coslon(i) & - + (uvaglob(i+imh,k,4)-uvaglob(i,k,4))*sinlon(i) - enddo - - un(k) = un(k)/im - vn(k) = vn(k)/im - do i=1,imh - uaglob(i) = -un(k)*sinlon(i) + vn(k)*coslon(i) - vaglob(i) = -un(k)*coslon(i) - vn(k)*sinlon(i) - uaglob(i+imh) = -uaglob(i) - vaglob(i+imh) = -vaglob(i) - enddo - do i=ifirst,ilast - ua(i,jm,k) = uaglob(i) - va(i,jm,k) = vaglob(i) - enddo - enddo - endif - - return -!EOC - end subroutine d2a3d -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: d2b3d -- 2nd order D-to-B grid transform (3D) XY decomp. -! Output array is i,j,k -! -! !INTERFACE: - - subroutine d2b3d( grid, u, v, ub, vb ) - -! !USES: -#if defined( SPMD ) - use parutilitiesmodule, only : parcollective3d, sumop - use mod_comm, only: commglobal, mp_send3d, mp_recv3d -#endif - - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - real(r8), intent(in) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(in) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: ub(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(inout) :: vb(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - - -! !DESCRIPTION: -! -! This routine performs a second order -! interpolation of three-dimensional wind -! fields on a D grid to an B grid. Only for an XY decomposition! -! -! !REVISION HISTORY: -! BP 05.02.22 : Creation from d2a3d -! -!EOP -!----------------------------------------------------------------------- -!BOC - integer :: im ! Dimensions longitude (total) - integer :: jm ! Dimensions latitude (total) - integer :: km ! Dimensions level (total) - integer :: ifirst ! longitude strip start - integer :: ilast ! longitude strip finish - integer :: jfirst ! latitude strip start - integer :: jlast ! latitude strip finish - integer :: iam, myidxy_y, nprxy_x, commxy_x - - real(r8), parameter :: UNDEFINED = 1.0D15 - - - real(r8), pointer :: coslon(:) ! Cosine in longitude - real(r8), pointer :: sinlon(:) ! Sine in longitude - - integer imh, i, j, k, itot, jtot, ltot, lbegin, lend, ik - - real(r8) :: ueast(grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) :: vsouth(grid%ifirstxy:grid%ilastxy,grid%km) - -#if defined( SPMD ) - integer dest, src, incount, outcount -#endif - -! -! Retrieve values from grid -! - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - nprxy_x = grid%nprxy_x - commxy_x = grid%commxy_x - myidxy_y = grid%myidxy_y - - coslon =>grid%coslon - sinlon =>grid%sinlon - - itot = ilast-ifirst+1 - jtot = jlast-jfirst+1 - - imh = im/2 - -#if defined( SPMD ) -! Set vb on B-grid - call mp_send3d( commglobal, iam+nprxy_x, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jfirst, jfirst, 1, km, v ) - call mp_recv3d( commglobal, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, vsouth ) - - if ( jfirst .gt. 1 ) then -!$omp parallel do private(i, k) - - do k=1,km - do i=ifirst,ilast - vb(i,jfirst,k) = D0_5 * ( v(i,jfirst,k) + vsouth(i,k) ) - enddo - enddo - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst+1, jlast - do i=ifirst,ilast - vb(i,j,k) = D0_5*(v(i,j,k) + v(i,j-1,k)) - enddo - enddo - enddo - -! Set ub on B-grid - -!$omp parallel do private(j,k) - - do k = 1,km - do j=jfirst,jlast - ueast(j,k) = u(ifirst,j,k) - enddo - enddo - -#if defined( SPMD ) - if (itot .ne. im) then - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ifirst, jfirst, jlast, 1, km, u ) - call mp_recv3d( commglobal, src, im, jm, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, ueast ) - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst, jlast - do i=ifirst,ilast-1 - ub(i,j,k) = D0_5*(u(i,j,k) + u(i+1,j,k)) - enddo - ub(ilast,j,k) = D0_5*(u(ilast,j,k) + ueast(j,k)) - enddo - enddo - - if ( jfirst == 1 ) then -!$omp parallel do private(i,k) - do k=1,km - do i=ifirst,ilast - ub(i,1,k) = UNDEFINED - vb(i,1,k) = UNDEFINED - enddo - enddo - endif - - return -!EOC - end subroutine d2b3d -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: b2d3d -- 2nd order B-to-D grid transform (3D) XY decomp -! INOUT array is i,j,k, and is modified in place -! -! !INTERFACE: - - subroutine b2d3d( grid, u, v ) - -! !USES: -#if defined( SPMD ) - use parutilitiesmodule, only : parcollective3d, sumop, gid - use mod_comm, only: commglobal, mp_send3d, mp_recv3d -#endif - - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(inout) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !DESCRIPTION: -! -! This routine performs a second order interpolation of -! three-dimensional wind fields on a B grid to an D grid. -! In place calculation! -! -! !REVISION HISTORY: -! BP 05.02.22 : Creation from a2d3d -! -!EOP -!----------------------------------------------------------------------- -!BOC - - integer :: im ! Dimensions longitude (total) - integer :: jm ! Dimensions latitude (total) - integer :: km ! Dimensions vertical (total) - integer :: ifirst ! longitude strip start - integer :: ilast ! longitude strip finish - integer :: jfirst ! latitude strip start - integer :: jlast ! latitude strip finish - integer :: iam ! process identifier - integer :: myidxy_y, myidxy_x, nprxy_x - integer :: comm_y, commxy_y, commxy_x - - real(r8), parameter :: UNDEFINED = 1.0D15 - - real(r8) :: uwest(grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) :: vsouth(grid%ifirstxy:grid%ilastxy,grid%km) - - integer :: imh, i, j, k, itot, jtot, ltot, lbegin, lend, ik - real(r8) :: un(grid%km), vn(grid%km), us(grid%km), vs(grid%km) - real(r8) :: uvbglob(grid%im,grid%km,4) - real(r8) :: uvbloc(grid%ifirstxy:grid%ilastxy,grid%km,4) - real(r8) :: ubglob(grid%im),vbglob(grid%im) - - real(r8), pointer :: coslon(:) ! Cosine in longitude - real(r8), pointer :: sinlon(:) ! Sine in longitude - real(r8), pointer :: cosl5(:) ! Cosine in longitude - real(r8), pointer :: sinl5(:) ! Sine in longitude - -#if defined( SPMD ) - integer dest, src -#endif - - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - myidxy_x = grid%myidxy_x - myidxy_y = grid%myidxy_y - nprxy_x = grid%nprxy_x - - comm_y = grid%comm_y - commxy_x = grid%commxy_x - commxy_y = grid%commxy_y - - itot = ilast-ifirst+1 - jtot = jlast-jfirst+1 - - imh = im/2 - coslon => grid%coslon - sinlon => grid%sinlon - cosl5 => grid%cosl5 - sinl5 => grid%sinl5 - -! -! Initial Preparation for Projection at Poles -! -!$omp parallel do private(i,ik,k) - - do ik=1,4 - do k=1,km - do i=1,im - uvbglob(i,k,ik) = D0_0 - enddo - enddo - enddo - - if (jfirst .eq. 1) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvbloc(i,k,1) = u(i,2,k) - uvbloc(i,k,2) = v(i,2,k) - uvbglob(i,k,1) = u(i,2,k) - uvbglob(i,k,2) = v(i,2,k) - enddo - enddo - lbegin = 1 - lend = 2 - endif - - if (jlast .eq. jm) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvbloc(i,k,3) = u(i,jm,k) - uvbloc(i,k,4) = v(i,jm,k) - uvbglob(i,k,3) = u(i,jm,k) - uvbglob(i,k,4) = v(i,jm,k) - enddo - enddo - lbegin = 3 - lend = 4 - endif - if (jtot .eq. jm) lbegin=1 - -#if defined( SPMD ) - if (itot .ne. im) then - if (jfirst .eq. 1 .or. jlast .eq. jm) then - ltot = lend-lbegin+1 - call parcollective3d(commxy_x, sumop, im, km, ltot, uvbglob(1,1,lbegin)) - endif - endif -#endif - -! -! V-Winds -! - -#if defined( SPMD ) -! Send one latitude to the north - call mp_send3d( commglobal, iam+nprxy_x, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jlast, jlast, 1, km, v ) - call mp_recv3d( commglobal, iam-nprxy_x, im, jm, km, & - ifirst, ilast, jfirst-1, jfirst-1, 1, km, & - ifirst, ilast, jfirst-1, jfirst-1, 1, km, vsouth ) -#endif - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jlast, jfirst+1, -1 - do i=ifirst,ilast - v(i,j,k) = D0_5*(v(i,j-1,k) + v(i,j,k)) - enddo - enddo - enddo - -#if defined( SPMD ) - if ( jfirst > 1 ) then -!$omp parallel do private(i, k) - do k=1,km - do i=ifirst,ilast - v(i,jfirst,k) = D0_5 * ( v(i,jfirst,k) + vsouth(i,k) ) - enddo - enddo - endif -#endif - -! -! U-winds -! - -! Pack uwest with wrap-around condition - -!$omp parallel do private(j,k) - do k = 1,km - do j=jfirst,jlast - uwest(j,k) = v(ilast,j,k) - enddo - enddo - -#if defined( SPMD ) - if (itot /= im) then - dest = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ilast, ilast, jfirst, jlast, 1, km, u ) - call mp_recv3d( commglobal, src, im, jm, km, & - ifirst-1, ifirst-1, jfirst, jlast, 1, km, & - ifirst-1, ifirst-1, jfirst, jlast, 1, km, uwest ) - endif -#endif - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst, jlast - do i=ilast,ifirst+1,-1 - u(i,j,k) = D0_5*(u(i-1,j,k) + u(i,j,k)) - enddo - enddo - enddo - -!$omp parallel do private(i,j,k) - do k=1,km - do j=jfirst, jlast - u(ifirst,j,k)= D0_5*(uwest(j,k) + u(ifirst,j,k)) - enddo - enddo - - if ( jfirst == 1 ) then -!$omp parallel do private(i,k) - do k=1,km - do i=ifirst,ilast - u(i,1,k) = UNDEFINED - enddo - enddo - endif - -! -! Project V-Winds to the Poles -! - if ( jfirst == 1 ) then -! Projection at SP -!$omp parallel do private(i,k,ubglob,vbglob) - do k=1,km - us(k) = D0_0 - vs(k) = D0_0 - do i=1,imh - us(k) = us(k) + (uvbglob(i+imh,k,1)-uvbglob(i,k,1))*sinlon(i) & - + (uvbglob(i,k,2)-uvbglob(i+imh,k,2))*coslon(i) - vs(k) = vs(k) + (uvbglob(i+imh,k,1)-uvbglob(i,k,1))*coslon(i) & - + (uvbglob(i+imh,k,2)-uvbglob(i,k,2))*sinlon(i) - enddo - - us(k) = us(k)/im - vs(k) = vs(k)/im - do i=1,imh - vbglob(i) = us(k)*cosl5(i) - vs(k)*sinl5(i) - vbglob(i+imh) = -vbglob(i) - enddo - do i=ifirst,ilast - v(i,1,k) = vbglob(i) - enddo - enddo - endif - - if ( jlast == jm ) then -! Projection at NP -!$omp parallel do private(i,k,ubglob,vbglob) - do k=1,km - un(k) = D0_0 - vn(k) = D0_0 - do i=1,imh - un(k) = un(k) + (uvbglob(i+imh,k,3)-uvbglob(i,k,3))*sinlon(i) & - + (uvbglob(i+imh,k,4)-uvbglob(i,k,4))*coslon(i) - vn(k) = vn(k) + (uvbglob(i,k,3)-uvbglob(i+imh,k,3))*coslon(i) & - + (uvbglob(i+imh,k,4)-uvbglob(i,k,4))*sinlon(i) - enddo - - un(k) = un(k)/im - vn(k) = vn(k)/im - do i=1,imh - vbglob(i) = -un(k)*cosl5(i) - vn(k)*sinl5(i) - vbglob(i+imh) = -vbglob(i) - enddo - do i=ifirst,ilast - v(i,jm,k) = vbglob(i) - enddo - enddo - endif - - return -!EOC - end subroutine b2d3d -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: c2a3d -- 2nd order C-to-A grid transform (3D) XY decomp. -! Output array is i,j,k -! -! !INTERFACE: - - subroutine c2a3d( grid, u, v, ua, va ) - -! !USES: - -#if defined( SPMD ) - use parutilitiesmodule, only : parcollective3d, sumop - use mod_comm, only: commglobal, mp_send3d, mp_recv3d -#endif - - implicit none -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - real(r8), intent(in) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(in) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: ua(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind - real(r8), intent(inout) :: va(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! V-Wind - -! !DESCRIPTION: -! -! This routine performs a second order -! interpolation of three-dimensional wind -! fields on a C grid to an A grid. Only for an XY decomposition! -! -! !REVISION HISTORY: -! WMP 06.11.03 : Creation from d2a3d -! -!EOP -!----------------------------------------------------------------------- -!BOC - integer :: im ! Dimensions longitude (total) - integer :: jm ! Dimensions latitude (total) - integer :: km ! Dimensions level (total) - integer :: ifirst ! longitude strip start - integer :: ilast ! longitude strip finish - integer :: jfirst ! latitude strip start - integer :: jlast ! latitude strip finish - integer :: iam, myidxy_y, nprxy_x, commxy_x - - real(r8), pointer :: coslon(:) ! Cosine in longitude - real(r8), pointer :: sinlon(:) ! Sine in longitude - - integer imh, i, j, k, itot, jtot, ltot, lbegin, lend, ik - - real(r8) :: un(grid%km), vn(grid%km), us(grid%km), vs(grid%km) - real(r8) :: ueast(grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) :: vnorth(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) :: uvaglob(grid%im,grid%km,4) - real(r8) :: uvaloc(grid%ifirstxy:grid%ilastxy,grid%km,4) - real(r8) :: uaglob(grid%im),vaglob(grid%im) - -#if defined( SPMD ) - integer dest, src, incount, outcount -#endif - -! -! Retrieve values from grid -! - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - nprxy_x = grid%nprxy_x - commxy_x = grid%commxy_x - myidxy_y = grid%myidxy_y - - coslon =>grid%coslon - sinlon =>grid%sinlon - - itot = ilast-ifirst+1 - jtot = jlast-jfirst+1 - - imh = im/2 - -#if defined( SPMD ) -! Set va on A-grid - call mp_send3d( commglobal, iam-nprxy_x, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jfirst, jfirst, 1, km, v ) - call mp_recv3d( commglobal, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, vnorth ) - - if ( jlast .lt. jm ) then -!$omp parallel do private(i, k) - - do k=1,km - do i=ifirst,ilast - va(i,jlast,k) = D0_5 * ( v(i,jlast,k) + vnorth(i,k) ) - enddo - enddo - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst, jlast-1 - do i=ifirst,ilast - va(i,j,k) = D0_5*(v(i,j,k) + v(i,j+1,k)) - enddo - enddo - enddo - -! Set ua on A-grid - -!$omp parallel do private(j,k) - - do k = 1,km - do j=jfirst,jlast - ueast(j,k) = u(ifirst,j,k) - enddo - enddo - -#if defined( SPMD ) - if (itot .ne. im) then - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ifirst, jfirst, jlast, 1, km, u ) - call mp_recv3d( commglobal, src, im, jm, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, ueast ) - endif -#endif - -!$omp parallel do private(i,j,k) - - do k=1,km - do j=jfirst, jlast - do i=ifirst,ilast-1 - ua(i,j,k) = D0_5*(u(i,j,k) + u(i+1,j,k)) - enddo - ua(ilast,j,k) = D0_5*(u(ilast,j,k) + ueast(j,k)) - enddo - enddo - -!$omp parallel do private(i,ik,k) - - do ik=1,4 - do k=1,km - do i=1,im - uvaglob(i,k,ik) = D0_0 - enddo - enddo - enddo - - if (jfirst .eq. 1) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvaloc(i,k,1) = ua(i,2,k) - uvaloc(i,k,2) = va(i,2,k) - uvaglob(i,k,1) = ua(i,2,k) - uvaglob(i,k,2) = va(i,2,k) - enddo - enddo - lbegin = 1 - lend = 2 - endif - - if (jlast .eq. jm) then -!$omp parallel do private(i,k) - do k = 1,km - do i=ifirst,ilast - uvaloc(i,k,3) = ua(i,jm-1,k) - uvaloc(i,k,4) = va(i,jm-1,k) - uvaglob(i,k,3) = ua(i,jm-1,k) - uvaglob(i,k,4) = va(i,jm-1,k) - enddo - enddo - lbegin = 3 - lend = 4 - endif - if (jtot .eq. jm) lbegin=1 - -#if defined( SPMD ) - if (itot .ne. im) then - if (jfirst .eq. 1 .or. jlast .eq. jm) then - ltot = lend-lbegin+1 - call parcollective3d(commxy_x, sumop, im, km, ltot, uvaglob(1,1,lbegin)) - endif - endif -#endif - - if ( jfirst .eq. 1 ) then -! Projection at SP -!$omp parallel do private(i,k,uaglob,vaglob) - do k=1,km - us(k) = D0_0 - vs(k) = D0_0 - do i=1,imh - us(k) = us(k) + (uvaglob(i+imh,k,1)-uvaglob(i,k,1))*sinlon(i) & - + (uvaglob(i,k,2)-uvaglob(i+imh,k,2))*coslon(i) - vs(k) = vs(k) + (uvaglob(i+imh,k,1)-uvaglob(i,k,1))*coslon(i) & - + (uvaglob(i+imh,k,2)-uvaglob(i,k,2))*sinlon(i) - enddo - - us(k) = us(k)/im - vs(k) = vs(k)/im - do i=1,imh - uaglob(i) = -us(k)*sinlon(i) - vs(k)*coslon(i) - vaglob(i) = us(k)*coslon(i) - vs(k)*sinlon(i) - uaglob(i+imh) = -uaglob(i) - vaglob(i+imh) = -vaglob(i) - enddo - do i=ifirst,ilast - ua(i,1,k) = uaglob(i) - va(i,1,k) = vaglob(i) - enddo - enddo - endif - - if ( jlast .eq. jm ) then -! Projection at NP -!$omp parallel do private(i,k,uaglob,vaglob) - do k=1,km - un(k) = D0_0 - vn(k) = D0_0 - do i=1,imh - un(k) = un(k) + (uvaglob(i+imh,k,3)-uvaglob(i,k,3))*sinlon(i) & - + (uvaglob(i+imh,k,4)-uvaglob(i,k,4))*coslon(i) - vn(k) = vn(k) + (uvaglob(i,k,3)-uvaglob(i+imh,k,3))*coslon(i) & - + (uvaglob(i+imh,k,4)-uvaglob(i,k,4))*sinlon(i) - enddo - - un(k) = un(k)/im - vn(k) = vn(k)/im - do i=1,imh - uaglob(i) = -un(k)*sinlon(i) + vn(k)*coslon(i) - vaglob(i) = -un(k)*coslon(i) - vn(k)*sinlon(i) - uaglob(i+imh) = -uaglob(i) - vaglob(i+imh) = -vaglob(i) - enddo - do i=ifirst,ilast - ua(i,jm,k) = uaglob(i) - va(i,jm,k) = vaglob(i) - enddo - enddo - endif - - return -!EOC - end subroutine c2a3d -!----------------------------------------------------------------------- - -end module dynamics_vars diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/epvd.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/epvd.F90 deleted file mode 100644 index aeca1f16b..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/epvd.F90 +++ /dev/null @@ -1,271 +0,0 @@ -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: epvd --- Calculate absolute potential vorticity -! -! !INTERFACE: - subroutine epvd( grid, u, v, pt, delp, grav, ae, omega, epv ) -! !USES: - use shr_kind_mod, only : r8 => shr_kind_r8 - use mapz_module, only : ppme - use dynamics_vars, only : T_FVDYCORE_GRID -#if defined( SPMD ) - use parutilitiesmodule, only: sumop, parcollective - use mod_comm, only : gid, commglobal, mp_send3d, mp_recv3d -#endif - implicit none - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid ! grid (for XY decomp) - - real (r8) :: u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - real (r8) :: v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - real (r8) :: pt(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - real (r8) :: delp(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - real(r8), intent(in) :: GRAV ! Constants, passed as arguments to - real(r8), intent(in) :: AE ! ensure portability between - real(r8), intent(in) :: OMEGA ! CAM and GEOS5 - -! !OUTPUT PARAMETERS: - real(r8) epv(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - -! !DESCRIPTION: -! Compute absolute vorticity on the D grid -! epv = -g * (vort+f0)*dpt/dp -! -! !REVISION HISTORY: -! WS 99.11.02 Documentation; indentation; jfirstxy:jlastxy -! WS 00.07.08 Use precision module; Kevin's ghost indices -! WS 05.02.16 Rewritten for FVdycore_GridCompMod, XY decomposition -! WS 05.05.25 Add constants to avoid dependencies on GEOS_Mod -! WS 09.04.01 : Upgraded to PILGRIM from cam3_6_33 -! -!EOP -!--------------------------------------------------------------------- -!BOC - real(r8), parameter :: D0_0 = 0.0_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D2_0 = 2.0_r8 - - real(r8) :: te(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) - real(r8) :: te2(grid%ifirstxy:grid%ilastxy,grid%km+1) - real(r8) :: t2(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) :: delp2(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) :: fx(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy+1) - real(r8) :: fy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) - -! Geometric arrays - real(r8) :: rdx(grid%jfirstxy:grid%jlastxy) ! 1 / ae*cos(\theta)* dtheta - real(r8) :: cy(grid%jfirstxy:grid%jlastxy) ! 1 / ae*cos(\theta)* dlam - - integer :: i, j, k, js2g0, jn2g0 - integer :: iam, myidxy_y, nprxy_x, nprxy_y, dest, src ! SPMD related - integer :: im, jm, km ! problem dimensions - integer :: ifirstxy, ilastxy, jfirstxy, jlastxy ! This PE's intervals - real(r8) :: c1, c2, rdy - - real(r8), allocatable :: veast(:,:) ! East halo - real(r8), allocatable :: unorth(:,:) ! North halo - real(r8), allocatable :: fx_sp(:,:), fx_np(:,:) - real(r8), allocatable :: f0(:) ! Coriolis force - real(r8), allocatable :: vort(:,:) ! Relative vorticity - - im = grid%im - jm = grid%jm - km = grid%km - - ifirstxy = grid%ifirstxy - ilastxy = grid%ilastxy - jfirstxy = grid%jfirstxy - jlastxy = grid%jlastxy - - iam = grid%iam - myidxy_y = grid%myidxy_y - nprxy_x = grid%nprxy_x - nprxy_y = grid%nprxy_y - - - js2g0 = max(2,jfirstxy) - jn2g0 = min(jm-1,jlastxy) - - allocate(veast(jfirstxy:jlastxy,km)) ! East halo - allocate(unorth(ifirstxy:ilastxy,km)) ! North halo - allocate(fx_sp(im,km), fx_np(im,km) ) - allocate(f0(jfirstxy:jlastxy)) ! Coriolis force - allocate(vort(ifirstxy:ilastxy,jfirstxy:jlastxy)) ! Relative vorticity - - -! Geometric factors - - do j=jfirstxy,jlastxy - f0(j) = D2_0*omega*grid%sinp(j) - enddo - rdy = D1_0/(ae*grid%dp) - do j=js2g0,jn2g0 - rdx(j) = D1_0/(grid%dl*ae*grid%cosp(j)) - cy(j) = rdy / grid%cosp(j) - enddo - - unorth = D0_0 -! Periodic boundary (for the case of no decomposition in X) - do k=1,km - do j=jfirstxy,jlastxy - veast(j,k) = v(ifirstxy,j,k) - enddo - enddo - -#if defined( SPMD ) - if (nprxy_y > 1) then -! Nontrivial y decomposition - call mp_send3d( commglobal, iam-nprxy_x, iam+nprxy_x, im, jm, km, & - ifirstxy, ilastxy, jfirstxy, jlastxy, 1, km, & - ifirstxy, ilastxy, jfirstxy, jfirstxy, 1, km, u ) - endif - if (nprxy_x > 1) then -! Nontrivial x decomposition - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirstxy, ilastxy, jfirstxy, jlastxy, 1,km, & - ifirstxy, ifirstxy, jfirstxy, jlastxy, 1, km, v ) - endif -#endif - -! Compute PT at layer edges. - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,j,k,t2,delp2,te2) - - do 1000 j=jfirstxy,jlastxy - - do k=1,km - do i=ifirstxy,ilastxy - t2(i,k) = pt(i,j,k) - delp2(i,k) = delp(i,j,k) - enddo - enddo - - call ppme(t2,te2,delp2,ilastxy-ifirstxy+1,km) - - do k=1,km+1 - do i=ifirstxy,ilastxy - te(i,j,k) = te2(i,k) - enddo - enddo - -1000 continue - - -! -! Prepare sum of U-winds for vorticities at pole -! - fx_sp = D0_0 - fx_np = D0_0 -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,k) - do k=1,km - if ( jfirstxy == 1 ) then ! SP - do i=ifirstxy,ilastxy - fx_sp(i,k) = u(i,2,k)*grid%cose(2) - enddo - endif - if ( jlastxy == jm ) then ! NP - do i=ifirstxy,ilastxy - fx_np(i,k) = u(i,jm,k)*grid%cose(jm) - enddo - endif - enddo - - -#if defined( SPMD ) - if ( nprxy_y > 1 ) then -! Non-trivial Y decomposition - call mp_recv3d( commglobal, iam+nprxy_x, im, jm, km, & - ifirstxy, ilastxy, jlastxy+1, jlastxy+1, 1, km, & - ifirstxy, ilastxy, jlastxy+1, jlastxy+1, 1, km, unorth ) - endif - if ( nprxy_x > 1 ) then -! Non-trivial X decomposition - call mp_recv3d( commglobal, src, im, jm, km, & - ilastxy+1, ilastxy+1, jfirstxy, jlastxy, 1, km, & - ilastxy+1, ilastxy+1, jfirstxy, jlastxy, 1, km, veast ) - endif -#endif - -#if defined( SPMD ) -! -! Collect on all PETs the weighted U-winds at both poles -! - if (nprxy_x > 1) then - call parcollective(grid%commxy_x, sumop, im, km, fx_sp) - call parcollective(grid%commxy_x, sumop, im, km, fx_np) - endif -#endif - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,j,k,fx,fy,vort,c1,c2) - - do 2000 k=1,km -! Compute relative vorticity - do j=js2g0,jlastxy - do i=ifirstxy,ilastxy - fx(i,j) = u(i,j,k)*grid%cose(j) - enddo - enddo - if ( jlastxy < jm ) then - do i=ifirstxy,ilastxy - fx(i,jlastxy+1) = unorth(i,k)*grid%cose(jlastxy+1) - enddo - endif - - do j=js2g0,jn2g0 - do i=ifirstxy,ilastxy-1 - fy(i,j) = v(i+1,j,k) - v(i,j,k) - enddo - enddo - do j=js2g0,jn2g0 - fy(ilastxy,j) = veast(j,k) - v(ilastxy,j,k) - enddo - - do j=js2g0,jn2g0 - do i=ifirstxy,ilastxy - vort(i,j) = (fx(i,j)-fx(i,j+1))*cy(j) + fy(i,j)*rdx(j) - enddo - enddo - -! Vort at poles computed by circulation theorem - - if ( jfirstxy == 1 ) then - c1 = -SUM(fx_sp(1:im,k))*rdy*grid%rcap - do i=ifirstxy,ilastxy - vort(i, 1) = c1 - enddo - endif - if ( jlastxy == jm ) then - c2 = SUM(fx_np(1:im,k))*rdy*grid%rcap - do i=ifirstxy,ilastxy - vort(i,jm) = c2 - enddo - endif - - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy -! Standard, virtual potential temp based, definition of EPV - epv(i,j,k) = grav*(vort(i,j)+f0(j))*(te(i,j,k)-te(i,j,k+1)) & - / (delp(i,j,k)) - enddo - enddo -!!! print *, "k", k, ifirstxy, jfirstxy, "minmax epv", minval(epv(:,:,k)), & -!!! maxval(epv(:,:,k)), minloc(epv(:,:,k)), maxloc(epv(:,:,k)) -2000 continue - - deallocate(veast) - deallocate(unorth) - deallocate(fx_sp,fx_np) - deallocate(f0) - deallocate(vort) - - return - end diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fft99.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fft99.F90 deleted file mode 100644 index eae01e783..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fft99.F90 +++ /dev/null @@ -1,1207 +0,0 @@ - SUBROUTINE FFT99(A,WORK,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN) -! -! PURPOSE PERFORMS MULTIPLE FAST FOURIER TRANSFORMS. THIS PACKAGE -! WILL PERFORM A NUMBER OF SIMULTANEOUS REAL/HALF-COMPLEX -! PERIODIC FOURIER TRANSFORMS OR CORRESPONDING INVERSE -! TRANSFORMS, I.E. GIVEN A SET OF REAL DATA VECTORS, THE -! PACKAGE RETURNS A SET OF 'HALF-COMPLEX' FOURIER -! COEFFICIENT VECTORS, OR VICE VERSA. THE LENGTH OF THE -! TRANSFORMS MUST BE AN EVEN NUMBER GREATER THAN 4 THAT HAS -! NO OTHER FACTORS EXCEPT POSSIBLY POWERS OF 2, 3, AND 5. -! THIS IS AN ALL FORTRAN VERSION OF THE CRAYLIB PACKAGE -! THAT IS MOSTLY WRITTEN IN CAL. -! -! THE PACKAGE FFT99F CONTAINS SEVERAL USER-LEVEL ROUTINES: -! -! SUBROUTINE SET99 -! AN INITIALIZATION ROUTINE THAT MUST BE CALLED ONCE -! BEFORE A SEQUENCE OF CALLS TO THE FFT ROUTINES -! (PROVIDED THAT N IS NOT CHANGED). -! -! SUBROUTINES FFT99 AND FFT991 -! TWO FFT ROUTINES THAT RETURN SLIGHTLY DIFFERENT -! ARRANGEMENTS OF THE DATA IN GRIDPOINT SPACE. -! -! -! ACCESS THIS FORTRAN VERSION MAY BE ACCESSED WITH -! -! *FORTRAN,P=XLIB,SN=FFT99F -! -! TO ACCESS THE CRAY OBJECT CODE, CALLING THE USER ENTRY -! POINTS FROM A CRAY PROGRAM IS SUFFICIENT. THE SOURCE -! FORTRAN AND CAL CODE FOR THE CRAYLIB VERSION MAY BE -! ACCESSED USING -! -! FETCH P=CRAYLIB,SN=FFT99 -! FETCH P=CRAYLIB,SN=CAL99 -! -! USAGE LET N BE OF THE FORM 2**P * 3**Q * 5**R, WHERE P .GE. 1, -! Q .GE. 0, AND R .GE. 0. THEN A TYPICAL SEQUENCE OF -! CALLS TO TRANSFORM A GIVEN SET OF REAL VECTORS OF LENGTH -! N TO A SET OF 'HALF-COMPLEX' FOURIER COEFFICIENT VECTORS -! OF LENGTH N IS -! -! DIMENSION IFAX(13),TRIGS(3*N/2+1),A(M*(N+2)), -! + WORK(M*(N+1)) -! -! CALL SET99 (TRIGS, IFAX, N) -! CALL FFT99 (A,WORK,TRIGS,IFAX,INC,JUMP,N,M,ISIGN) -! -! SEE THE INDIVIDUAL WRITE-UPS FOR SET99, FFT99, AND -! FFT991 BELOW, FOR A DETAILED DESCRIPTION OF THE -! ARGUMENTS. -! -! HISTORY THE PACKAGE WAS WRITTEN BY CLIVE TEMPERTON AT ECMWF IN -! NOVEMBER, 1978. IT WAS MODIFIED, DOCUMENTED, AND TESTED -! FOR NCAR BY RUSS REW IN SEPTEMBER, 1980. -! -!----------------------------------------------------------------------- -! -! SUBROUTINE SET99 (TRIGS, IFAX, N) -! -! PURPOSE A SET-UP ROUTINE FOR FFT99 AND FFT991. IT NEED ONLY BE -! CALLED ONCE BEFORE A SEQUENCE OF CALLS TO THE FFT -! ROUTINES (PROVIDED THAT N IS NOT CHANGED). -! -! ARGUMENT IFAX(13),TRIGS(3*N/2+1) -! DIMENSIONS -! -! ARGUMENTS -! -! ON INPUT TRIGS -! A FLOATING POINT ARRAY OF DIMENSION 3*N/2 IF N/2 IS -! EVEN, OR 3*N/2+1 IF N/2 IS ODD. -! -! IFAX -! AN INTEGER ARRAY. THE NUMBER OF ELEMENTS ACTUALLY USED -! WILL DEPEND ON THE FACTORIZATION OF N. DIMENSIONING -! IFAX FOR 13 SUFFICES FOR ALL N LESS THAN A MILLION. -! -! N -! AN EVEN NUMBER GREATER THAN 4 THAT HAS NO PRIME FACTOR -! GREATER THAN 5. N IS THE LENGTH OF THE TRANSFORMS (SEE -! THE DOCUMENTATION FOR FFT99 AND FFT991 FOR THE -! DEFINITIONS OF THE TRANSFORMS). -! -! ON OUTPUT IFAX -! CONTAINS THE FACTORIZATION OF N/2. IFAX(1) IS THE -! NUMBER OF FACTORS, AND THE FACTORS THEMSELVES ARE STORED -! IN IFAX(2),IFAX(3),... IF SET99 IS CALLED WITH N ODD, -! OR IF N HAS ANY PRIME FACTORS GREATER THAN 5, IFAX(1) -! IS SET TO -99. -! -! TRIGS -! AN ARRAY OF TRIGONOMETRIC FUNCTION VALUES SUBSEQUENTLY -! USED BY THE FFT ROUTINES. -! -!----------------------------------------------------------------------- -! -! SUBROUTINE FFT991 (A,WORK,TRIGS,IFAX,INC,JUMP,N,M,ISIGN) -! AND -! SUBROUTINE FFT99 (A,WORK,TRIGS,IFAX,INC,JUMP,N,M,ISIGN) -! -! PURPOSE PERFORM A NUMBER OF SIMULTANEOUS REAL/HALF-COMPLEX -! PERIODIC FOURIER TRANSFORMS OR CORRESPONDING INVERSE -! TRANSFORMS, USING ORDINARY SPATIAL ORDER OF GRIDPOINT -! VALUES (FFT991) OR EXPLICIT CYCLIC CONTINUITY IN THE -! GRIDPOINT VALUES (FFT99). GIVEN A SET -! OF REAL DATA VECTORS, THE PACKAGE RETURNS A SET OF -! 'HALF-COMPLEX' FOURIER COEFFICIENT VECTORS, OR VICE -! VERSA. THE LENGTH OF THE TRANSFORMS MUST BE AN EVEN -! NUMBER THAT HAS NO OTHER FACTORS EXCEPT POSSIBLY POWERS -! OF 2, 3, AND 5. THESE VERSION OF FFT991 AND FFT99 ARE -! OPTIMIZED FOR USE ON THE CRAY-1. -! -! ARGUMENT A(M*(N+2)), WORK(M*(N+1)), TRIGS(3*N/2+1), IFAX(13) -! DIMENSIONS -! -! ARGUMENTS -! -! ON INPUT A -! AN ARRAY OF LENGTH M*(N+2) CONTAINING THE INPUT DATA -! OR COEFFICIENT VECTORS. THIS ARRAY IS OVERWRITTEN BY -! THE RESULTS. -! -! WORK -! A WORK ARRAY OF DIMENSION M*(N+1) -! -! TRIGS -! AN ARRAY SET UP BY SET99, WHICH MUST BE CALLED FIRST. -! -! IFAX -! AN ARRAY SET UP BY SET99, WHICH MUST BE CALLED FIRST. -! -! INC -! THE INCREMENT (IN WORDS) BETWEEN SUCCESSIVE ELEMENTS OF -! EACH DATA OR COEFFICIENT VECTOR (E.G. INC=1 FOR -! CONSECUTIVELY STORED DATA). -! -! JUMP -! THE INCREMENT (IN WORDS) BETWEEN THE FIRST ELEMENTS OF -! SUCCESSIVE DATA OR COEFFICIENT VECTORS. ON THE CRAY-1, -! TRY TO ARRANGE DATA SO THAT JUMP IS NOT A MULTIPLE OF 8 -! (TO AVOID MEMORY BANK CONFLICTS). FOR CLARIFICATION OF -! INC AND JUMP, SEE THE EXAMPLES BELOW. -! -! N -! THE LENGTH OF EACH TRANSFORM (SEE DEFINITION OF -! TRANSFORMS, BELOW). -! -! M -! THE NUMBER OF TRANSFORMS TO BE DONE SIMULTANEOUSLY. -! -! ISIGN -! = +1 FOR A TRANSFORM FROM FOURIER COEFFICIENTS TO -! GRIDPOINT VALUES. -! = -1 FOR A TRANSFORM FROM GRIDPOINT VALUES TO FOURIER -! COEFFICIENTS. -! -! ON OUTPUT A -! IF ISIGN = +1, AND M COEFFICIENT VECTORS ARE SUPPLIED -! EACH CONTAINING THE SEQUENCE: -! -! A(0),B(0),A(1),B(1),...,A(N/2),B(N/2) (N+2 VALUES) -! -! THEN THE RESULT CONSISTS OF M DATA VECTORS EACH -! CONTAINING THE CORRESPONDING N+2 GRIDPOINT VALUES: -! -! FOR FFT991, X(0), X(1), X(2),...,X(N-1),0,0. -! FOR FFT99, X(N-1),X(0),X(1),X(2),...,X(N-1),X(0). -! (EXPLICIT CYCLIC CONTINUITY) -! -! WHEN ISIGN = +1, THE TRANSFORM IS DEFINED BY: -! X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! AND I=SQRT (-1) -! -! IF ISIGN = -1, AND M DATA VECTORS ARE SUPPLIED EACH -! CONTAINING A SEQUENCE OF GRIDPOINT VALUES X(J) AS -! DEFINED ABOVE, THEN THE RESULT CONSISTS OF M VECTORS -! EACH CONTAINING THE CORRESPONDING FOURIER COFFICIENTS -! A(K), B(K), 0 .LE. K .LE N/2. -! -! WHEN ISIGN = -1, THE INVERSE TRANSFORM IS DEFINED BY: -! C(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*EXP(-2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND I=SQRT(-1) -! -! A CALL WITH ISIGN=+1 FOLLOWED BY A CALL WITH ISIGN=-1 -! (OR VICE VERSA) RETURNS THE ORIGINAL DATA. -! -! NOTE: THE FACT THAT THE GRIDPOINT VALUES X(J) ARE REAL -! IMPLIES THAT B(0)=B(N/2)=0. FOR A CALL WITH ISIGN=+1, -! IT IS NOT ACTUALLY NECESSARY TO SUPPLY THESE ZEROS. -! -! EXAMPLES GIVEN 19 DATA VECTORS EACH OF LENGTH 64 (+2 FOR EXPLICIT -! CYCLIC CONTINUITY), COMPUTE THE CORRESPONDING VECTORS OF -! FOURIER COEFFICIENTS. THE DATA MAY, FOR EXAMPLE, BE -! ARRANGED LIKE THIS: -! -! FIRST DATA A(1)= . . . A(66)= A(70) -! VECTOR X(63) X(0) X(1) X(2) ... X(63) X(0) (4 EMPTY LOCATIONS) -! -! SECOND DATA A(71)= . . . A(140) -! VECTOR X(63) X(0) X(1) X(2) ... X(63) X(0) (4 EMPTY LOCATIONS) -! -! AND SO ON. HERE INC=1, JUMP=70, N=64, M=19, ISIGN=-1, -! AND FFT99 SHOULD BE USED (BECAUSE OF THE EXPLICIT CYCLIC -! CONTINUITY). -! -! ALTERNATIVELY THE DATA MAY BE ARRANGED LIKE THIS: -! -! FIRST SECOND LAST -! DATA DATA DATA -! VECTOR VECTOR VECTOR -! -! A(1)= A(2)= A(19)= -! -! X(63) X(63) . . . X(63) -! A(20)= X(0) X(0) . . . X(0) -! A(39)= X(1) X(1) . . . X(1) -! . . . -! . . . -! . . . -! -! IN WHICH CASE WE HAVE INC=19, JUMP=1, AND THE REMAINING -! PARAMETERS ARE THE SAME AS BEFORE. IN EITHER CASE, EACH -! COEFFICIENT VECTOR OVERWRITES THE CORRESPONDING INPUT -! DATA VECTOR. -! -!----------------------------------------------------------------------- -! -! $Id$ -! $Author$ -! - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - INTEGER :: IFAX(13),INC,JUMP,N,LOT,ISIGN - REAL(R8) :: A(LOT*(N+2)),WORK(LOT*(N+1)), TRIGS(3*N/2+1) - -! -! SUBROUTINE "FFT99" - MULTIPLE FAST REAL PERIODIC TRANSFORM -! CORRESPONDING TO OLD SCALAR ROUTINE FFT9 -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(N-1),X(0),X(1),X(2),...,X(N),X(0) -! I.E. EXPLICIT CYCLIC CONTINUITY; (N+2) LOCATIONS REQUIRED -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! -! -! -! - INTEGER :: NFAX, NX, NH, INK, IGO, IBASE, JBASE, I, J, K, L, M, & - IA, JA, LA, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 -! -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=INC+1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE - - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE -! - IGO=60 - GO TO 40 -! -! PREPROCESSING (ISIGN=+1) -! ------------------------ -! - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 -! -! COMPLEX TRANSFORM -! ----------------- -! - 40 CONTINUE - IA=INC+1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, & - INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, & - 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE -! - IF (ISIGN.EQ.-1) GO TO 130 -! -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=IA - DO 100 L=1,LOT - I=IBASE - J=JBASE - - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE -! -! FILL IN CYCLIC BOUNDARY POINTS - 110 CONTINUE - IA=1 - IB=N*INC+1 - - DO 120 L=1,LOT - A(IA)=A(IB) - A(IB+INC)=A(IA+INC) - IA=IA+JUMP - IB=IB+JUMP - 120 CONTINUE - GO TO 140 -! -! POSTPROCESSING (ISIGN=-1): -! -------------------------- -! - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) -! - 140 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - REAL(R8) :: A(*),WORK(*),TRIGS(*) - INTEGER :: INC,JUMP,N,LOT - -! -! SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1 -! (SPECTRAL TO GRIDPOINT TRANSFORM) -! - REAL(R8) :: C, S - INTEGER :: NH, NX, INK, IA, IB, JA, JB, IABASE, JABASE, K, L, & - IBBASE, JBBASE - - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - IA=1 - IB=N*INC+1 - JA=1 - JB=2 - - DO 10 L=1,LOT - WORK(JA)=A(IA)+A(IB) - WORK(JB)=A(IA)-A(IB) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 10 CONTINUE -! -! REMAINING WAVENUMBERS - IABASE=2*INC+1 - IBBASE=(N-2)*INC+1 - JABASE=3 - JBBASE=N-1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) - - DO 20 L=1,LOT - WORK(JA)=(A(IA)+A(IB))-(S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JB)=(A(IA)+A(IB))+(S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC))) - WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+(A(IA+INC)-A(IB+INC)) - WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))-(A(IA+INC)-A(IB+INC)) - IA=IA+JUMP - IB=IB+JUMP - JA=JA+NX - JB=JB+NX - 20 CONTINUE - IABASE=IABASE+INK - IBBASE=IBBASE-INK - JABASE=JABASE+2 - JBBASE=JBBASE-2 - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - - DO 40 L=1,LOT - WORK(JA)=2.0*A(IA) - WORK(JA+1)=-2.0*A(IA+INC) - IA=IA+JUMP - JA=JA+NX - 40 CONTINUE -! - 50 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - REAL(R8) :: WORK(*),A(*),TRIGS(*) - INTEGER :: INC,JUMP,N,LOT - -! -! SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1 -! (GRIDPOINT TO SPECTRAL TRANSFORM) -! - REAL(R8) :: SCALE, C, S - INTEGER :: NH, NX, INK, IA, IB, JA, JB, K, L, & - IABASE, JABASE, IBBASE, JBBASE - - NH=N/2 - NX=N+1 - INK=INC+INC -! -! A(0) AND A(N/2) - SCALE=1.0/FLOAT(N) - IA=1 - IB=2 - JA=1 - JB=N*INC+1 - - DO 10 L=1,LOT - A(JA)=SCALE*(WORK(IA)+WORK(IB)) - A(JB)=SCALE*(WORK(IA)-WORK(IB)) - A(JA+INC)=0.0 - A(JB+INC)=0.0 - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 10 CONTINUE -! -! REMAINING WAVENUMBERS - SCALE=0.5*SCALE - IABASE=3 - IBBASE=N-1 - JABASE=2*INC+1 - JBBASE=(N-2)*INC+1 -! - DO 30 K=3,NH,2 - IA=IABASE - IB=IBBASE - JA=JABASE - JB=JBBASE - C=TRIGS(N+K) - S=TRIGS(N+K+1) - - DO 20 L=1,LOT - A(JA)=SCALE*((WORK(IA)+WORK(IB)) & - +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JB)=SCALE*((WORK(IA)+WORK(IB)) & - -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB)))) - A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) & - +(WORK(IB+1)-WORK(IA+1))) - A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1))) & - -(WORK(IB+1)-WORK(IA+1))) - IA=IA+NX - IB=IB+NX - JA=JA+JUMP - JB=JB+JUMP - 20 CONTINUE - IABASE=IABASE+2 - IBBASE=IBBASE-2 - JABASE=JABASE+INK - JBBASE=JBBASE-INK - 30 CONTINUE -! - IF (IABASE.NE.IBBASE) GO TO 50 -! WAVENUMBER N/4 (IF IT EXISTS) - IA=IABASE - JA=JABASE - SCALE=2.0*SCALE - - DO 40 L=1,LOT - A(JA)=SCALE*WORK(IA) - A(JA+INC)=-SCALE*WORK(IA+1) - IA=IA+NX - JA=JA+JUMP - 40 CONTINUE -! - 50 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE FFT991(A,WORK,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - REAL(R8) :: A(*),WORK(*),TRIGS(*) - INTEGER :: IFAX(13), INC, JUMP, N, LOT, ISIGN - -! -! SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC -! FAST FOURIER TRANSFORM -! -! SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO -! THAT IN MRFFT2 -! -! PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM -! IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12 -! (1970), 315-337) -! -! A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA -! WORK IS AN AREA OF SIZE (N+1)*LOT -! TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES -! IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2 -! INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR' -! (E.G. INC=1 FOR CONSECUTIVELY STORED DATA) -! JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR -! N IS THE LENGTH OF THE DATA VECTORS -! LOT IS THE NUMBER OF DATA VECTORS -! ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT -! = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL -! -! ORDERING OF COEFFICIENTS: -! A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2) -! WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED -! -! ORDERING OF DATA: -! X(0),X(1),X(2),...,X(N-1) -! -! VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN -! PARALLEL -! -! *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER -! -! DEFINITION OF TRANSFORMS: -! ------------------------- -! -! ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N)) -! WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K) -! -! ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N)) -! B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N)) -! - INTEGER :: NFAX, NX, NH, INK, IGO, IBASE, JBASE, I, J, K, L, M, & - IA, LA, IB - - NFAX=IFAX(1) - NX=N+1 - NH=N/2 - INK=INC+INC - IF (ISIGN.EQ.+1) GO TO 30 - -! IF NECESSARY, TRANSFER DATA TO WORK AREA - IGO=50 - IF (MOD(NFAX,2).EQ.1) GOTO 40 - IBASE=1 - JBASE=1 - DO 20 L=1,LOT - I=IBASE - J=JBASE - - DO 10 M=1,N - WORK(J)=A(I) - I=I+INC - J=J+1 - 10 CONTINUE - IBASE=IBASE+JUMP - JBASE=JBASE+NX - 20 CONTINUE - - IGO=60 - GO TO 40 - -! PREPROCESSING (ISIGN=+1) -! ------------------------ - - 30 CONTINUE - CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT) - IGO=60 - -! COMPLEX TRANSFORM -! ----------------- - - 40 CONTINUE - IA=1 - LA=1 - DO 80 K=1,NFAX - IF (IGO.EQ.60) GO TO 60 - 50 CONTINUE - CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS, & - INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA) - IGO=60 - GO TO 70 - 60 CONTINUE - CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS, & - 2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA) - IGO=50 - 70 CONTINUE - LA=LA*IFAX(K+1) - 80 CONTINUE - - IF (ISIGN.EQ.-1) GO TO 130 - -! IF NECESSARY, TRANSFER DATA FROM WORK AREA - IF (MOD(NFAX,2).EQ.1) GO TO 110 - IBASE=1 - JBASE=1 - DO 100 L=1,LOT - I=IBASE - J=JBASE - - DO 90 M=1,N - A(J)=WORK(I) - I=I+1 - J=J+INC - 90 CONTINUE - IBASE=IBASE+NX - JBASE=JBASE+JUMP - 100 CONTINUE - -! FILL IN ZEROS AT END - 110 CONTINUE - IB=N*INC+1 - - DO 120 L=1,LOT - A(IB)=0.0 - A(IB+INC)=0.0 - IB=IB+JUMP - 120 CONTINUE - GO TO 140 - -! POSTPROCESSING (ISIGN=-1): -! -------------------------- - - 130 CONTINUE - CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT) - - 140 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE SET99 (TRIGS, IFAX, N) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - REAL(R8) :: TRIGS(*) - INTEGER :: IFAX(13), N - -! -! MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS. IT IS POSSIBLE -! TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT -! DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE -! WAS WRITTEN. -! - INTEGER :: MODE, I - - DATA MODE /3/ - CALL FAX (IFAX, N, MODE) - I = IFAX(1) - IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99 - IF (IFAX(1) .LE. 0 ) THEN - WRITE(6,*) ' SET99 -- INVALID N' - STOP 'SET99' - ENDIF - CALL FFTRIG (TRIGS, N, MODE) - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE FAX(IFAX,N,MODE) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - - INTEGER :: IFAX(10), N, MODE - - INTEGER :: NN, I, K, L, II, ISTOP, ITEM, INC, NFAX - - NN=N - IF (IABS(MODE).EQ.1) GO TO 10 - IF (IABS(MODE).EQ.8) GO TO 10 - NN=N/2 - IF ((NN+NN).EQ.N) GO TO 10 - IFAX(1)=-99 - RETURN - 10 K=1 -! TEST FOR FACTORS OF 4 - 20 IF (MOD(NN,4).NE.0) GO TO 30 - K=K+1 - IFAX(K)=4 - NN=NN/4 - IF (NN.EQ.1) GO TO 80 - GO TO 20 -! TEST FOR EXTRA FACTOR OF 2 - 30 IF (MOD(NN,2).NE.0) GO TO 40 - K=K+1 - IFAX(K)=2 - NN=NN/2 - IF (NN.EQ.1) GO TO 80 -! TEST FOR FACTORS OF 3 - 40 IF (MOD(NN,3).NE.0) GO TO 50 - K=K+1 - IFAX(K)=3 - NN=NN/3 - IF (NN.EQ.1) GO TO 80 - GO TO 40 -! NOW FIND REMAINING FACTORS - 50 L=5 - INC=2 -! INC ALTERNATELY TAKES ON VALUES 2 AND 4 - 60 IF (MOD(NN,L).NE.0) GO TO 70 - K=K+1 - IFAX(K)=L - NN=NN/L - IF (NN.EQ.1) GO TO 80 - GO TO 60 - 70 L=L+INC - INC=6-INC - GO TO 60 - 80 IFAX(1)=K-1 -! IFAX(1) CONTAINS NUMBER OF FACTORS - NFAX=IFAX(1) -! SORT FACTORS INTO ASCENDING ORDER - IF (NFAX.EQ.1) GO TO 110 - DO 100 II=2,NFAX - ISTOP=NFAX+2-II - DO 90 I=2,ISTOP - IF (IFAX(I+1).GE.IFAX(I)) GO TO 90 - ITEM=IFAX(I) - IFAX(I)=IFAX(I+1) - IFAX(I+1)=ITEM - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE FFTRIG(TRIGS,N,MODE) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - REAL(R8) :: TRIGS(*) - INTEGER :: N, MODE - - REAL(R8) :: PI, DEL, ANGLE - INTEGER :: IMODE, NN, I, L, NH, LA - -!BMP PI=2.0*ASIN(1.0) - PI=3.14159265358979323846_r8 - IMODE=IABS(MODE) - NN=N - IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2 - DEL=(PI+PI)/FLOAT(NN) - L=NN+NN - DO 10 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(I)=COS(ANGLE) - TRIGS(I+1)=SIN(ANGLE) - 10 CONTINUE - IF (IMODE.EQ.1) RETURN - IF (IMODE.EQ.8) RETURN - DEL=0.5*DEL - NH=(NN+1)/2 - L=NH+NH - LA=NN+NN - DO 20 I=1,L,2 - ANGLE=0.5*FLOAT(I-1)*DEL - TRIGS(LA+I)=COS(ANGLE) - TRIGS(LA+I+1)=SIN(ANGLE) - 20 CONTINUE - IF (IMODE.LE.3) RETURN - DEL=0.5*DEL - LA=LA+NN - IF (MODE.EQ.5) GO TO 40 - DO 30 I=2,NN - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=2.0*SIN(ANGLE) - 30 CONTINUE - RETURN - 40 CONTINUE - DEL=0.5*DEL - DO 50 I=2,N - ANGLE=FLOAT(I-1)*DEL - TRIGS(LA+I)=SIN(ANGLE) - 50 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- - SUBROUTINE VPASSM(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC,LA) - use shr_kind_mod, only : r8 => shr_kind_r8 - implicit none - REAL(R8) :: A(*),B(*),C(*),D(*),TRIGS(*) - INTEGER :: INC1,INC2,INC3,INC4,LOT,N,IFAC,LA - -! SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA" -! PERFORMS ONE PASS THROUGH DATA -! AS PART OF MULTIPLE COMPLEX FFT ROUTINE -! A IS FIRST REAL INPUT VECTOR -! B IS FIRST IMAGINARY INPUT VECTOR -! C IS FIRST REAL OUTPUT VECTOR -! D IS FIRST IMAGINARY OUTPUT VECTOR -! TRIGS IS PRECALCULATED TABLE OF SINES " COSINES -! INC1 IS ADDRESSING INCREMENT FOR A AND B -! INC2 IS ADDRESSING INCREMENT FOR C AND D -! INC3 IS ADDRESSING INCREMENT BETWEEN A"S & B"S -! INC4 IS ADDRESSING INCREMENT BETWEEN C"S & D"S -! LOT IS THE NUMBER OF VECTORS -! N IS LENGTH OF VECTORS -! IFAC IS CURRENT FACTOR OF N -! LA IS PRODUCT OF PREVIOUS FACTORS - - - REAL(R8) :: SIN36, COS36, SIN72, COS72, SIN60, & - C1, S1, C2, S2, C3, S3, C4, S4 - - INTEGER :: IINK, JINK, JUMP, IBASE, JBASE, IGO, & - IA, JA, IB, JB, KB, KC, IC, JC, ID, JD, KD, IE, JE, KE, & - I, J, K, L, M, LA1, IJK - - DATA SIN36/0.587785252292473_r8/,COS36/0.809016994374947_r8/, & - SIN72/0.951056516295154_r8/,COS72/0.309016994374947_r8/, & - SIN60/0.866025403784437_r8/ - - M=N/IFAC - IINK=M*INC1 - JINK=LA*INC2 - JUMP=(IFAC-1)*JINK - IBASE=0 - JBASE=0 - IGO=IFAC-1 - IF (IGO.GT.4) RETURN - GO TO (10,50,90,130),IGO - -! CODING FOR FACTOR 2 - - 10 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - DO 20 L=1,LA - I=IBASE - J=JBASE - - DO 15 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=A(IA+I)-A(IB+I) - D(JB+J)=B(IA+I)-B(IB+I) - I=I+INC3 - J=J+INC4 - 15 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 20 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 40 K=LA1,M,LA - KB=K+K-2 - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - DO 30 L=1,LA - I=IBASE - J=JBASE - - DO 25 IJK=1,LOT - C(JA+J)=A(IA+I)+A(IB+I) - D(JA+J)=B(IA+I)+B(IB+I) - C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I)) - D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I)) - I=I+INC3 - J=J+INC4 - 25 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 30 CONTINUE - JBASE=JBASE+JUMP - 40 CONTINUE - RETURN - -! CODING FOR FACTOR 3 - - 50 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - DO 60 L=1,LA - I=IBASE - J=JBASE - - DO 55 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))) - C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))) - D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))) - D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))) - I=I+INC3 - J=J+INC4 - 55 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 60 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 80 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - DO 70 L=1,LA - I=IBASE - J=JBASE - - DO 65 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I)) - C(JB+J)= & - C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) & - -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - D(JB+J)= & - S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))) & - +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))) - C(JC+J)= & - C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) & - -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - D(JC+J)= & - S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))) & - +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))) - I=I+INC3 - J=J+INC4 - 65 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 70 CONTINUE - JBASE=JBASE+JUMP - 80 CONTINUE - RETURN - -! CODING FOR FACTOR 4 - - 90 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - DO 100 L=1,LA - I=IBASE - J=JBASE - - DO 95 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)) - C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)) - C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)) - D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)) - D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)) - I=I+INC3 - J=J+INC4 - 95 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 100 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 120 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - DO 110 L=1,LA - I=IBASE - J=JBASE - - DO 105 IJK=1,LOT - C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I)) - D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I)) - C(JC+J)= & - C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) & - -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - D(JC+J)= & - S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))) & - +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))) - C(JB+J)= & - C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) & - -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - D(JB+J)= & - S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))) & - +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))) - C(JD+J)= & - C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) & - -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - D(JD+J)= & - S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))) & - +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 105 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 110 CONTINUE - JBASE=JBASE+JUMP - 120 CONTINUE - RETURN -! -! CODING FOR FACTOR 5 -! - 130 IA=1 - JA=1 - IB=IA+IINK - JB=JA+JINK - IC=IB+IINK - JC=JB+JINK - ID=IC+IINK - JD=JC+JINK - IE=ID+IINK - JE=JD+JINK - DO 140 L=1,LA - I=IBASE - J=JBASE - - DO 135 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))) - D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))) - C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))) - D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))) - I=I+INC3 - J=J+INC4 - 135 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 140 CONTINUE - IF (LA.EQ.M) RETURN - LA1=LA+1 - JBASE=JBASE+JUMP - DO 160 K=LA1,M,LA - KB=K+K-2 - KC=KB+KB - KD=KC+KB - KE=KD+KB - C1=TRIGS(KB+1) - S1=TRIGS(KB+2) - C2=TRIGS(KC+1) - S2=TRIGS(KC+2) - C3=TRIGS(KD+1) - S3=TRIGS(KD+2) - C4=TRIGS(KE+1) - S4=TRIGS(KE+2) - DO 150 L=1,LA - I=IBASE - J=JBASE - - DO 145 IJK=1,LOT - C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I)) - D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I)) - C(JB+J)= & - C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) & - -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JB+J)= & - S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) & - +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JE+J)= & - C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) & - -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - D(JE+J)= & - S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I))) & - +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))) & - +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I))) & - -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))) - C(JC+J)= & - C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) & - -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JC+J)= & - S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) & - +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - C(JD+J)= & - C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) & - -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - D(JD+J)= & - S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I))) & - +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))) & - +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I))) & - -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))) - I=I+INC3 - J=J+INC4 - 145 CONTINUE - IBASE=IBASE+INC1 - JBASE=JBASE+INC2 - 150 CONTINUE - JBASE=JBASE+JUMP - 160 CONTINUE - RETURN - END SUBROUTINE -!---------------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fill_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fill_module.F90 deleted file mode 100644 index 3c670a7b0..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/fill_module.F90 +++ /dev/null @@ -1,584 +0,0 @@ -module fill_module -!----------------------------------------------------------------------- -! $Id$ -!BOP -! -! !MODULE: fill_module --- utilities for filling in "bad" data - - use shr_kind_mod, only: r8 => shr_kind_r8 - -#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 - -! -! !PUBLIC MEMBER FUNCTIONS: - public filew, fillxy, fillz, filns, pfix - -! -! !DESCRIPTION: -! -! This module provides the basic utilities to fill in regions -! with bad "data", for example slightly negative values in fields -! which must be positive, like mixing ratios. Generally this -! means borrowing positive values from neighboring cells. -! -! !REVISION HISTORY: -! 99.03.01 Lin Creation -! 01.02.14 Lin Routines coalesced into this module -! 01.03.26 Sawyer Added ProTeX documentation -! 05.05.25 Sawyer Merged CAM and GEOS5 versions -! -!EOP -!----------------------------------------------------------------------- - -private -real(r8), parameter :: D0_0 = 0.0_r8 -real(r8), parameter :: D0_5 = 0.5_r8 -real(r8), parameter :: D1_0 = 1.0_r8 -real(r8), parameter :: D1_5 = 1.5_r8 - -contains - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: filew --- Fill from east and west neighbors; essentially -! performing local flux adjustment -! -! !INTERFACE: - subroutine filew(q, im, jm, jfirst, jlast, acap, ipx, tiny, cosp2) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - integer im ! Longitudes - integer jm ! Total latitudes - integer jfirst ! Starting latitude - integer jlast ! Finishing latitude - - real(r8) tiny ! A small number to pump up value - real(r8) acap ! 1/(polar cap area) - real(r8) cosp2 ! cosine(lat) at j=2 - -! !INPUT/OUTPUT PARAMETERS: - real(r8) q(im,jfirst:jlast) ! Field to adjust - -! !OUTPUT PARAMETERS: - integer ipx ! Flag: 0 if Q not change, 1 if changed - -! !DESCRIPTION: -! Check for "bad" data and fill from east and west neighbors -! -! !REVISION HISTORY: -! 01.99.10 Lin Creation -! 01.07.30 Lin Improvement -! -!EOP -!----------------------------------------------------------------------- -!BOC -! !LOCAL VARIABLES: - real(r8) d0, d1, d2 - real(r8) qtmp(jfirst:jlast,im) - real(r8) tinyl ! local tiny mixing ratio - real(r8) qmin - - integer i, j, jm1, ip2 - integer j1, j2 - integer imin, jmin - - j1 = max( jfirst, 2 ) - j2 = min( jlast, jm-1 ) - jm1 = jm-1 - ipx = 0 - -! Copy & swap direction for vectorization. - do j=j1,j2 - do i=1,im - qtmp(j,i) = q(i,j) - enddo - enddo - - do i=2,im-1 - do j=j1,j2 - if(qtmp(j,i) < D0_0) then - tinyl = max(D0_0,qtmp(j,i-1),qtmp(j,i+1))*tiny - ipx = 1 -! west - d0 = max(D0_0,qtmp(j,i-1)) - d1 = min(-qtmp(j,i),d0) - qtmp(j,i-1) = qtmp(j,i-1) - d1 - qtmp(j,i) = qtmp(j,i) + d1 -! east - d0 = max(D0_0,qtmp(j,i+1)) - d2 = min(-qtmp(j,i),d0) - qtmp(j,i+1) = qtmp(j,i+1) - d2 - qtmp(j,i) = qtmp(j,i) + d2 + tinyl - endif - enddo - enddo - - i=1 - do j=j1,j2 - if(qtmp(j,i) < D0_0) then - ipx = 1 - tinyl = max(D0_0,qtmp(j,im),qtmp(j,i+1))*tiny -! west - d0 = max(D0_0,qtmp(j,im)) - d1 = min(-qtmp(j,i),d0) - qtmp(j,im) = qtmp(j,im) - d1 - qtmp(j,i) = qtmp(j,i) + d1 -! east - d0 = max(D0_0,qtmp(j,i+1)) - d2 = min(-qtmp(j,i),d0) - qtmp(j,i+1) = qtmp(j,i+1) - d2 - qtmp(j,i) = qtmp(j,i) + d2 + tinyl - endif - enddo - - i=im - do j=j1,j2 - if(qtmp(j,i) < D0_0) then - ipx = 1 - tinyl = max(D0_0,qtmp(j,i-1),qtmp(j,1))*tiny -! west - d0 = max(D0_0,qtmp(j,i-1)) - d1 = min(-qtmp(j,i),d0) - qtmp(j,i-1) = qtmp(j,i-1) - d1 - qtmp(j,i) = qtmp(j,i) + d1 -! east - d0 = max(D0_0,qtmp(j,1)) - d2 = min(-qtmp(j,i),d0) - qtmp(j,1) = qtmp(j,1) - d2 - qtmp(j,i) = qtmp(j,i) + d2 + tinyl - endif - enddo - - if(ipx .ne. 0) then - -!----------- -! Final pass -!----------- - do i=1,im-1 - do j=j1,j2 - if (qtmp(j,i) < D0_0 ) then -! Take mass from east (essentially adjusting fx(i+1,j)) - qtmp(j,i+1) = qtmp(j,i+1) + qtmp(j,i) - qtmp(j,i) = D0_0 - endif - enddo - enddo - - do i=im,2,-1 - do j=j1,j2 - if (qtmp(j,i) < D0_0 ) then -! Take mass from west (essentially adjusting fx(i,j)) - qtmp(j,i-1) = qtmp(j,i-1) + qtmp(j,i) - qtmp(j,i) = D0_0 - endif - enddo - enddo - - do j=j1,j2 - - qmin = D0_0 - do i=1, im - if (qtmp(j,i) < qmin) then - qmin = qtmp(j,i) - imin = i - jmin = j - endif - enddo - - if ( qmin < D0_0 ) then - write (6,*) ' filew failed, worst i, j, qtmp, q = ', imin, jmin, qtmp(jmin,imin), q(imin,jmin) - end if - - do i=1,im - q(i,j) = qtmp(j,i) - enddo - enddo - - endif - -! Check Poles. - - if ( jfirst == 1 ) then - if(q(1,1) < D0_0) then - call pfix(q(1,2),q(1,1),im,ipx,acap,cosp2) - else -! Check j=2 - ip2 = 0 - do i=1,im - if(q(i,2).lt.D0_0) then - ip2 = 1 - go to 322 - endif - enddo -322 continue - if(ip2.ne.0) call pfix(q(1,2),q(1,1),im,ipx,acap,cosp2) - endif - endif - - if ( jlast == jm ) then - if(q(1,jm) < D0_0) then - call pfix(q(1,jm1),q(1,jm),im,ipx,acap,cosp2) - else -! Check j=jm1 - ip2 = 0 - do i=1,im - if(q(i,jm1) < D0_0) then - ip2 = 1 - go to 323 - endif - enddo -323 continue - if(ip2.ne.0) call pfix(q(1,jm1),q(1,jm),im,ipx,acap,cosp2) - endif - endif - -!EOC - end subroutine filew -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: fillxy --- Fill from east, west, north and south neighbors -! -! !INTERFACE: - subroutine fillxy(q, im, jm, jfirst, jlast, acap, cosp, acosp) - -! !USES: - - implicit none - - integer im ! Longitudes - integer jm ! Total latitudes - integer jfirst ! Starting latitude - integer jlast ! Finishing latitude - - real(r8) acap ! ??? - real(r8) cosp(jm) ! ??? - real(r8) acosp(jm) ! ??? -! -! !INPUT/OUTPUT PARAMETERS: - real(r8) q(im,jfirst:jlast) ! Field to adjust - -! !DESCRIPTION: -! Check for "bad" data and fill from east and west neighbors -! -! !BUGS: -! Currently this routine only performs the east-west fill algorithm. -! This is because the N-S fill is very hard to do in a reproducible -! fashion when the problem is decomposed by latitudes. -! -! !REVISION HISTORY: -! 99.03.01 Lin Creation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer ipx, ipy, j1, j2 - real(r8) tiny - parameter( tiny = 1.e-20_r8 ) - - call filew(q,im,jm,jfirst,jlast,acap,ipx,tiny,cosp(2)) - -! WS 99.08.03 : S.-J. can you clean up the j1, j2 stuff here? - if(ipx.ne.0) then - - j1 = max( 2, jfirst ) - j2 = min( jm-1, jlast ) -! -! WS 99.08.03 : see comments in "BUGS" above -!!! call filns(q,im,jm,j1,j2,cosp,acosp,ipy,tiny) - -! if(ipy .ne. 0) then -! do fill zonally -! xfx is problematic -! call xfix(q,IM,JM,tiny,qt) -! endif - - endif - -!EOC - end subroutine fillxy -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: fillz --- Fill from neighbors below and above -! -! !INTERFACE: - subroutine fillz(im, i1, i2, km, nq, q, dp) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: im ! No. of longitudes - integer, intent(in) :: km ! No. of levels - integer, intent(in) :: i1 ! Starting longitude - integer, intent(in) :: i2 ! Finishing longitude - integer, intent(in) :: nq ! Total number of tracers - real(r8), intent(in) :: dp(im,km) ! pressure thickness - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: q(im,km,nq) ! tracer mixing ratio - -! !DESCRIPTION: -! Check for "bad" data and fill from east and west neighbors -! -! !BUGS: -! Currently this routine only performs the east-west fill algorithm. -! This is because the N-S fill is very hard to do in a reproducible -! fashion when the problem is decomposed by latitudes. -! -! !REVISION HISTORY: -! 00.04.01 Lin Creation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i, k, ic - real(r8) qup, qly, dup - - do ic=1,nq -! Top layer - do i=i1,i2 - if( q(i,1,ic) < D0_0) then - q(i,2,ic) = q(i,2,ic) + q(i,1,ic)*dp(i,1)/dp(i,2) - q(i,1,ic) = D0_0 - endif - enddo - -! Interior - do k=2,km-1 - do i=i1,i2 - if( q(i,k,ic) < D0_0 ) then -! Borrow from above - qup = q(i,k-1,ic)*dp(i,k-1) - qly = -q(i,k ,ic)*dp(i,k ) - dup = min( D0_5*qly, qup ) !borrow no more than 50% - q(i,k-1,ic) = q(i,k-1,ic) - dup/dp(i,k-1) -! Borrow from below: q(i,k,ic) is still negative at this stage - q(i,k+1,ic) = q(i,k+1,ic) + (dup-qly)/dp(i,k+1) - q(i,k ,ic) = D0_0 - endif - enddo - enddo - -! Bottom layer - k = km - do i=i1,i2 - if( q(i,k,ic) < D0_0) then -! Borrow from above - qup = q(i,k-1,ic)*dp(i,k-1) - qly = -q(i,k ,ic)*dp(i,k ) - dup = min( qly, qup ) - q(i,k-1,ic) = q(i,k-1,ic) - dup/dp(i,k-1) - q(i,k,ic) = D0_0 - endif - enddo - enddo -!EOC -end subroutine fillz -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: filns --- Fill from north and south neighbors -! -! !INTERFACE: - subroutine filns(q,im,jm,j1,j2,cosp,acosp,ipy,tiny) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - integer im ! Longitudes - integer jm ! Total latitudes - integer j1 ! Starting latitude - integer j2 ! Finishing latitude - - - real(r8) tiny ! A small number to pump up value - real(r8) cosp(*) ! ??? - real(r8) acosp(*) ! ??? - -! !INPUT/OUTPUT PARAMETERS: - real(r8) q(im,*) ! Field to adjust - -! !OUTPUT PARAMETERS: - integer ipy ! Flag: 0 if no fill-in, 1 if fill-in - -! !DESCRIPTION: -! Check for "bad" data and fill from north and south neighbors -! -! !BUGS: -! Currently this routine can only be used performs when the -! problem is *not* distributed in latitude (i.e. j1=1, j2=jm). -! This is because the N-S fill is very hard to do in a reproducible -! fashion when the problem is decomposed by latitudes. -! -! !REVISION HISTORY: -! 99.03.01 Lin Creation -! 05.06.30 Sawyer Removed SAVE attribute for cap1 (recalculated) -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i, j -! This definition of PI as opposed to 4._r16*atan(1._r16) does not -! appear to generate non-zero differences in GEOS5 checkpoint files - real(R16),parameter :: pi = 3.1415926535897932384626433832795028841971_R16 - real(r8) :: dp, cap1, dq, dn, ds, d0, d1, d2 - - dp = pi/real(jm-1,r16) - cap1 = im*(D1_0-cos((j1-D1_5)*dp))/dp - - ipy = 0 - do j=j1+1,j2-1 - do i=1,im - if(q(i,j).lt.D0_0) then - ipy = 1 - dq = - q(i,j)*cosp(j) -! North - dn = q(i,j+1)*cosp(j+1) - d0 = max(D0_0,dn) - d1 = min(dq,d0) - q(i,j+1) = (dn - d1)*acosp(j+1) - dq = dq - d1 -! South - ds = q(i,j-1)*cosp(j-1) - d0 = max(D0_0,ds) - d2 = min(dq,d0) - q(i,j-1) = (ds - d2)*acosp(j-1) - q(i,j) = (d2 - dq)*acosp(j) + tiny - endif - enddo - enddo - - do i=1,im - if(q(i,j1).lt.D0_0) then - ipy = 1 - dq = - q(i,j1)*cosp(j1) -! North - dn = q(i,j1+1)*cosp(j1+1) - d0 = max(D0_0,dn) - d1 = min(dq,d0) - q(i,j1+1) = (dn - d1)*acosp(j1+1) - q(i,j1) = (d1 - dq)*acosp(j1) + tiny - endif - enddo - - j = j2 - do i=1,im - if(q(i,j).lt.D0_0) then - ipy = 1 - dq = - q(i,j)*cosp(j) -! South - ds = q(i,j-1)*cosp(j-1) - d0 = max(D0_0,ds) - d2 = min(dq,d0) - q(i,j-1) = (ds - d2)*acosp(j-1) - q(i,j) = (d2 - dq)*acosp(j) + tiny - endif - enddo - -! Check Poles. - if(q(1,1).lt.D0_0) then - dq = q(1,1)*cap1/real(im,r8)*acosp(j1) - do i=1,im - q(i,1) = tiny - q(i,j1) = q(i,j1) + dq - q(i,j1) = max(tiny, q(i,j1) + dq ) - enddo - endif - - if(q(1,jm).lt.D0_0) then - dq = q(1,jm)*cap1/real(im,r8)*acosp(j2) - do i=1,im - q(i,jm) = tiny - q(i,j2) = max(tiny, q(i,j2) + dq ) - enddo - endif -!EOC - end subroutine filns -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: pfix --- fix an individual latitude-level -! -! !INTERFACE: - subroutine pfix(q, qp, im, ipx, acap, cosp2) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im ! Longitudes - real(r8) acap ! ??? - real(r8) cosp2 ! ??? - -! !INPUT/OUTPUT PARAMETERS: - real(r8) q(im) ! Latitude-level field to adjust - real(r8) qp(im) ! Second latitude-level field to adjust (usually pole) - -! !OUTPUT PARAMETERS: - integer ipx ! Flag: 0 if Q not change, 1 if changed - - -! !DESCRIPTION: -! Fill one latitude-level from east and west neighbors -! -! !REVISION HISTORY: -! 99.03.01 Lin Creation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i - real(r8) summ, sump, pmean - - summ = D0_0 - sump = D0_0 - do i=1,im - summ = summ + q(i) - sump = sump + qp(i) - enddo - - sump = sump/im - pmean = (sump*acap + summ*cosp2) / (acap + cosp2*im) - - do i=1,im - q(i) = pmean - qp(i) = pmean - enddo - - if( qp(1) < D0_0 ) then - ipx = 1 - endif - -!EOC - end subroutine pfix -!----------------------------------------------------------------------- - -end module fill_module diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/geopk.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/geopk.F90 deleted file mode 100644 index 97d1c76c9..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/geopk.F90 +++ /dev/null @@ -1,630 +0,0 @@ -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: geopk --- Calculate geopotential to the kappa -! -!----------------------------------------------------------------------- -! There are two versions of geopk below. The first is the standard -! version and is typically used with transposes between yz and xy -! space. The second (called geopk16) operates in yz space and performs -! semi-global communication in the z direction (to avoid transposes). -! It also can use 16-byte reals to preserve accuracy through round-off; -! this is accomplished by toggling DsIZE to 16 immediately below. -! Note that the interfaces to the two versions are slightly different. -! Also, geopk (the standard version with transposes) is called for -! the D-grid during the last small timestep in cd_core. -! Geopk16 uses mod_comm communication calls; one can activate the old -! Pilgrim calls (for debugging) by activating PaREXCH immediately below. - -!#define PAREXCH -!#define DSIZE 16 -#define DSIZE 8 - -#if (DSIZE == 16) -# define DTWO 2 -#else -# define DTWO 1 -#endif -!----------------------------------------------------------------------- -! -! !INTERFACE: - subroutine geopk(grid, pe, delp, pk, wz, hs, pt, cp, akap, nx) - - use shr_kind_mod, only: r8 => shr_kind_r8 - use dynamics_vars, only: T_FVDYCORE_GRID - - 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 - -! !INPUT PARAMETERS: - - type (T_FVDYCORE_GRID), intent(in) :: grid - integer, intent(in) :: nx ! # of pieces in longitude direction - real(r8), intent(in) :: akap, cp - real(r8), intent(in) :: hs(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) - real(r8), intent(in) :: pt(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - real(r8), intent(in) :: delp(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - -! !OUTPUT PARAMETERS: - real(r8) wz(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) ! space N*1 S*1 - real(r8) pk(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) ! space N*1 S*1 - real(r8) pe(grid%ifirstxy:grid%ilastxy,grid%km+1,grid%jfirstxy:grid%jlastxy) - -! !DESCRIPTION: -! Calculates geopotential and pressure to the kappa. This is an expensive -! operation and several out arrays are kept around for future use. -! -! !REVISION HISTORY: -! -! WS 99.10.22: MPIed SJ's original SMP version -! SJL 00.01.01: Merged C-core and D-core computation -! SMP "decmposition" in E-W by combining i and j loops -! WS 00.12.01: Replaced MPI_ON with SPMD; hs now distributed -! AAM 01.06.27: Generalize for 2D decomposition -! AAM 01.07.24: Removed dpcheck -! WS 04.10.07: Simplified interface using Grid as input argument -! WS 05.05.25: Merged CAM and GEOS5 versions (mostly CAM) -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! Local: - real(r8), parameter :: D0_0 = 0.0_r8 - integer :: im, jm, km, jfirst, jlast, ifirst, ilast - real(r8) :: ptop - - integer i, j, k - integer ixj, jp, it, i1, i2, nxu, itot - real(r8) delpp(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - - ptop = grid%ptop - im = grid%im - jm = grid%jm - km = grid%km - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - itot = ilast - ifirst + 1 -! nxu = nx - nxu = 1 - it = itot / nxu - jp = nxu * ( jlast - jfirst + 1 ) - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i1, i2, ixj, i, j, k ) - -! do 2000 j=jfirst,jlast - do 2000 ixj=1, jp - - j = jfirst + (ixj-1)/nxu - i1 = ifirst + it * mod(ixj-1, nxu) - i2 = i1 + it - 1 - - do i=i1,i2 - pe(i,1,j) = D0_0 - wz(i,j,km+1) = D0_0 - enddo - -! Top down - do k=2,km+1 - do i=i1,i2 - pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) - enddo - enddo - do k=1,km+1 - do i=i1,i2 - pe(i,k,j) = pe(i,k,j) + ptop - pk(i,j,k) = pe(i,k,j)**akap - enddo - enddo - -! Bottom up - do k=1,km - do i=i1,i2 - delpp(i,j,k) = cp*pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k)) - enddo - enddo - do k=km,1,-1 - do i=i1,i2 - wz(i,j,k) = wz(i,j,k+1)+delpp(i,j,k) - enddo - enddo - do k=1,km+1 - do i=i1,i2 - wz(i,j,k) = wz(i,j,k)+hs(i,j) - enddo - enddo -2000 continue - - return -!EOC - end subroutine geopk -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: geopk16 --- Calculate geopotential to the kappa -! -! !INTERFACE: - subroutine geopk16(grid, pe, delp, pk, wz, hs, pt, ng, cp, akap ) - - use shr_kind_mod, only : r8 => shr_kind_r8, i8 => shr_kind_i8 - use decompmodule, only : decomptype - use dynamics_vars, only : T_FVDYCORE_GRID - -#if defined( SPMD ) - use parutilitiesmodule, only : parexchangevector - use mod_comm, only : numpro, blockdescriptor, get_partneroffset, & - commglobal, mp_swapirr, max_nparcels -#endif - - implicit none - -#if defined ( SPMD ) -#include "mpif.h" -#endif - -! !INPUT PARAMETERS: - - type (T_FVDYCORE_GRID), intent(in) :: grid - integer, intent(in) :: ng ! Halo size (not always = ng_d) - - real(r8) akap, cp - real(r8), intent(in):: hs(1:grid%im,grid%jfirst:grid%jlast) - -! !INPUT PARAMETERS: - real(r8) pt(1:grid%im,grid%jfirst-ng:grid%jlast+ng,grid%kfirst:grid%klast) - real(r8) delp(1:grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - -! !OUTPUT PARAMETERS: - real(r8) wz(1:grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) ! space N*1 S*1 - real(r8) pk(1:grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) ! space N*1 S*1 - real(r8) pe(1:grid%im,grid%kfirst:grid%klast+1,grid%jfirst:grid%jlast) ! temporary variable - -! !DESCRIPTION: -! Calculates geopotential and pressure to the kappa. This is an expensive -! operation and several out arrays are kept around for future use. -! To preserve accuracy through round-off, 16-byte reals are used -! for some intermediate data. -! -! !REVISION HISTORY: -! -! AAM 00.12.18: Original version -! AAM 03.01.21: Use mod_comm -! WS 03.11.19: Merged latest CAM version (by AAM) -! WS 04.10.07: Simplified interface using Grid as input argument -! WS 05.05.17: Merged CAM and GEOS5 versions -! -!EOP -!--------------------------------------------------------------------- -!BOC - -#ifndef NO_CRAY_POINTERS - -! Local: - integer :: i, j, k, nk, ijtot, ierror, ione - - integer :: im,jm,km, ifirst, ilast, jfirst, jlast, kfirst, klast - real(r8):: ptop - - integer :: npr_y, npr_z, myid_y, myid_z - integer :: twod_decomp, mod_geopk - -#if (DSIZE == 16) - real(r16), parameter :: DP0_0 = 0.0_r16 - real(r16) delp16(1:grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - real(r16) pe16(1:grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) - real(r16) inbuf(1:grid%im,grid%jfirst:grid%jlast,0:grid%npr_z-1) - real(r16) outbuf(1:grid%im,grid%jfirst:grid%jlast,0:grid%npr_z-1) -#else - real (r8), parameter :: DP0_0 = 0.0_r8 - real (r8) delp16(1:grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - real (r8) pe16(1:grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast+1) - real (r8) inbuf(1:grid%im,grid%jfirst:grid%jlast,0:grid%npr_z-1) - real (r8) outbuf(1:grid%im,grid%jfirst:grid%jlast,0:grid%npr_z-1) -#endif - integer sendcount(0:grid%npr_z-1), recvcount(0:grid%npr_z-1) - -#if defined(SPMD) -! -! data structures for mp_swapirr -! - type (blockdescriptor), allocatable, save :: sendbl1(:), recvbl1(:) - type (blockdescriptor), allocatable, save :: sendbl2(:), recvbl2(:) - -#endif - - integer first_time_through - data first_time_through / 0 / - -! Arrays inbuf8 and outbuf8 are created to fool the compiler -! into accepting them as calling arguments for parexchangevector. -! The trickery below equivalences them to inbuf and outbuf - real (r8) inbuf8(1), outbuf8(1) - pointer (ptr_inbuf8, inbuf8) - pointer (ptr_outbuf8, outbuf8) - integer (i8) locinbuf, locoutbuf - -! -! Initialize variables from Grid -! - ptop = grid%ptop - - im = grid%im - jm = grid%jm - km = grid%km - - ifirst = 1 ! 2004.10.04 (WS): Now hardwired for 1..im - ilast = grid%im ! Code was always used in this mode - jfirst = grid%jfirst - jlast = grid%jlast - kfirst = grid%kfirst - klast = grid%klast - - myid_y = grid%myid_y - myid_z = grid%myid_z - - npr_y = grid%npr_y - npr_z = grid%npr_z - - twod_decomp = grid%twod_decomp - mod_geopk = grid%mod_geopk - - ijtot = (jlast-jfirst+1) * (ilast-ifirst+1) - -#if defined (SPMD) - if (first_time_through .eq. 0) then - first_time_through = 1 - ione = 1 - if (npr_z .gt. 1) then - allocate( sendbl1(0:numpro-1) ) - allocate( recvbl1(0:numpro-1) ) - allocate( sendbl2(0:numpro-1) ) - allocate( recvbl2(0:numpro-1) ) - - do nk = 0,numpro-1 - - sendbl1(nk)%method = mod_geopk - sendbl2(nk)%method = mod_geopk - recvbl1(nk)%method = mod_geopk - recvbl2(nk)%method = mod_geopk - -! allocate for either method (safety) - allocate( sendbl1(nk)%blocksizes(1) ) - allocate( sendbl1(nk)%displacements(1) ) - allocate( recvbl1(nk)%blocksizes(1) ) - allocate( recvbl1(nk)%displacements(1) ) - allocate( sendbl2(nk)%blocksizes(1) ) - allocate( sendbl2(nk)%displacements(1) ) - allocate( recvbl2(nk)%blocksizes(1) ) - allocate( recvbl2(nk)%displacements(1) ) - - sendbl1(nk)%type = MPI_DATATYPE_NULL - - if ( (nk/npr_y) > myid_z .and. mod(nk,npr_y) == myid_y ) then - - if (mod_geopk .ne. 0) then - call MPI_TYPE_INDEXED(ione, DTWO*ijtot, & - DTWO*ijtot*(klast-kfirst+1), MPI_DOUBLE_PRECISION, & - sendbl1(nk)%type, ierror) - call MPI_TYPE_COMMIT(sendbl1(nk)%type, ierror) - endif - - sendbl1(nk)%blocksizes(1) = DTWO*ijtot - sendbl1(nk)%displacements(1) = DTWO*ijtot*(klast-kfirst+1) - sendbl1(nk)%partneroffset = myid_z * ijtot * DTWO - - else - - sendbl1(nk)%blocksizes(1) = 0 - sendbl1(nk)%displacements(1) = 0 - sendbl1(nk)%partneroffset = 0 - - endif - sendbl1(nk)%nparcels = size(sendbl1(nk)%displacements) - sendbl1(nk)%tot_size = sum(sendbl1(nk)%blocksizes) - max_nparcels = max(max_nparcels, sendbl1(nk)%nparcels) - - recvbl1(nk)%type = MPI_DATATYPE_NULL - - if ( (nk/npr_y) < myid_z .and. mod(nk,npr_y) == myid_y ) then - - if (mod_geopk .ne. 0) then - call MPI_TYPE_INDEXED(ione, DTWO*ijtot, & - nk/npr_y * ijtot * DTWO, MPI_DOUBLE_PRECISION, & - recvbl1(nk)%type, ierror) - call MPI_TYPE_COMMIT(recvbl1(nk)%type, ierror) - endif - - recvbl1(nk)%blocksizes(1) = DTWO*ijtot - recvbl1(nk)%displacements(1) = nk/npr_y * ijtot * DTWO - recvbl1(nk)%partneroffset = 0 - - else - - recvbl1(nk)%blocksizes(1) = 0 - recvbl1(nk)%displacements(1) = 0 - recvbl1(nk)%partneroffset = 0 - - endif - recvbl1(nk)%nparcels = size(recvbl1(nk)%displacements) - recvbl1(nk)%tot_size = sum(recvbl1(nk)%blocksizes) - max_nparcels = max(max_nparcels, recvbl1(nk)%nparcels) - - if ( (nk/npr_y) < myid_z .and. mod(nk,npr_y) == myid_y ) then - - call MPI_TYPE_INDEXED(ione, DTWO*ijtot, & - 0, MPI_DOUBLE_PRECISION, & - sendbl2(nk)%type, ierror) - call MPI_TYPE_COMMIT(sendbl2(nk)%type, ierror) - - sendbl2(nk)%blocksizes(1) = DTWO*ijtot - sendbl2(nk)%displacements(1) = 0 - sendbl2(nk)%partneroffset = (myid_z-nk/npr_y-1) * ijtot * DTWO - - else - - sendbl2(nk)%type = MPI_DATATYPE_NULL - - sendbl2(nk)%blocksizes(1) = 0 - sendbl2(nk)%displacements(1) = 0 - sendbl2(nk)%partneroffset = 0 - - endif - sendbl2(nk)%nparcels = size(sendbl2(nk)%displacements) - sendbl2(nk)%tot_size = sum(sendbl2(nk)%blocksizes) - max_nparcels = max(max_nparcels, sendbl2(nk)%nparcels) - - if ( (nk/npr_y) > myid_z .and. mod(nk,npr_y) == myid_y ) then - - call MPI_TYPE_INDEXED(ione, DTWO*ijtot, & - nk/npr_y * ijtot * DTWO, MPI_DOUBLE_PRECISION, & - recvbl2(nk)%type, ierror) - call MPI_TYPE_COMMIT(recvbl2(nk)%type, ierror) - - recvbl2(nk)%blocksizes(1) = DTWO*ijtot - recvbl2(nk)%displacements(1) = nk/npr_y * ijtot * DTWO - recvbl2(nk)%partneroffset = 0 - - else - - recvbl2(nk)%type = MPI_DATATYPE_NULL - - recvbl2(nk)%blocksizes(1) = 0 - recvbl2(nk)%displacements(1) = 0 - recvbl2(nk)%partneroffset = 0 - - endif - recvbl2(nk)%nparcels = size(recvbl2(nk)%displacements) - recvbl2(nk)%tot_size = sum(recvbl2(nk)%blocksizes) - max_nparcels = max(max_nparcels, recvbl2(nk)%nparcels) - enddo - - call get_partneroffset(commglobal, sendbl1, recvbl1) - call get_partneroffset(commglobal, sendbl2, recvbl2) - - endif - endif - -#if (!defined PAREXCH) - locinbuf = loc(pe16) -#else - locinbuf = loc(inbuf) -#endif - locoutbuf = loc(outbuf) - ptr_inbuf8 = locinbuf - ptr_outbuf8 = locoutbuf -#endif - -! Top down - -#if (DSIZE == 16) -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j, k) - do k = kfirst,klast - do j = jfirst,jlast - do i = ifirst,ilast - delp16(i,j,k) = delp(i,j,k) - enddo - enddo - enddo -#endif - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j) - do j = jfirst,jlast - do i = ifirst,ilast - pe16(i,j,kfirst) = DP0_0 - enddo - enddo - -! compute partial sums - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j, k) - do j = jfirst,jlast - do k = kfirst+1,klast+1 - do i = ifirst,ilast -#if (DSIZE == 16) - pe16(i,j,k) = pe16(i,j,k-1) + delp16(i,j,k-1) -#else - pe16(i,j,k) = pe16(i,j,k-1) + delp(i,j,k-1) -#endif - enddo - enddo - enddo - -#if defined( SPMD ) - if (npr_z .gt. 1) then - -! communicate upward - -# if !defined (PAREXCH) - call mp_swapirr(commglobal, sendbl1, recvbl1, inbuf8, outbuf8) -# else - - do nk = 0, npr_z-1 - sendcount(nk) = 0 - recvcount(nk) = 0 - enddo - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j, nk) - do nk = myid_z+1, npr_z-1 - do j = jfirst,jlast - do i = ifirst,ilast - inbuf(i,j,nk-myid_z-1) = pe16(i,j,klast+1) - enddo - enddo -! Double sendcount since quantities are 16-bytes long - sendcount(nk) = DTWO*ijtot - enddo - - call parexchangevector(grid%comm_z, sendcount, inbuf8, recvcount, outbuf8) - -# endif - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j, k, nk) - do k = kfirst,klast+1 - do nk = 0, myid_z-1 - do j = jfirst,jlast - do i = ifirst,ilast - pe16(i,j,k) = pe16(i,j,k) + outbuf(i,j,nk) - enddo - enddo - enddo - enddo - - endif -#endif - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j, k) - do k = kfirst,klast+1 - do j = jfirst,jlast - do i = ifirst,ilast - pe(i,k,j) = pe16(i,j,k) + ptop - pk(i,j,k) = pe(i,k,j) ** akap - enddo - enddo - enddo - -! Bottom up - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j, k) - do k = kfirst,klast - do j = jfirst,jlast - do i = ifirst,ilast - delp16(i,j,k) = cp*pt(i,j,k)*(pk(i,j,k+1)-pk(i,j,k)) - enddo - enddo - enddo - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j) - do j = jfirst,jlast - do i = ifirst,ilast - pe16(i,j,klast+1) = DP0_0 - enddo - enddo - -! compute partial sums - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j, k) - do j = jfirst,jlast - do k = klast,kfirst,-1 - do i = ifirst,ilast - pe16(i,j,k) = pe16(i,j,k+1) + delp16(i,j,k) - enddo - enddo - enddo - -#if defined( SPMD ) - if (npr_z .gt. 1) then - -! communicate downward - -# if !defined (PAREXCH) - call mp_swapirr(commglobal, sendbl2, recvbl2, inbuf8, outbuf8) -# else - - do nk = 0, npr_z-1 - sendcount(nk) = 0 - recvcount(nk) = 0 - enddo - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j, nk) - do nk = 0, myid_z-1 - do j = jfirst,jlast - do i = ifirst,ilast - inbuf(i,j,nk) = pe16(i,j,kfirst) - enddo - enddo -! Double sendcount since quantities are 16-bytes long - sendcount(nk) = DTWO*ijtot - enddo - - call parexchangevector(grid%comm_z, sendcount, inbuf8, recvcount, outbuf8) - -# endif - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j, k, nk) - do k = kfirst,klast+1 - do nk = myid_z+1, npr_z-1 - do j = jfirst,jlast - do i = ifirst,ilast -# if !defined (PAREXCH) - pe16(i,j,k) = pe16(i,j,k) + outbuf(i,j,nk) -# else - pe16(i,j,k) = pe16(i,j,k) + outbuf(i,j,nk-myid_z-1) -# endif - enddo - enddo - enddo - enddo - - endif -#endif - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, j, k) - do k = kfirst,klast+1 - do j = jfirst,jlast - do i = ifirst,ilast - wz(i,j,k) = pe16(i,j,k) + hs(i,j) - enddo - enddo - enddo - - return -! endif for NO_CRAY_POINTERS -#endif -!EOC - end subroutine geopk16 -!----------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/glosum.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/glosum.F90 deleted file mode 100644 index 4b1f0c4e8..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/glosum.F90 +++ /dev/null @@ -1,114 +0,0 @@ -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: glosum --- Calculate global sum of an A-Grid Tracer -! -! !INTERFACE: - - subroutine glosum (STATE,NQ,QG) - -! !USES: - - use shr_kind_mod, only : r8 => shr_kind_r8, r4 => shr_kind_r4 - use dynamics_vars, only : T_FVDYCORE_STATE, T_FVDYCORE_GRID - implicit none - - type(T_FVDYCORE_STATE), intent(IN) :: STATE - integer, intent(IN) :: NQ - real(r8), intent(OUT) :: QG(NQ) - -! !DESCRIPTION: -! Calculate the globally integrated tracer -! -!EOP -!--------------------------------------------------------------------- -!BOC - - integer :: im, jm, km - integer :: iam - integer :: i1,in,j1,jn,jt,j,k,n - - real (r4), pointer :: ptr4(:,:,:) - real (r8), pointer :: ptr8(:,:,:) - real (r8), allocatable :: dp(:,:,:) - real (r8), allocatable :: dA(:,:) - real (r8), allocatable :: qj(:) - real (r8), allocatable :: qsum(:,:) - real (r8), allocatable :: xsum(:) - - real (r8), parameter :: D0_0 = 0.0_r8 - - im = state%grid%im - jm = state%grid%jm - km = state%grid%km - iam = state%grid%iam - - i1 = state%grid%ifirstxy - in = state%grid%ilastxy - j1 = state%grid%jfirstxy - jn = state%grid%jlastxy - jt = jn - j1 + 1 - -!----------------------------------------------------------------------------------------------- - - allocate( dp(i1:in,j1:jn,km) ) - allocate( dA(i1:in,j1:jn) ) - allocate( qsum(i1:in,j1:jn) ) - allocate( xsum(j1:jn) ) - allocate( qj(jm) ) - -! Compute Grid-Box Area -! --------------------- - do j=j1,jn - if ( j == 1 ) then - dA(:,j) = state%grid%acap * state%grid%dl*state%grid%dp ! => 2*pi [1-cos(dp/2)] - else if ( j == jm ) then - dA(:,j) = state%grid%acap * state%grid%dl*state%grid%dp ! => 2*pi [1-cos(dp/2)] - else - dA(:,j) = state%grid%cosp(j) * state%grid%dl*state%grid%dp - endif - enddo - -! Compute Pressure Thickness -! -------------------------- - do k=1,km - dp(:,:,k) = state%vars%pe(:,:,k+1)-state%vars%pe(:,:,k) - enddo - -! Loop over Tracers -! ----------------- - do n=1,NQ - qsum(:,:) = D0_0 - if( STATE%VARS%TRACER(N)%IS_R4 ) then - do k=1,km - qsum(:,:) = qsum(:,:) + state%vars%tracer(n)%content_r4(:,:,k)*dp(:,:,k) - enddo - else - do k=1,km - qsum(:,:) = qsum(:,:) + state%vars%tracer(n)%content (:,:,k)*dp(:,:,k) - enddo - endif - qsum(:,:) = qsum(:,:) *dA(:,:) - - call par_xsum (state%grid,qsum,jt,xsum) - do j=j1,jn - if ( j == 1 ) then - qj(j) = qsum(i1,j) - else if ( j == jm ) then - qj(j) = qsum(i1,j) - else - qj(j) = xsum(j) - endif - enddo - call par_vecsum (jm, j1, jn, qj, qg(n), state%grid%commxy_y, state%grid%nprxy_y) - -! if( iam==0 ) print *, 'The global sum for Tracer ',n,' is: ',qg(n) - enddo - - deallocate( dp ) - deallocate( dA ) - deallocate( qj ) - deallocate( qsum ) - deallocate( xsum ) - - return - end subroutine glosum diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/gmap.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/gmap.F90 deleted file mode 100644 index 0cab9746b..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/gmap.F90 +++ /dev/null @@ -1,516 +0,0 @@ -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine gmap(im, jm, nq, akap, & - km, pk3d_m, pe3d_m, u_m, v_m, pt_m, q_m, & - kn, pk3d_n, pe3d_n, u_n, v_n, pt_n, q_n ) -!****6***0*********0*********0*********0*********0*********0**********72 - - implicit none - - integer im, jm - integer km, kn, nq - -! Input: -! original data km-level - - real*8 u_m(im,jm,km) - real*8 v_m(im,jm,km) - real*8 pt_m(im,jm,km) - real*8 q_m(im,jm,km,nq) - real*8 pk3d_m(im,jm,km+1) - real*8 pe3d_m(im,jm,km+1) - - real*8 pk3d_n(im,jm,kn+1) - real*8 pe3d_n(im,jm,kn+1) - -! Output: -! New data (kn-level) - real*8 u_n(im,jm,kn) - real*8 v_n(im,jm,kn) - real*8 pt_n(im,jm,kn) - real*8 q_n(im,jm,kn,nq) - -! local (private) - integer i, j, k, n, ic - - real*8 pe1(im,km+1) ,pe2(im,kn+1) - real*8 pk1(im,km+1) ,pk2(im,kn+1) - real*8 dp1(im,km) ,dp2(im,kn) - real*8 u1(im,km) , u2(im,kn) - real*8 v1(im,km) , v2(im,kn) - real*8 t1(im,km) , t2(im,kn) - real*8 q1(im,km,nq), q2(im,kn,nq) - - real*8 ptop - real*8 akap - real*8 ple, pek, dak, bkh - real*8 undef - real*8 big - parameter ( undef = 1.e15 ) - parameter ( big = 1.e10 ) - - do 2000 j=1,jm - -! Copy original data to local 2D arrays. - - do k=1,km+1 - do i=1,im - pe1(i,k) = pe3d_m(i,j,k) - pk1(i,k) = pk3d_m(i,j,k) - enddo - enddo - - do k=1,kn+1 - do i=1,im - pe2(i,k) = pe3d_n(i,j,k) - pk2(i,k) = pk3d_n(i,j,k) - enddo - enddo - - do k=1,km - do i=1,im - dp1(i,k) = pk1(i,k+1)-pk1(i,k) - u1(i,k) = u_m(i,j,k) - v1(i,k) = v_m(i,j,k) - t1(i,k) = pt_m(i,j,k) - enddo - enddo - do n=1,nq - do k=1,km - do i=1,im - q1(i,k,n) = q_m(i,j,k,n) - enddo - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pk2(i,k+1)-pk2(i,k) - enddo - enddo - -! map pt -! ------ - call mappm ( km, pk1, dp1, t1, kn, pk2, dp2, t2, im, 1, 7 ) - - do k=1,km - do i=1,im - dp1(i,k) = pe1(i,k+1)-pe1(i,k) - enddo - enddo - - do k=1,kn - do i=1,im - dp2(i,k) = pe2(i,k+1)-pe2(i,k) - enddo - enddo - -! map u,v,q,oz -! ------------ - do n=1,nq - call mappm ( km, pe1, dp1, q1(1,1,n), kn, pe2, dp2, q2(1,1,n), im, 0, 7 ) - enddo - call mappm ( km, pe1, dp1, u1, kn, pe2, dp2, u2, im, -1, 7 ) - call mappm ( km, pe1, dp1, v1, kn, pe2, dp2, v2, im, -1, 7 ) - - do k=1,kn - do i=1,im - u_n(i,j,k) = u2(i,k) - v_n(i,j,k) = v2(i,k) - pt_n(i,j,k) = t2(i,k) - enddo - enddo - do n=1,nq - do k=1,kn - do i=1,im - q_n(i,j,k,n) = q2(i,k,n) - enddo - enddo - enddo - -2000 continue - - return - end - - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine mappm(km, pe1, dp1, q1, kn, pe2, dp2, q2, im, iv, kord) -!****6***0*********0*********0*********0*********0*********0**********72 -! IV = 0: constituents -! IV = 1: potential temp -! IV =-1: winds -! -! Mass flux preserving mapping: q1(im,km) -> q2(im,kn) -! -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate - - parameter (kmax = 200) - parameter (R3 = 1./3., R23 = 2./3.) - - real*8 dp1(im,km), dp2(im,kn), & - q1(im,km), q2(im,kn), & - pe1(im,km+1), pe2(im,kn+1) - integer kord - -! local work arrays - real*8 a4(4,im,km) - - do k=1,km - do i=1,im - a4(1,i,k) = q1(i,k) - enddo - enddo - - call ppm2m(a4, dp1, im, km, iv, kord) - -! Lowest layer: constant distribution - do i=1, im - a4(2,i,km) = q1(i,km) - a4(3,i,km) = q1(i,km) - a4(4,i,km) = 0. - enddo - - do 5555 i=1,im - k0 = 1 - do 555 k=1,kn - - if(pe2(i,k+1) .le. pe1(i,1)) then -! Entire grid above old ptop - q2(i,k) = a4(2,i,1) - elseif(pe2(i,k) .ge. pe1(i,km+1)) then -! Entire grid below old ps - q2(i,k) = a4(3,i,km) - elseif(pe2(i,k ) .lt. pe1(i,1) .and. & - pe2(i,k+1) .gt. pe1(i,1)) then -! Part of the grid above ptop - q2(i,k) = a4(1,i,1) - else - - do 45 L=k0,km -! locate the top edge at pe2(i,k) - if( pe2(i,k) .ge. pe1(i,L) .and. & - pe2(i,k) .le. pe1(i,L+1) ) then - k0 = L - PL = (pe2(i,k)-pe1(i,L)) / dp1(i,L) - if(pe2(i,k+1) .le. pe1(i,L+1)) then - -! entire new grid is within the original grid - PR = (pe2(i,k+1)-pe1(i,L)) / dp1(i,L) - TT = R3*(PR*(PR+PL)+PL**2) - q2(i,k) = a4(2,i,L) + 0.5*(a4(4,i,L)+a4(3,i,L) & - - a4(2,i,L))*(PR+PL) - a4(4,i,L)*TT - goto 555 - else -! Fractional area... - delp = pe1(i,L+1) - pe2(i,k) - TT = R3*(1.+PL*(1.+PL)) - qsum = delp*(a4(2,i,L)+0.5*(a4(4,i,L)+ & - a4(3,i,L)-a4(2,i,L))*(1.+PL)-a4(4,i,L)*TT) - dpsum = delp - k1 = L + 1 - goto 111 - endif - endif -45 continue - -111 continue - do 55 L=k1,km - if( pe2(i,k+1) .gt. pe1(i,L+1) ) then - -! Whole layer.. - - qsum = qsum + dp1(i,L)*q1(i,L) - dpsum = dpsum + dp1(i,L) - else - delp = pe2(i,k+1)-pe1(i,L) - esl = delp / dp1(i,L) - qsum = qsum + delp * (a4(2,i,L)+0.5*esl* & - (a4(3,i,L)-a4(2,i,L)+a4(4,i,L)*(1.-r23*esl)) ) - dpsum = dpsum + delp - k0 = L - goto 123 - endif -55 continue - delp = pe2(i,k+1) - pe1(i,km+1) - if(delp .gt. 0.) then -! Extended below old ps - qsum = qsum + delp * a4(3,i,km) - dpsum = dpsum + delp - endif -123 q2(i,k) = qsum / dpsum - endif -555 continue -5555 continue - - return - end - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine ppm2m(a4,delp,im,km,iv,kord) -!****6***0*********0*********0*********0*********0*********0**********72 -! iv = 0: positive definite scalars -! iv = 1: others -! iv =-1: winds - - implicit none - - integer im, km, lmt, iv - integer kord - integer i, k, km1 - real*8 a4(4,im,km), delp(im,km) - -! local arrays. - real*8 dc(im,km),delq(im,km) - real*8 h2(im,km) - real*8 a1, a2, a3, b2, c1, c2, c3, d1, d2, f1, f2, f3, f4 - real*8 s1, s2, s3, s4, ss3, s32, s34, s42, sc - real*8 qmax, qmin, cmax, cmin - real*8 dm, qm, dq, tmp - -! Local scalars: - real*8 qmp - real*8 lac - - km1 = km - 1 - - do 500 k=2,km - do 500 i=1,im - delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) -500 a4(4,i,k ) = delp(i,k-1) + delp(i,k) - - do 1220 k=2,km1 - do 1220 i=1,im - c1 = (delp(i,k-1)+0.5*delp(i,k))/a4(4,i,k+1) - c2 = (delp(i,k+1)+0.5*delp(i,k))/a4(4,i,k) - tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / & - (a4(4,i,k)+delp(i,k+1)) - qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k) - qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp) -1220 continue - -!****6***0*********0*********0*********0*********0*********0**********72 -! 4th order interpolation of the provisional cell edge value -!****6***0*********0*********0*********0*********0*********0**********72 - - do 12 k=3,km1 - do 12 i=1,im - c1 = delq(i,k-1)*delp(i,k-1) / a4(4,i,k) - a1 = a4(4,i,k-1) / (a4(4,i,k) + delp(i,k-1)) - a2 = a4(4,i,k+1) / (a4(4,i,k) + delp(i,k)) - a4(2,i,k) = a4(1,i,k-1) + c1 + 2./(a4(4,i,k-1)+a4(4,i,k+1)) * & - ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - & - delp(i,k-1)*a1*dc(i,k ) ) -12 continue - -! Area preserving cubic with 2nd deriv. = 0 at the boundaries -! Top - do i=1,im - d1 = delp(i,1) - d2 = delp(i,2) - qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) - dq = 2.*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) - c1 = 4.*(a4(2,i,3)-qm-d2*dq) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) - c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1) - a4(2,i,1) = d1*(2.*c1*d1**2-c3) + a4(2,i,2) - dc(i,1) = a4(1,i,1) - a4(2,i,1) -! No over- and undershoot condition - cmax = max(a4(1,i,1), a4(1,i,2)) - cmin = min(a4(1,i,1), a4(1,i,2)) - a4(2,i,2) = max(cmin,a4(2,i,2)) - a4(2,i,2) = min(cmax,a4(2,i,2)) - enddo - - if(iv == 0) then - do i=1,im - a4(2,i,1) = max(0.,a4(2,i,1)) - a4(2,i,2) = max(0.,a4(2,i,2)) - enddo - elseif(iv == -1) then - do i=1,im - if( a4(2,i,1)*a4(1,i,1) <= 0. ) a4(2,i,1) = 0. - enddo - endif - -!****6***0*********0*********0*********0*********0*********0**********72 - -! Bottom -! Area preserving cubic with 2nd deriv. = 0 at the surface - do 15 i=1,im - d1 = delp(i,km) - d2 = delp(i,km1) - qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) - dq = 2.*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) - c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) - c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2) - a4(2,i,km) = qm - c1*d1*d2*(d2+3.*d1) - a4(3,i,km) = d1*(8.*c1*d1**2-c3) + a4(2,i,km) - dc(i,km) = a4(3,i,km) - a4(1,i,km) -!****6***0*********0*********0*********0*********0*********0**********72 -! No over- and undershoot condition - cmax = max(a4(1,i,km), a4(1,i,km1)) - cmin = min(a4(1,i,km), a4(1,i,km1)) - a4(2,i,km) = max(cmin,a4(2,i,km)) - a4(2,i,km) = min(cmax,a4(2,i,km)) -!****6***0*********0*********0*********0*********0*********0**********72 -15 continue - - if(iv .eq. 0) then - do i=1,im - a4(2,i,km) = max(0.,a4(2,i,km)) - a4(3,i,km) = max(0.,a4(3,i,km)) - enddo - endif - - do 20 k=1,km1 - do 20 i=1,im - a4(3,i,k) = a4(2,i,k+1) -20 continue -! -! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) -! - -! Top 2 and bottom 2 layers always use monotonic mapping - - do k=1,2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) - enddo - - if(kord == 7) then -!****6***0*********0*********0*********0*********0*********0**********72 -! Huynh's 2nd constraint -!****6***0*********0*********0*********0*********0*********0**********72 - do k=2, km1 - do i=1,im - h2(i,k) = delq(i,k) - delq(i,k-1) - enddo - enddo - - do 4000 k=3, km-2 - do 3000 i=1, im -! Right edges - qmp = a4(1,i,k) + 2.0*delq(i,k-1) - lac = a4(1,i,k) + 1.5*h2(i,k-1) + 0.5*delq(i,k-1) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax) -! Left edges - qmp = a4(1,i,k) - 2.0*delq(i,k) - lac = a4(1,i,k) + 1.5*h2(i,k+1) - 0.5*delq(i,k) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax) -! Recompute A6 - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) -3000 continue -! Additional constraint to prevent negatives - if (iv == 0) then - call kmppm(dc(1,k),a4(1,1,k),im, 2) - endif -4000 continue - - else - - lmt = kord - 3 - lmt = max(0, lmt) - if (iv .eq. 0) lmt = min(2, lmt) - - do k=3, km-2 - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, lmt) - enddo - endif - - do 5000 k=km1,km - do i=1,im - a4(4,i,k) = 3.*(2.*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(1,k),a4(1,1,k),im, 0) -5000 continue - - return - end - -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine kmppm(dm, a4, km, lmt) -!****6***0*********0*********0*********0*********0*********0**********72 - implicit none - - real*8 r12 - parameter (r12 = 1./12.) - - integer km, lmt - integer i - real*8 a4(4,km),dm(km) - real*8 da1, da2, a6da - real*8 fmin - real*8 qmp - - if (lmt .eq. 3) return -! Full constraint - - if(lmt .eq. 0) then - do 100 i=1,km - if(dm(i) .eq. 0.) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = 0. - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da .lt. -da2) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da .gt. da2) then - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif -100 continue - elseif (lmt .eq. 2) then -! Positive definite - -! Positive definite constraint - do 250 i=1,km - if(abs(a4(3,i)-a4(2,i)) .ge. -a4(4,i)) go to 250 - fmin = a4(1,i)+0.25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 - if(fmin.ge.0.) go to 250 - if(a4(1,i).lt.a4(3,i) .and. a4(1,i).lt.a4(2,i)) then - a4(3,i) = a4(1,i) - a4(2,i) = a4(1,i) - a4(4,i) = 0. - elseif(a4(3,i) .gt. a4(2,i)) then - a4(4,i) = 3.*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - else - a4(4,i) = 3.*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif -250 continue - - elseif (lmt == 1) then - -! Improved full monotonicity constraint (Lin) -! Note: no need to provide first guess of A6 <-- a4(4,i) - - do i=1, km - qmp = 2.*dm(i) - a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) - a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) - a4(4,i) = 3.*( 2.*a4(1,i) - (a4(2,i)+a4(3,i)) ) - enddo - endif - - return - end - diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/mapz_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/mapz_module.F90 deleted file mode 100644 index 0446a6e4f..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/mapz_module.F90 +++ /dev/null @@ -1,1334 +0,0 @@ -module mapz_module - - use shr_kind_mod, only : r8 => shr_kind_r8 - use dynamics_vars, only : t_tracers - use FVperf_module, only : FVstartclock, FVstopclock - - public map1_cubic_te, map1_ppm, mapn_ppm, mapn_ppm_tracer, ppme - - private - - real(r8), parameter :: D0_0 = 0.0_r8 - real(r8), parameter :: D1EM14 = 1.0e-14_r8 - real(r8), parameter :: D0_125 = 0.125_r8 - real(r8), parameter :: D0_1875 = 0.1875_r8 - real(r8), parameter :: D0_25 = 0.25_r8 - real(r8), parameter :: D0_5 = 0.5_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D1_5 = 1.5_r8 - real(r8), parameter :: D2_0 = 2.0_r8 - real(r8), parameter :: D3_0 = 3.0_r8 - real(r8), parameter :: D4_0 = 4.0_r8 - real(r8), parameter :: D5_0 = 5.0_r8 - real(r8), parameter :: D8_0 = 8.0_r8 - real(r8), parameter :: D12_0 = 12.0_r8 - -contains - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: map1_cubic_te --- Cubic Interpolation for TE mapping -! -! !INTERFACE: - subroutine map1_cubic_te ( km, pe1, q1, kn, pe2, q2, & - ng_s, ng_n, itot, i1, i2, & - j, jfirst, jlast, iv, kord) - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: i1 ! Starting longitude - integer, intent(in) :: i2 ! Finishing longitude - integer, intent(in) :: itot ! Total latitudes - integer, intent(in) :: iv ! Mode: 0 == constituents 1 == ??? - integer, intent(in) :: kord ! Method order - integer, intent(in) :: j ! Current latitude - integer, intent(in) :: jfirst ! Starting latitude - integer, intent(in) :: jlast ! Finishing latitude - integer, intent(in) :: ng_s ! Ghosted latitudes south - integer, intent(in) :: ng_n ! Ghosted latitudes north - integer, intent(in) :: km ! Original vertical dimension - integer, intent(in) :: kn ! Target vertical dimension - - real(r8), intent(in) :: pe1(itot,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the original vertical coordinate - real(r8), intent(in) :: pe2(itot,kn+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the new vertical coordinate - - real(r8), intent(in) :: q1(itot,jfirst-ng_s:jlast+ng_n,km) ! Field input - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout):: q2(itot,jfirst-ng_s:jlast+ng_n,kn) ! Field output - -! !DESCRIPTION: -! -! Perform Cubic Interpolation a given latitude -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate -! -! !REVISION HISTORY: -! 05.11.14 Takacs Initial Code -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real(r8) qx(i1:i2,km) - real(r8) logpl1(i1:i2,km) - real(r8) logpl2(i1:i2,kn) - real(r8) dlogp1(i1:i2,km) - real(r8) vsum1(i1:i2) - real(r8) vsum2(i1:i2) - real(r8) am2,am1,ap0,ap1,P,PLP1,PLP0,PLM1,PLM2,DLP0,DLM1,DLM2 - - integer i, k, LM2,LM1,LP0,LP1 - -! Initialization -! -------------- - do k=1,km - qx(:,k) = q1(:,j,k) - logpl1(:,k) = log( D0_5*(pe1(:,k)+pe1(:,k+1)) ) - enddo - do k=1,kn - logpl2(:,k) = log( D0_5*(pe2(:,k)+pe2(:,k+1)) ) - enddo - - do k=1,km-1 - dlogp1(:,k) = logpl1(:,k+1)-logpl1(:,k) - enddo - -! Compute vertical integral of Input TE -! ------------------------------------- - vsum1(:) = D0_0 - do i=i1,i2 - do k=1,km - vsum1(i) = vsum1(i) + qx(i,k)*( pe1(i,k+1)-pe1(i,k) ) - enddo - vsum1(i) = vsum1(i) / ( pe1(i,km+1)-pe1(i,1) ) - enddo - -! Interpolate TE onto target Pressures -! ------------------------------------ - do i=i1,i2 - do k=1,kn - LM1 = 1 - LP0 = 1 - do while( LP0.le.km ) - if (logpl1(i,LP0).lt.logpl2(i,k)) then - LP0 = LP0+1 - else - exit - endif - enddo - LM1 = max(LP0-1,1) - LP0 = min(LP0, km) - -! Extrapolate Linearly in LogP above first model level -! ---------------------------------------------------- - if( LM1.eq.1 .and. LP0.eq.1 ) then - q2(i,j,k) = qx(i,1) + ( qx(i,2)-qx(i,1) )*( logpl2(i,k)-logpl1(i,1) ) & - /( logpl1(i,2)-logpl1(i,1) ) - -! Extrapolate Linearly in LogP below last model level -! --------------------------------------------------- - else if( LM1.eq.km .and. LP0.eq.km ) then - q2(i,j,k) = qx(i,km) + ( qx(i,km)-qx(i,km-1) )*( logpl2(i,k )-logpl1(i,km ) ) & - /( logpl1(i,km)-logpl1(i,km-1) ) - -! Interpolate Linearly in LogP between levels 1 => 2 and km-1 => km -! ----------------------------------------------------------------- - else if( LM1.eq.1 .or. LP0.eq.km ) then - q2(i,j,k) = qx(i,LP0) + ( qx(i,LM1)-qx(i,LP0) )*( logpl2(i,k )-logpl1(i,LP0) ) & - /( logpl1(i,LM1)-logpl1(i,LP0) ) - -! Interpolate Cubicly in LogP between other model levels -! ------------------------------------------------------ - else - LP1 = LP0+1 - LM2 = LM1-1 - P = logpl2(i,k) - PLP1 = logpl1(i,LP1) - PLP0 = logpl1(i,LP0) - PLM1 = logpl1(i,LM1) - PLM2 = logpl1(i,LM2) - DLP0 = dlogp1(i,LP0) - DLM1 = dlogp1(i,LM1) - DLM2 = dlogp1(i,LM2) - - ap1 = (P-PLP0)*(P-PLM1)*(P-PLM2)/( DLP0*(DLP0+DLM1)*(DLP0+DLM1+DLM2) ) - ap0 = (PLP1-P)*(P-PLM1)*(P-PLM2)/( DLP0* DLM1 *( DLM1+DLM2) ) - am1 = (PLP1-P)*(PLP0-P)*(P-PLM2)/( DLM1* DLM2 *(DLP0+DLM1 ) ) - am2 = (PLP1-P)*(PLP0-P)*(PLM1-P)/( DLM2*(DLM1+DLM2)*(DLP0+DLM1+DLM2) ) - - q2(i,j,k) = ap1*qx(i,LP1) + ap0*qx(i,LP0) + am1*qx(i,LM1) + am2*qx(i,LM2) - - endif - - enddo - enddo - -! Compute vertical integral of Output TE -! -------------------------------------- - vsum2(:) = D0_0 - do i=i1,i2 - do k=1,kn - vsum2(i) = vsum2(i) + q2(i,j,k)*( pe2(i,k+1)-pe2(i,k) ) - enddo - vsum2(i) = vsum2(i) / ( pe2(i,kn+1)-pe2(i,1) ) - enddo - -! Adjust Final TE to conserve -! --------------------------- - do i=i1,i2 - do k=1,kn - q2(i,j,k) = q2(i,j,k) + vsum1(i)-vsum2(i) -! q2(i,j,k) = q2(i,j,k) * vsum1(i)/vsum2(i) - enddo - enddo - - return -!EOC - end subroutine map1_cubic_te -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: map1_ppm --- Piecewise parabolic mapping, variant 1 -! -! !INTERFACE: - subroutine map1_ppm( km, pe1, q1, kn, pe2, q2, & - ng_s, ng_n, itot, i1, i2, & - j, jfirst, jlast, iv, kord) - - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: i1 ! Starting longitude - integer, intent(in) :: i2 ! Finishing longitude - integer, intent(in) :: itot ! Total latitudes - integer, intent(in) :: iv ! Mode: 0 == constituents 1 == ??? - integer, intent(in) :: kord ! Method order - integer, intent(in) :: j ! Current latitude - integer, intent(in) :: jfirst ! Starting latitude - integer, intent(in) :: jlast ! Finishing latitude - integer, intent(in) :: ng_s ! Ghosted latitudes south - integer, intent(in) :: ng_n ! Ghosted latitudes north - integer, intent(in) :: km ! Original vertical dimension - integer, intent(in) :: kn ! Target vertical dimension - - real(r8), intent(in) :: pe1(itot,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the original vertical coordinate - real(r8), intent(in) :: pe2(itot,kn+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the new vertical coordinate - real(r8), intent(in) :: q1(itot,jfirst-ng_s:jlast+ng_n,km) ! Field input - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout):: q2(itot,jfirst-ng_s:jlast+ng_n,kn) ! Field output - -! !DESCRIPTION: -! -! Perform piecewise parabolic method on a given latitude -! IV = 0: constituents -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate -! -! !REVISION HISTORY: -! 00.04.24 Lin Last modification -! 01.03.26 Sawyer Added ProTeX documentation -! 02.04.04 Sawyer incorporated latest FVGCM version -! 02.06.20 Sawyer made Q2 inout since the args for Q1/Q2 same -! 03.07.22 Parks Cleaned main loop, removed gotos -! 05.05.25 Sawyer Merged CAM and GEOS5 versions -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real(r8) r3, r23 - parameter (r3 = D1_0/D3_0, r23 = D2_0/D3_0) - real(r8) dp1(i1:i2,km) - real(r8) q4(4,i1:i2,km) - - integer i, k, kk, kl, k0(i1:i2,0:kn+1) - real(r8) pl, pr, qsum, qsumk(i1:i2,kn), delp, esl - - do k=1,km - do i=i1,i2 - dp1(i,k) = pe1(i,k+1) - pe1(i,k) - q4(1,i,k) = q1(i,j,k) - enddo - enddo - -! Mapping - -! Compute vertical subgrid distribution - call ppm2m( q4, dp1, km, i1, i2, iv, kord ) - -! For each pe2(i,k), determine lowest pe1 interval = smallest k0 (= k0(i,k)) -! such that pe1(i,k0) <= pe2(i,k) <= pe1(i,k0+1) -! Note that pe2(i,1)==pe1(i,1) and pe2(i,kn+1)==pe1(i,kn+1) -! Note also that pe1, pe2 are assumed to be monotonically increasing -#if defined( UNICOSMP ) || defined ( NEC_SX ) - do kk = km, 1, -1 - do k = 1, kn+1 -!dir$ prefervector - do i = i1, i2 - if (pe2(i,k) <= pe1(i,kk+1)) then - k0(i,k) = kk - endif - enddo - enddo - enddo -#else - do i = i1, i2 - k0(i,0) = 1 - do k = 1, kn+1 - do kk = k0(i,k-1), km - if (pe2(i,k) <= pe1(i,kk+1)) then - k0(i,k) = kk - exit - endif - enddo - enddo - enddo -#endif - -! Interpolate - do k = 1, kn - -! Prepare contribution between pe1(i,ko(i,k)+1) and pe1(i,k0(i,k+1)) - qsumk(:,k) = D0_0 - do i = i1, i2 - do kl = k0(i,k)+1, k0(i,k+1)-1 - qsumk(i,k) = qsumk(i,k) + dp1(i,kl)*q4(1,i,kl) - enddo - enddo - - do i = i1, i2 - kk = k0(i,k) -! Consider contribution between pe1(i,kk) and pe2(i,k) - pl = (pe2(i,k)-pe1(i,kk)) / dp1(i,kk) -! Check to see if pe2(i,k+1) and pe2(i,k) are in same pe1 interval - if (k0(i,k+1) == k0(i,k)) then - pr = (pe2(i,k+1)-pe1(i,kk)) / dp1(i,kk) - q2(i,j,k) = q4(2,i,kk) + D0_5*(q4(4,i,kk)+q4(3,i,kk)-q4(2,i,kk)) & - *(pr+pl) - q4(4,i,kk)*r3*(pr*(pr+pl)+pl**2) - else -! Consider contribution between pe2(i,k) and pe1(i,kk+1) - qsum = (pe1(i,kk+1)-pe2(i,k))*(q4(2,i,kk)+D0_5*(q4(4,i,kk)+ & - q4(3,i,kk)-q4(2,i,kk))*(D1_0+pl)-q4(4,i,kk)* & - (r3*(D1_0+pl*(D1_0+pl)))) -! Next consider contribution between pe1(i,kk+1) and pe1(i,k0(i,k+1)) - qsum = qsum + qsumk(i,k) -! Now consider contribution between pe1(i,k0(i,k+1)) and pe2(i,k+1) - kl = k0(i,k+1) - delp = pe2(i,k+1)-pe1(i,kl) - esl = delp / dp1(i,kl) - qsum = qsum + delp*(q4(2,i,kl)+D0_5*esl* & - (q4(3,i,kl)-q4(2,i,kl)+q4(4,i,kl)*(D1_0-r23*esl))) - q2(i,j,k) = qsum / ( pe2(i,k+1) - pe2(i,k) ) - endif - enddo - enddo - - return -!EOC - end subroutine map1_ppm -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: mapn_ppm --- Piecewise parabolic mapping, variant 1 -! -! !INTERFACE: - subroutine mapn_ppm(km, pe1, q1, nq, & - kn, pe2, q2, ng_s, ng_n, & - itot, i1, i2, j, & - jfirst, jlast, iv, kord) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: i1 ! Starting longitude - integer, intent(in) :: i2 ! Finishing longitude - integer, intent(in) :: itot ! Total latitudes - integer, intent(in) :: iv ! Mode: 0 == constituents 1 == ??? - integer, intent(in) :: kord ! Method order - integer, intent(in) :: j ! Current latitude - integer, intent(in) :: jfirst ! Starting latitude - integer, intent(in) :: jlast ! Finishing latitude - integer, intent(in) :: ng_s ! Ghosted latitudes south - integer, intent(in) :: ng_n ! Ghosted latitudes north - integer, intent(in) :: km ! Original vertical dimension - integer, intent(in) :: kn ! Target vertical dimension - integer, intent(in) :: nq ! Number of tracers - - real(r8), intent(in) :: pe1(itot,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the original vertical coordinate - real(r8), intent(in) :: pe2(itot,kn+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the new vertical coordinate - real(r8), intent(in) :: q1(itot,jfirst-ng_s:jlast+ng_n,km,nq) ! Field input -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout):: q2(itot,jfirst-ng_s:jlast+ng_n,kn,nq) ! Field output - -! !DESCRIPTION: -! -! Perform piecewise parabolic method on a given latitude -! IV = 0: constituents -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate -! -! !REVISION HISTORY: -! 02.04.04 Sawyer incorporated latest FVGCM version, ProTeX -! 02.06.20 Sawyer made Q2 inout since the args for Q1/Q2 same -! 03.07.22 Parks Cleaned main loop, removed gotos -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real(r8) r3, r23 - parameter (r3 = D1_0/D3_0, r23 = D2_0/D3_0) - real(r8) dp1(i1:i2,km) - real(r8) q4(4,i1:i2,km) - - integer i, k, kk, kl, k0(i1:i2,0:kn+1), iq - real(r8) pl, pr, qsum, qsumk(i1:i2,kn), delp, esl - - do k=1,km - do i=i1,i2 - dp1(i,k) = pe1(i,k+1) - pe1(i,k) - enddo - enddo - -! Mapping - -! For each pe2(i,k), determine lowest pe1 interval = smallest k0 (= k0(i,k)) -! such that pe1(i,k0) <= pe2(i,k) <= pe1(i,k0+1) -! Note that pe2(i,1)==pe1(i,1) and pe2(i,kn+1)==pe1(i,kn+1) -! Note also that pe1, pe2 are assumed to be monotonically increasing -#if defined( UNICOSMP ) || defined ( NEC_SX ) - do kk = km, 1, -1 - do k = 1, kn+1 -!dir$ prefervector - do i = i1, i2 - if (pe2(i,k) <= pe1(i,kk+1)) then - k0(i,k) = kk - endif - enddo - enddo - enddo -#else - do i = i1, i2 - k0(i,0) = 1 - do k = 1, kn+1 - do kk = k0(i,k-1), km - if (pe2(i,k) <= pe1(i,kk+1)) then - k0(i,k) = kk - exit - endif - enddo - enddo - enddo -#endif - - do iq=1,nq - - do k=1,km - do i=i1,i2 - q4(1,i,k) = q1(i,j,k,iq) - enddo - enddo - -! Compute vertical subgrid distribution - call ppm2m( q4, dp1, km, i1, i2, iv, kord ) -! Interpolate - do k = 1, kn - -! Prepare contribution between pe1(i,ko(i,k)+1) and pe1(i,k0(i,k+1)) - qsumk(:,k) = D0_0 - do i = i1, i2 - do kl = k0(i,k)+1, k0(i,k+1)-1 - qsumk(i,k) = qsumk(i,k) + dp1(i,kl)*q4(1,i,kl) - enddo - enddo - - do i = i1, i2 - kk = k0(i,k) -! Consider contribution between pe1(i,kk) and pe2(i,k) - pl = (pe2(i,k)-pe1(i,kk)) / dp1(i,kk) -! Check to see if pe2(i,k+1) and pe2(i,k) are in same pe1 interval - if (k0(i,k+1) == k0(i,k)) then - pr = (pe2(i,k+1)-pe1(i,kk)) / dp1(i,kk) - q2(i,j,k,iq) = q4(2,i,kk) + D0_5*(q4(4,i,kk)+q4(3,i,kk)-q4(2,i,kk)) & - *(pr+pl) - q4(4,i,kk)*r3*(pr*(pr+pl)+pl**2) - else -! Consider contribution between pe2(i,k) and pe1(i,kk+1) - qsum = (pe1(i,kk+1)-pe2(i,k))*(q4(2,i,kk)+D0_5*(q4(4,i,kk)+ & - q4(3,i,kk)-q4(2,i,kk))*(D1_0+pl)-q4(4,i,kk)* & - (r3*(D1_0+pl*(D1_0+pl)))) -! Next consider contribution between pe1(i,kk+1) and pe1(i,k0(i,k+1)) - qsum = qsum + qsumk(i,k) -! Now consider contribution between pe1(i,k0(i,k+1)) and pe2(i,k+1) - kl = k0(i,k+1) - delp = pe2(i,k+1)-pe1(i,kl) - esl = delp / dp1(i,kl) - qsum = qsum + delp*(q4(2,i,kl)+D0_5*esl* & - (q4(3,i,kl)-q4(2,i,kl)+q4(4,i,kl)*(D1_0-r23*esl))) - q2(i,j,k,iq) = qsum / ( pe2(i,k+1) - pe2(i,k) ) - endif - enddo - enddo - - enddo - - return -!EOC - end subroutine mapn_ppm -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: mapn_ppm_tracer --- Piecewise parabolic mapping, multiple tracers -! -! !INTERFACE: - subroutine mapn_ppm_tracer(km, pe1, tracer, nq, & - kn, pe2, i1, i2, j, & - ifirst, ilast, jfirst, jlast, iv, kord) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: i1 ! Starting longitude - integer, intent(in) :: i2 ! Finishing longitude - integer, intent(in) :: iv ! Mode: 0 == constituents 1 == ??? - integer, intent(in) :: kord ! Method order - integer, intent(in) :: j ! Current latitude - integer, intent(in) :: ifirst ! Starting segment - integer, intent(in) :: ilast ! Finishing segment - integer, intent(in) :: jfirst ! Starting latitude - integer, intent(in) :: jlast ! Finishing latitude - integer, intent(in) :: km ! Original vertical dimension - integer, intent(in) :: kn ! Target vertical dimension - integer, intent(in) :: nq ! Number of tracers - - real(r8), intent(in) :: pe1(ifirst:ilast,km+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the original vertical coordinate - real(r8), intent(in) :: pe2(ifirst:ilast,kn+1) ! pressure at layer edges - ! (from model top to bottom surface) - ! in the new vertical coordinate -! !INPUT/OUTPUT PARAMETERS: - type (t_tracers), intent(inout):: tracer(nq) ! Field output - -! !DESCRIPTION: -! -! Perform piecewise parabolic method on a given latitude -! IV = 0: constituents -! pe1: pressure at layer edges (from model top to bottom surface) -! in the original vertical coordinate -! pe2: pressure at layer edges (from model top to bottom surface) -! in the new vertical coordinate -! -! !REVISION HISTORY: -! 05.03.20 Sawyer Created from mapn_ppm -! 05.04.04 Sawyer Simplified indexing, removed ifirst -! 05.04.12 Sawyer Added r4/r8 distinction -! 05.10.12 Worley Made mapn_ppm_tracer vector-friendly -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - - real(r8) r3, r23 - parameter (r3 = D1_0/D3_0, r23 = D2_0/D3_0) - - real(r8) dp1(i1:i2,km) - real(r8) q4(4,i1:i2,km) - - integer i, k, kk, kl, k0(i1:i2,0:kn+1), iq - real(r8) pl, pr, qsum, qsumk(i1:i2,kn), delp, esl - - do k=1,km - do i=i1,i2 - dp1(i,k) = pe1(i,k+1) - pe1(i,k) - enddo - enddo - -! Mapping - -! For each pe2(i,k), determine lowest pe1 interval = smallest k0 (= k0(i,k)) -! such that pe1(i,k0) <= pe2(i,k) <= pe1(i,k0+1) -! Note that pe2(i,1)==pe1(i,1) and pe2(i,kn+1)==pe1(i,kn+1) -! Note also that pe1, pe2 are assumed to be monotonically increasing -#if defined( UNICOSMP ) || defined ( NEC_SX ) - do kk = km, 1, -1 - do k = 1, kn+1 -!dir$ prefervector - do i = i1, i2 - if (pe2(i,k) <= pe1(i,kk+1)) then - k0(i,k) = kk - endif - enddo - enddo - enddo -#else - do i = i1, i2 - k0(i,0) = 1 - do k = 1, kn+1 - do kk = k0(i,k-1), km - if (pe2(i,k) <= pe1(i,kk+1)) then - k0(i,k) = kk - exit - endif - enddo - enddo - enddo -#endif - - do iq=1,nq - if ( tracer(iq)%is_r4) then - do k=1,km - do i=i1,i2 - q4(1,i,k) = tracer(iq)%content_r4(i,j,k) - enddo - enddo - else - do k=1,km - do i=i1,i2 - q4(1,i,k) = tracer(iq)%content(i,j,k) - enddo - enddo - endif - -! Compute vertical subgrid distribution - call ppm2m( q4, dp1, km, i1, i2, iv, kord ) - - if ( tracer(iq)%is_r4) then -! Interpolate - do k = 1, kn - -! Prepare contribution between pe1(i,ko(i,k)+1) and pe1(i,k0(i,k+1)) - qsumk(:,k) = D0_0 - do i = i1, i2 - do kl = k0(i,k)+1, k0(i,k+1)-1 - qsumk(i,k) = qsumk(i,k) + dp1(i,kl)*q4(1,i,kl) - enddo - enddo - - do i = i1, i2 - kk = k0(i,k) -! Consider contribution between pe1(i,kk) and pe2(i,k) - pl = (pe2(i,k)-pe1(i,kk)) / dp1(i,kk) -! Check to see if pe2(i,k+1) and pe2(i,k) are in same pe1 interval - if (k0(i,k+1) == k0(i,k)) then - pr = (pe2(i,k+1)-pe1(i,kk)) / dp1(i,kk) - tracer(iq)%content_r4(i,j,k) = q4(2,i,kk) & - + D0_5*(q4(4,i,kk)+q4(3,i,kk)-q4(2,i,kk)) & - *(pr+pl)-q4(4,i,kk)*r3*(pr*(pr+pl)+pl**2) - else -! Consider contribution between pe2(i,k) and pe1(i,kk+1) - qsum = (pe1(i,kk+1)-pe2(i,k))*(q4(2,i,kk)+D0_5*(q4(4,i,kk)+ & - q4(3,i,kk)-q4(2,i,kk))*(D1_0+pl)-q4(4,i,kk)* & - (r3*(D1_0+pl*(D1_0+pl)))) -! Next consider contribution between pe1(i,kk+1) and pe1(i,k0(i,k+1)) - qsum = qsum + qsumk(i,k) -! Now consider contribution between pe1(i,k0(i,k+1)) and pe2(i,k+1) - kl = k0(i,k+1) - delp = pe2(i,k+1)-pe1(i,kl) - esl = delp / dp1(i,kl) - qsum = qsum + delp*(q4(2,i,kl)+D0_5*esl* & - (q4(3,i,kl)-q4(2,i,kl)+q4(4,i,kl)*(D1_0-r23*esl))) - tracer(iq)%content_r4(i,j,k) = qsum / ( pe2(i,k+1) - pe2(i,k) ) - endif - enddo - enddo - - else ! Tracers are R8 - -! Interpolate - do k = 1, kn - -! Prepare contribution between pe1(i,ko(i,k)+1) and pe1(i,k0(i,k+1)) - qsumk(:,k) = D0_0 - do i = i1, i2 - do kl = k0(i,k)+1, k0(i,k+1)-1 - qsumk(i,k) = qsumk(i,k) + dp1(i,kl)*q4(1,i,kl) - enddo - enddo - - do i = i1, i2 - kk = k0(i,k) -! Consider contribution between pe1(i,kk) and pe2(i,k) - pl = (pe2(i,k)-pe1(i,kk)) / dp1(i,kk) -! Check to see if pe2(i,k+1) and pe2(i,k) are in same pe1 interval - if (k0(i,k+1) == k0(i,k)) then - pr = (pe2(i,k+1)-pe1(i,kk)) / dp1(i,kk) - tracer(iq)%content(i,j,k) = q4(2,i,kk) & - + D0_5*(q4(4,i,kk)+q4(3,i,kk)-q4(2,i,kk)) & - *(pr+pl)-q4(4,i,kk)*r3*(pr*(pr+pl)+pl**2) - else -! Consider contribution between pe2(i,k) and pe1(i,kk+1) - qsum = (pe1(i,kk+1)-pe2(i,k))*(q4(2,i,kk)+D0_5*(q4(4,i,kk)+ & - q4(3,i,kk)-q4(2,i,kk))*(D1_0+pl)-q4(4,i,kk)* & - (r3*(D1_0+pl*(D1_0+pl)))) -! Next consider contribution between pe1(i,kk+1) and pe1(i,k0(i,k+1)) - qsum = qsum + qsumk(i,k) -! Now consider contribution between pe1(i,k0(i,k+1)) and pe2(i,k+1) - kl = k0(i,k+1) - delp = pe2(i,k+1)-pe1(i,kl) - esl = delp / dp1(i,kl) - qsum = qsum + delp*(q4(2,i,kl)+D0_5*esl* & - (q4(3,i,kl)-q4(2,i,kl)+q4(4,i,kl)*(D1_0-r23*esl))) - tracer(iq)%content(i,j,k) = qsum / ( pe2(i,k+1) - pe2(i,k) ) - endif - enddo - enddo - - endif - enddo ! do iq=1,nq - - return -!EOC - end subroutine mapn_ppm_tracer -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: ppm2m --- Piecewise parabolic method for fields -! -! !INTERFACE: - subroutine ppm2m(a4, delp, km, i1, i2, iv, kord) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer, intent(in):: iv ! iv =-1: winds - ! iv = 0: positive definite scalars - ! iv = 1: others - integer, intent(in):: i1 ! Starting longitude - integer, intent(in):: i2 ! Finishing longitude - integer, intent(in):: km ! vertical dimension - integer, intent(in):: kord ! Order (or more accurately method no.): - ! - real (r8), intent(in):: delp(i1:i2,km) ! layer pressure thickness - -! !INPUT/OUTPUT PARAMETERS: - real (r8), intent(inout):: a4(4,i1:i2,km) ! Interpolated values - -! !DESCRIPTION: -! -! Perform the piecewise parabolic method -! -! !REVISION HISTORY: -! ??.??.?? Lin Creation -! 02.04.04 Sawyer Newest release from FVGCM -! 02.04.23 Sawyer Incorporated minor algorithmic change to -! maintain CAM zero diffs (see comments inline) -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: -! local arrays: - real(r8) dc(i1:i2,km) - real(r8) h2(i1:i2,km) - real(r8) delq(i1:i2,km) - real(r8) df2(i1:i2,km) - real(r8) d4(i1:i2,km) - -! local scalars: - real(r8) fac - real(r8) a1, a2, c1, c2, c3, d1, d2 - real(r8) qmax, qmin, cmax, cmin - real(r8) qm, dq, tmp - - integer i, k, km1, lmt - real(r8) qmp, pmp - real(r8) lac - integer it - - km1 = km - 1 - it = i2 - i1 + 1 - - do k=2,km - do i=i1,i2 - delq(i,k-1) = a4(1,i,k) - a4(1,i,k-1) - d4(i,k ) = delp(i,k-1) + delp(i,k) - enddo - enddo - - do k=2,km1 - do i=i1,i2 - c1 = (delp(i,k-1)+D0_5*delp(i,k))/d4(i,k+1) - c2 = (delp(i,k+1)+D0_5*delp(i,k))/d4(i,k) - tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / & - (d4(i,k)+delp(i,k+1)) - qmax = max(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - a4(1,i,k) - qmin = a4(1,i,k) - min(a4(1,i,k-1),a4(1,i,k),a4(1,i,k+1)) - dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp) - df2(i,k) = tmp - enddo - enddo - -!****6***0*********0*********0*********0*********0*********0**********72 -! 4th order interpolation of the provisional cell edge value -!****6***0*********0*********0*********0*********0*********0**********72 - - do k=3,km1 - do i=i1,i2 - c1 = delq(i,k-1)*delp(i,k-1) / d4(i,k) - a1 = d4(i,k-1) / (d4(i,k) + delp(i,k-1)) - a2 = d4(i,k+1) / (d4(i,k) + delp(i,k)) - a4(2,i,k) = a4(1,i,k-1) + c1 + D2_0/(d4(i,k-1)+d4(i,k+1)) * & - ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - & - delp(i,k-1)*a1*dc(i,k ) ) - enddo - enddo - - call steepz(i1, i2, km, a4, df2, dc, delq, delp, d4) - -! Area preserving cubic with 2nd deriv. = 0 at the boundaries -! Top - do i=i1,i2 - d1 = delp(i,1) - d2 = delp(i,2) - qm = (d2*a4(1,i,1)+d1*a4(1,i,2)) / (d1+d2) - dq = D2_0*(a4(1,i,2)-a4(1,i,1)) / (d1+d2) - c1 = D4_0*(a4(2,i,3)-qm-d2*dq) / ( d2*(D2_0*d2*d2+d1*(d2+D3_0*d1)) ) - c3 = dq - D0_5*c1*(d2*(D5_0*d1+d2)-D3_0*d1**2) - a4(2,i,2) = qm - D0_25*c1*d1*d2*(d2+D3_0*d1) - a4(2,i,1) = d1*(D2_0*c1*d1**2-c3) + a4(2,i,2) - dc(i,1) = a4(1,i,1) - a4(2,i,1) -! No over- and undershoot condition - cmax = max(a4(1,i,1), a4(1,i,2)) - cmin = min(a4(1,i,1), a4(1,i,2)) - a4(2,i,2) = max(cmin,a4(2,i,2)) - a4(2,i,2) = min(cmax,a4(2,i,2)) - enddo - - if( iv == 0 ) then - do i=i1,i2 -! -! WS: 02.04.23 Algorithmic difference with FVGCM. FVGCM does this: -! -!!! a4(2,i,1) = a4(1,i,1) -!!! a4(3,i,1) = a4(1,i,1) -! -! CAM does this: -! - a4(2,i,1) = max(D0_0,a4(2,i,1)) - a4(2,i,2) = max(D0_0,a4(2,i,2)) - enddo - elseif ( iv == -1 ) then -! Winds: - if( km > 32 ) then - do i=i1,i2 -! More dampping: top layer as the sponge - a4(2,i,1) = a4(1,i,1) - a4(3,i,1) = a4(1,i,1) - enddo - else - do i=i1,i2 - if( a4(1,i,1)*a4(2,i,1) <= D0_0 ) then - a4(2,i,1) = D0_0 - else - a4(2,i,1) = sign(min(abs(a4(1,i,1)), & - abs(a4(2,i,1))), & - a4(1,i,1) ) - endif - enddo - endif - endif - -! Bottom -! Area preserving cubic with 2nd deriv. = 0 at the surface - do i=i1,i2 - d1 = delp(i,km) - d2 = delp(i,km1) - qm = (d2*a4(1,i,km)+d1*a4(1,i,km1)) / (d1+d2) - dq = D2_0*(a4(1,i,km1)-a4(1,i,km)) / (d1+d2) - c1 = (a4(2,i,km1)-qm-d2*dq) / (d2*(D2_0*d2*d2+d1*(d2+D3_0*d1))) - c3 = dq - D2_0*c1*(d2*(D5_0*d1+d2)-D3_0*d1**2) - a4(2,i,km) = qm - c1*d1*d2*(d2+D3_0*d1) - a4(3,i,km) = d1*(D8_0*c1*d1**2-c3) + a4(2,i,km) - dc(i,km) = a4(3,i,km) - a4(1,i,km) -! No over- and under-shoot condition - cmax = max(a4(1,i,km), a4(1,i,km1)) - cmin = min(a4(1,i,km), a4(1,i,km1)) - a4(2,i,km) = max(cmin,a4(2,i,km)) - a4(2,i,km) = min(cmax,a4(2,i,km)) - enddo - -! Enforce constraint at the surface - - if ( iv == 0 ) then -! Positive definite scalars: - do i=i1,i2 - a4(3,i,km) = max(D0_0, a4(3,i,km)) - enddo - elseif ( iv == -1 ) then -! Winds: - do i=i1,i2 - if( a4(1,i,km)*a4(3,i,km) <= D0_0 ) then - a4(3,i,km) = D0_0 - else - a4(3,i,km) = sign( min(abs(a4(1,i,km)), & - abs(a4(3,i,km))), & - a4(1,i,km) ) - endif - enddo - endif - - do k=1,km1 - do i=i1,i2 - a4(3,i,k) = a4(2,i,k+1) - enddo - enddo - -! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) - -! Top 2 and bottom 2 layers always use monotonic mapping - do k=1,2 - do i=i1,i2 - a4(4,i,k) = D3_0*(D2_0*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(i1,k), a4(1,i1,k), it, 0) - enddo - - if(kord >= 7) then -!****6***0*********0*********0*********0*********0*********0**********72 -! Huynh's 2nd constraint -!****6***0*********0*********0*********0*********0*********0**********72 - do k=2, km1 - do i=i1,i2 -! Method#1 -! h2(i,k) = delq(i,k) - delq(i,k-1) -! Method#2 -! h2(i,k) = D2_0*(dc(i,k+1)/delp(i,k+1) - dc(i,k-1)/delp(i,k-1)) -! & / ( delp(i,k)+D0_5*(delp(i,k-1)+delp(i,k+1)) ) -! & * delp(i,k)**2 -! Method#3 - h2(i,k) = dc(i,k+1) - dc(i,k-1) - enddo - enddo - - if( kord == 7 ) then - fac = D1_5 ! original quasi-monotone - else - fac = D0_125 ! full monotone - endif - - do k=3, km-2 - do i=i1,i2 -! Right edges -! qmp = a4(1,i,k) + D2_0*delq(i,k-1) -! lac = a4(1,i,k) + fac*h2(i,k-1) + D0_5*delq(i,k-1) -! - pmp = D2_0*dc(i,k) - qmp = a4(1,i,k) + pmp - lac = a4(1,i,k) + fac*h2(i,k-1) + dc(i,k) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(3,i,k) = min(max(a4(3,i,k), qmin), qmax) -! Left edges -! qmp = a4(1,i,k) - D2_0*delq(i,k) -! lac = a4(1,i,k) + fac*h2(i,k+1) - D0_5*delq(i,k) -! - qmp = a4(1,i,k) - pmp - lac = a4(1,i,k) + fac*h2(i,k+1) - dc(i,k) - qmin = min(a4(1,i,k), qmp, lac) - qmax = max(a4(1,i,k), qmp, lac) - a4(2,i,k) = min(max(a4(2,i,k), qmin), qmax) -! Recompute A6 - a4(4,i,k) = D3_0*(D2_0*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo -! Additional constraint to prevent negatives when kord=7 - if (iv == 0 .and. kord == 7) then - call kmppm(dc(i1,k), a4(1,i1,k), it, 2) - endif - enddo - - else - - lmt = kord - 3 - lmt = max(0, lmt) - if (iv == 0) lmt = min(2, lmt) - - do k=3, km-2 - if( kord /= 4) then - do i=i1,i2 - a4(4,i,k) = D3_0*(D2_0*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - endif - call kmppm(dc(i1,k), a4(1,i1,k), it, lmt) - enddo - endif - - do k=km1,km - do i=i1,i2 - a4(4,i,k) = D3_0*(D2_0*a4(1,i,k) - (a4(2,i,k)+a4(3,i,k))) - enddo - call kmppm(dc(i1,k), a4(1,i1,k), it, 0) - enddo - - return -!EOC - end subroutine ppm2m -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: ppme --- PPM scheme at vertical edges -! -! !INTERFACE: - subroutine ppme(p,qe,delp,im,km) -! !USES: - use shr_kind_mod, only : r8 => shr_kind_r8, i4 => shr_kind_i4 - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: im, km - real(r8), intent(in) :: p(im,km), delp(im,km) - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(out) :: qe(im,km+1) - -! !DESCRIPTION: -! -! -! !REVISION HISTORY: -! 05.06.13 Sawyer Inserted file ppme.F90 here, added ProTeX -! -!EOP -!----------------------------------------------------------------------- -!BOC - - integer(i4) km1 - integer(i4) i, k -! local arrays. - real(r8) dc(im,km),delq(im,km), a6(im,km) - real(r8) c1, c2, c3, tmp, qmax, qmin - real(r8) a1, a2, s1, s2, s3, s4, ss3, s32, s34, s42 - real(r8) a3, b2, sc, dm, d1, d2, f1, f2, f3, f4 - real(r8) qm, dq - - km1 = km - 1 - - do 500 k=2,km - do 500 i=1,im -500 a6(i,k) = delp(i,k-1) + delp(i,k) - - do 1000 k=1,km1 - do 1000 i=1,im - delq(i,k) = p(i,k+1) - p(i,k) -1000 continue - - do 1220 k=2,km1 - do 1220 i=1,im - c1 = (delp(i,k-1)+D0_5*delp(i,k))/a6(i,k+1) - c2 = (delp(i,k+1)+D0_5*delp(i,k))/a6(i,k) - tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / & - (a6(i,k)+delp(i,k+1)) - qmax = max(p(i,k-1),p(i,k),p(i,k+1)) - p(i,k) - qmin = p(i,k) - min(p(i,k-1),p(i,k),p(i,k+1)) - dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp) -1220 continue - -!****6***0*********0*********0*********0*********0*********0**********72 -! 4th order interpolation of the provisional cell edge value -!****6***0*********0*********0*********0*********0*********0**********72 - - do 12 k=3,km1 - do 12 i=1,im - c1 = delq(i,k-1)*delp(i,k-1) / a6(i,k) - a1 = a6(i,k-1) / (a6(i,k) + delp(i,k-1)) - a2 = a6(i,k+1) / (a6(i,k) + delp(i,k)) - qe(i,k) = p(i,k-1) + c1 + D2_0/(a6(i,k-1)+a6(i,k+1)) * & - ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - & - delp(i,k-1)*a1*dc(i,k ) ) -12 continue - -! three-cell parabolic subgrid distribution at model top - - do 10 i=1,im -! three-cell PP-distribution -! Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp -! a3 = a / 3 -! b2 = b / 2 - s1 = delp(i,1) - s2 = delp(i,2) + s1 -! - s3 = delp(i,2) + delp(i,3) - s4 = s3 + delp(i,4) - ss3 = s3 + s1 - s32 = s3*s3 - s42 = s4*s4 - s34 = s3*s4 -! model top - a3 = (delq(i,2) - delq(i,1)*s3/s2) / (s3*ss3) -! - if(abs(a3) .gt. D1EM14) then - b2 = delq(i,1)/s2 - a3*(s1+s2) - sc = -b2/(D3_0*a3) - if(sc .lt. D0_0 .or. sc .gt. s1) then - qe(i,1) = p(i,1) - s1*(a3*s1 + b2) - else - qe(i,1) = p(i,1) - delq(i,1)*s1/s2 - endif - else -! Linear - qe(i,1) = p(i,1) - delq(i,1)*s1/s2 - endif - dc(i,1) = p(i,1) - qe(i,1) -! compute coef. for the off-centered area preserving cubic poly. - dm = delp(i,1) / (s34*ss3*(delp(i,2)+s3)*(s4+delp(i,1))) - f1 = delp(i,2)*s34 / ( s2*ss3*(s4+delp(i,1)) ) - f2 = (delp(i,2)+s3) * (ss3*(delp(i,2)*s3+s34+delp(i,2)*s4) & - + s42*(delp(i,2)+s3+s32/s2)) - f3 = -delp(i,2)*( ss3*(s32*(s3+s4)/(s4-delp(i,2)) & - + (delp(i,2)*s3+s34+delp(i,2)*s4)) & - + s42*(delp(i,2)+s3) ) - f4 = ss3*delp(i,2)*s32*(delp(i,2)+s3) / (s4-delp(i,2)) - qe(i,2) = f1*p(i,1)+(f2*p(i,2)+f3*p(i,3)+f4*p(i,4))*dm -10 continue - -! Bottom -! Area preserving cubic with 2nd deriv. = 0 at the surface - do 15 i=1,im - d1 = delp(i,km) - d2 = delp(i,km1) - qm = (d2*p(i,km)+d1*p(i,km1)) / (d1+d2) - dq = D2_0*(p(i,km1)-p(i,km)) / (d1+d2) - c1 = (qe(i,km1)-qm-d2*dq) / (d2*(D2_0*d2*d2+d1*(d2+D3_0*d1))) - c3 = dq - D2_0*c1*(d2*(D5_0*d1+d2)-D3_0*d1**2) - qe(i,km ) = qm - c1*d1*d2*(d2+D3_0*d1) - qe(i,km+1) = d1*(D8_0*c1*d1**2-c3) + qe(i,km) -15 continue - return -!EOC - end subroutine ppme -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: kmppm --- Perform piecewise parabolic method in vertical -! -! !INTERFACE: - subroutine kmppm(dm, a4, itot, lmt) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - real(r8), intent(in):: dm(*) ! ?????? - integer, intent(in) :: itot ! Total Longitudes - integer, intent(in) :: lmt ! 0: Standard PPM constraint - ! 1: Improved full monotonicity constraint (Lin) - ! 2: Positive definite constraint - ! 3: do nothing (return immediately) - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: a4(4,*) ! ??????? - ! AA <-- a4(1,i) - ! AL <-- a4(2,i) - ! AR <-- a4(3,i) - ! A6 <-- a4(4,i) - -! !DESCRIPTION: -! -! Writes a standard set of data to the history buffer. -! -! !REVISION HISTORY: -! 00.04.24 Lin Last modification -! 01.03.26 Sawyer Added ProTeX documentation -! 02.04.04 Sawyer Incorporated newest FVGCM version -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - - real(r8) r12 - parameter (r12 = D1_0/D12_0) - - real(r8) qmp - integer i - real(r8) da1, da2, a6da - real(r8) fmin - -! Developer: S.-J. Lin, NASA-GSFC -! Last modified: Apr 24, 2000 - - if ( lmt == 3 ) return - - if(lmt == 0) then -! Standard PPM constraint - do i=1,itot - if(dm(i) == D0_0) then - a4(2,i) = a4(1,i) - a4(3,i) = a4(1,i) - a4(4,i) = D0_0 - else - da1 = a4(3,i) - a4(2,i) - da2 = da1**2 - a6da = a4(4,i)*da1 - if(a6da < -da2) then - a4(4,i) = D3_0*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - elseif(a6da > da2) then - a4(4,i) = D3_0*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif - enddo - - elseif (lmt == 1) then - -! Improved full monotonicity constraint (Lin) -! Note: no need to provide first guess of A6 <-- a4(4,i) - do i=1, itot - qmp = D2_0*dm(i) - a4(2,i) = a4(1,i)-sign(min(abs(qmp),abs(a4(2,i)-a4(1,i))), qmp) - a4(3,i) = a4(1,i)+sign(min(abs(qmp),abs(a4(3,i)-a4(1,i))), qmp) - a4(4,i) = D3_0*( D2_0*a4(1,i) - (a4(2,i)+a4(3,i)) ) - enddo - - elseif (lmt == 2) then - -! Positive definite constraint - do i=1,itot - if( abs(a4(3,i)-a4(2,i)) < -a4(4,i) ) then - fmin = a4(1,i)+D0_25*(a4(3,i)-a4(2,i))**2/a4(4,i)+a4(4,i)*r12 - if( fmin < D0_0 ) then - if(a4(1,i) a4(2,i)) then - a4(4,i) = D3_0*(a4(2,i)-a4(1,i)) - a4(3,i) = a4(2,i) - a4(4,i) - else - a4(4,i) = D3_0*(a4(3,i)-a4(1,i)) - a4(2,i) = a4(3,i) - a4(4,i) - endif - endif - endif - enddo - - endif - - return -!EOC - end subroutine kmppm -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: steepz --- Calculate attributes for PPM -! -! !INTERFACE: - subroutine steepz(i1, i2, km, a4, df2, dm, dq, dp, d4) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: km ! Total levels - integer, intent(in) :: i1 ! Starting longitude - integer, intent(in) :: i2 ! Finishing longitude - real(r8), intent(in) :: dp(i1:i2,km) ! grid size - real(r8), intent(in) :: dq(i1:i2,km) ! backward diff of q - real(r8), intent(in) :: d4(i1:i2,km) ! backward sum: dp(k)+ dp(k-1) - real(r8), intent(in) :: df2(i1:i2,km) ! first guess mismatch - real(r8), intent(in) :: dm(i1:i2,km) ! monotonic mismatch - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout) :: a4(4,i1:i2,km) ! first guess/steepened - -! -! !DESCRIPTION: -! This is complicated stuff related to the Piecewise Parabolic Method -! and I need to read the Collela/Woodward paper before documenting -! thoroughly. -! -! !REVISION HISTORY: -! ??.??.?? Lin? Creation -! 01.03.26 Sawyer Added ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i, k - real(r8) alfa(i1:i2,km) - real(r8) f(i1:i2,km) - real(r8) rat(i1:i2,km) - real(r8) dg2 - -! Compute ratio of dq/dp - do k=2,km - do i=i1,i2 - rat(i,k) = dq(i,k-1) / d4(i,k) - enddo - enddo - -! Compute F - do k=2,km-1 - do i=i1,i2 - f(i,k) = (rat(i,k+1) - rat(i,k)) & - / ( dp(i,k-1)+dp(i,k)+dp(i,k+1) ) - enddo - enddo - - do k=3,km-2 - do i=i1,i2 - if(f(i,k+1)*f(i,k-1) shr_kind_r8 - use dynamics_vars, only : T_FVDYCORE_GRID -#if defined( SPMD ) - use parutilitiesmodule, only: bcstop, sumop, parcollective - use mod_comm, only : commglobal, mp_exit, gid, mp_send3d, mp_recv3d -#endif - implicit none - -#if defined(BILL_DEBUG) -#include "mpif.h" -#endif - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid ! grid (for XY decomp) - - real(r8), intent(in) :: ae ! Radius of the Earth (m) - real(r8), intent(in) :: grav ! Gravity - integer, intent(in) :: dt ! large time step in seconds - real(r8), intent(inout) :: mfx(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - real(r8), intent(inout) :: mfy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - - real(r8), intent(in) :: delpxy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - real(r8), intent(in) :: delp0xy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - -! !OUTPUT PARAMETERS: - real(r8), intent(inout) :: mfz(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) - -! !DESCRIPTION: -! Compute cell centered vertical mass flux -! Vertical integration of the continuity equation using the -! divergence of the horizontal mass fluxes -! -! !REVISION HISTORY: -! WMP 05.12.01 Created -! WS 09.04.01 : Upgraded to PILGRIM from cam3_6_33 -! -! !BUGS: -! Not yet tested... -! -!EOP -!--------------------------------------------------------------------- -!BOC - - real(r8) mfy_north(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8), allocatable :: mfx_east(:,:) ! East halo - real(r8), allocatable :: mfy_sp(:,:), mfy_np(:,:) - real(r8) delp1xy(grid%im,grid%jm,grid%km) - real(r8) conv(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) pit(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) ! pressure tendency - real(r8) area, sum1, sum1a, sum1k, sum2, sum2a, sum2k - integer :: im, jm, km - integer :: ifirstxy, ilastxy, jfirstxy, jlastxy - integer :: ierr, iam, myidxy_y, nprxy_x, nprxy_y, dest, src ! SPMD related - integer :: i,j,k - - im = grid%im - jm = grid%jm - km = grid%km - - ifirstxy = grid%ifirstxy - ilastxy = grid%ilastxy - jfirstxy = grid%jfirstxy - jlastxy = grid%jlastxy - - iam = grid%iam - myidxy_y = grid%myidxy_y - nprxy_x = grid%nprxy_x - nprxy_y = grid%nprxy_y - - ! Initialize mfy_north - mfy_north = 0.0_r8 - - allocate(mfx_east(jfirstxy:jlastxy,km)) ! East halo - allocate(mfy_sp(im,km), mfy_np(im,km) ) - -#if defined( SPMD ) - call mp_send3d( commglobal, iam-nprxy_x, iam+nprxy_x, im, jm, km, & - ifirstxy, ilastxy, jfirstxy, jlastxy, 1, km, & - ifirstxy, ilastxy, jfirstxy, jfirstxy, 1, km, mfy ) - call mp_recv3d( commglobal, iam+nprxy_x, im, jm, km, & - ifirstxy, ilastxy, jlastxy+1, jlastxy+1, 1, km, & - ifirstxy, ilastxy, jlastxy+1, jlastxy+1, 1, km, mfy_north ) - if (nprxy_x > 1) then -! Nontrivial x decomposition - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirstxy, ilastxy, jfirstxy, jlastxy, 1,km, & - ifirstxy, ifirstxy, jfirstxy, jlastxy, 1, km, mfx ) - endif -#endif -! -! Prepare sum of mfy for divergence at poles -! - mfy_sp = 0.0_r8 - mfy_np = 0.0_r8 -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,k) - do k=1,km - if ( jfirstxy == 1 ) then ! SP - do i=ifirstxy,ilastxy - mfy_sp(i,k) = mfy(i,2,k) - enddo - endif - if ( jlastxy == jm ) then ! NP - do i=ifirstxy,ilastxy - mfy_np(i,k) = mfy(i,jm,k) - enddo - endif -! Periodic boundary (for the case of no decomposition in X) - do j=jfirstxy,jlastxy - mfx_east(j,k) = mfx(ifirstxy,j,k) - enddo - enddo - -#if defined( SPMD ) - if ( nprxy_x > 1 ) then -! Non-trivial X decomposition - call mp_recv3d( commglobal, src, im, jm, km, & - ilastxy+1, ilastxy+1, jfirstxy, jlastxy, 1, km, & - ilastxy+1, ilastxy+1, jfirstxy, jlastxy, 1, km, mfx_east ) - endif -! -! Collect on all PEs the mfy at both poles -! - if (nprxy_x > 1) then - call parcollective(grid%commxy_x, sumop, im, km, mfy_sp) - call parcollective(grid%commxy_x, sumop, im, km, mfy_np) - endif -#endif - -! Compute Convergence of the horizontal Mass flux -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,j,k,sum1,sum2) - do k=1,km - do j=jfirstxy,jlastxy-1 - do i=ifirstxy,ilastxy-1 - conv(i,j,k) = mfx(i,j,k) - mfx(i+1,j,k) + & - mfy(i,j,k) - mfy(i,j+1,k) - enddo - conv(ilastxy,j,k) = mfx(ilastxy,j,k) - mfx_east(j,k) + & - mfy(ilastxy,j,k) - mfy(ilastxy,j+1,k) - enddo - j = jlastxy - do i=ifirstxy,ilastxy-1 - conv(i,j,k) = mfx(i,j,k) - mfx(i+1,j,k) + & - mfy(i,j,k) - mfy_north(i,k) - enddo - conv(ilastxy,j,k) = mfx(ilastxy,j,k) - mfx_east(j,k) + & - mfy(ilastxy,j,k) - mfy_north(ilastxy,k) - -! Poles - if ( jfirstxy == 1 ) then - sum1 = -SUM(mfy_sp(1:im,k)) - do i=ifirstxy,ilastxy - conv(i,1,k) = sum1 - enddo - endif - - if ( jlastxy == jm ) then - sum2 = SUM(mfy_np(1:im,k)) - do i=ifirstxy,ilastxy - conv(i,jm,k) = sum2 - enddo - endif - enddo - -! Surface pressure tendency - pit(:,:) = 0.0 - do k=1,km - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - pit(i,j) = pit(i,j) + conv(i,j,k) - enddo - enddo - enddo - -! Sum over levels - do k=2,km - do j=jfirstxy,jlastxy - do i=ifirstxy,ilastxy - conv(i,j,k) = conv(i,j,k) + conv(i,j,k-1) - enddo - enddo - enddo - - mfz(:,:,:) = 0.0 - do k=2,km - do j=MAX(2,jfirstxy),MIN(jlastxy,jm-1) - area = grid%dl*grid%cosp(j)*ae * grid%dp*ae - do i=ifirstxy,ilastxy - mfz(i,j,k) = ( conv(i,j,k-1) - grid%bk(k)*pit(i,j) )/(grav*area) ! Kg/m^2/s - enddo - enddo -! Poles - if ( jfirstxy == 1 ) then - j=1 - area = grid%acap*(grid%dl*ae * grid%dp*ae) - do i=ifirstxy,ilastxy - mfz(i,j,k) = ( conv(i,j,k-1) - grid%bk(k)*pit(i,j) ) / (grav*area) ! Kg/m^2/s - enddo - endif - if ( jlastxy == jm ) then - j=jm - area = grid%acap*(grid%dl*ae * grid%dp*ae) - do i=ifirstxy,ilastxy - mfz(i,j,k) = ( conv(i,j,k-1) - grid%bk(k)*pit(i,j) ) / (grav*area) ! Kg/m^2/s - enddo - endif - enddo - - -#if defined(BILL_DEBUG) - if (1==1) then -!BMP - sum1k=0 - sum2k=0 - ! test mass fluxes and d(delp)/dt within each layer - do k=1,km - do j=MAX(2,jfirstxy),MIN(jlastxy-1,jm-1) - area = grid%dl*grid%cosp(j)*ae * grid%dp*ae - do i=ifirstxy,ilastxy-1 - - delp1xy(i,j,k) = dt*( -(mfx(i+1,j,k)-mfx(i,j,k) + mfy(i,j+1,k)-mfy(i,j,k))/area - grav*(mfz(i,j,k+1)-mfz(i,j,k)) ) - - if ( (i==100) .and. (j==99) .and. (k==60) ) then - print*, delpxy(i,j,k)-delp0xy(i,j,k), delp1xy(i,j,k) - endif - - enddo - i=ilastxy - delp1xy(i,j,k) = dt*( -(mfx_east(j,k)-mfx(i,j,k) + mfy(i,j+1,k)-mfy(i,j,k))/area - grav*(mfz(i,j,k+1)-mfz(i,j,k)) ) - enddo - if (jlastxy /= jm) then - j=jlastxy - area = grid%dl*grid%cosp(j)*ae * grid%dp*ae - do i=ifirstxy,ilastxy-1 - delp1xy(i,j,k) = dt*( -(mfx(i+1,j,k)-mfx(i,j,k) + mfy_north(i,k)-mfy(i,j,k))/area - grav*(mfz(i,j,k+1)-mfz(i,j,k)) ) - enddo - i=ilastxy - delp1xy(i,j,k) = dt*( -(mfx_east(j,k)-mfx(i,j,k) + mfy_north(i,k)-mfy(i,j,k))/area - grav*(mfz(i,j,k+1)-mfz(i,j,k)) ) - endif -! Poles - if ( jfirstxy == 1 ) then - sum1 = -(SUM(mfy_sp(1:im,k)))*grid%rcap / (grid%dl*ae * grid%dp*ae) - j=1 - do i=ifirstxy,ilastxy - delp1xy(i,j,k) = dt*( sum1 - grav*(mfz(i,j,k+1)-mfz(i,j,k)) ) - enddo - endif - if ( jlastxy == jm ) then - sum2 = (SUM(mfy_np(1:im,k)))*grid%rcap / (grid%dl*ae * grid%dp*ae) - j=jm - do i=ifirstxy,ilastxy - delp1xy(i,j,k) = dt*( sum2 - grav*(mfz(i,j,k+1)-mfz(i,j,k)) ) - enddo - endif - - sum1 = 0 - ! if (jfirstxy == 1) then - ! do j=1,1 - do j=MAX(1,jfirstxy),MIN(jlastxy,jm) - do i=ifirstxy,ilastxy - sum1 = sum1 + delp1xy(i,j,k) - enddo - enddo - ! endif - call mpi_reduce(sum1, sum1a, 1, MPI_DOUBLE_PRECISION, sumop, 0, grid%comm_y, ierr) - sum1k=sum1k+sum1a - - sum2 = 0 - ! if (jfirstxy == 1) then - ! do j=1,1 - do j=MAX(1,jfirstxy),MIN(jlastxy,jm) - do i=ifirstxy,ilastxy - sum2 = sum2 + delpxy(i,j,k)-delp0xy(i,j,k) - enddo - enddo - ! endif - call mpi_reduce(sum2, sum2a, 1, MPI_DOUBLE_PRECISION, sumop, 0, grid%comm_y, ierr) - sum2k=sum2k+sum2a - - if (gid==0) print*, k, sum1a, sum2a - - enddo - - if (gid==0) print*, sum1k, sum2k - - call mp_exit( commglobal ) - stop - - endif -#endif - - deallocate(mfx_east) - deallocate(mfy_sp,mfy_np) - - return - end - diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_vecsum.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_vecsum.F90 deleted file mode 100644 index e0d6783d5..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_vecsum.F90 +++ /dev/null @@ -1,91 +0,0 @@ -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: par_vecsum --- Calculate vector sum bit-wise consistently -! -! !INTERFACE: -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine par_vecsum(jm, jfirst, jlast, InVector, te0, & - incomm, npryuse) -!****6***0*********0*********0*********0*********0*********0**********72 -! -! !USES: -#if defined ( SPMD ) - use parutilitiesmodule, only : parexchangevector -#endif - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - -! !INPUT PARAMETERS: - integer jm ! global latitudes - integer jfirst ! first latitude on this PE - integer jlast ! last latitude on this PE - real (r8) InVector(jm) ! input vector to be summed - integer incomm ! communicator - integer npryuse ! number of subdomains - -! !OUTPUT PARAMETERS: - real (r8) te0 ! sum of all vector entries - -! !DESCRIPTION: -! This subroutine calculates the sum of InVector in a reproducible -! (sequentialized) fashion which should give bit-wise identical -! results irrespective of the number of MPI processes. -! -! !CALLED FROM: -! te_map and benergy -! -! !REVISION HISTORY: -! -! BWS 00.01.15 : Created -! WS 00.06.02 : Replaced MPI calls with ParExchangeVector; docu. -! WS 00.08.29 : SPMD instead of MPI_ON -! AM 01.06.15 : general communicator -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! !Local - real(r8), parameter :: D0_0 = 0.0_r8 - real (r8) tte_all(jm) - integer j - -#if defined ( SPMD ) - real (r8) tte_send(npryuse*(jlast-jfirst+1)) - integer sendcount(npryuse) - integer recvcount(npryuse) - integer ipe, icount -#endif - - te0 = D0_0 -#if defined ( SPMD ) - icount=0 - do ipe=1,npryuse - sendcount(ipe) = jlast-jfirst+1 - do j=jfirst, jlast - icount=icount+1 - tte_send(icount)=InVector(j) - enddo - enddo - call parexchangevector( incomm, sendcount, tte_send, & - recvcount, tte_all ) -#else - do j=1, jm - tte_all(j)=InVector(j) - enddo -#endif - - te0 = D0_0 - te0 = te0 + tte_all(1) !in oder to compare to SMP-only - te0 = te0 + tte_all(jm) !in oder to compare to SMP-only - - do j=2,jm-1 - te0 = te0 + tte_all(j) - enddo - - return -!EOC - end -!----------------------------------------------------------------------- - diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_xsum.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_xsum.F90 deleted file mode 100644 index f5625927f..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/par_xsum.F90 +++ /dev/null @@ -1,167 +0,0 @@ -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: par_xsum --- Calculate x-sum bit-wise consistently -! -! !INTERFACE: -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine par_xsum(grid, a, ltot, xsum) -!****6***0*********0*********0*********0*********0*********0**********72 -! -! !USES: -#if defined ( SPMD ) - use parutilitiesmodule, only : parcollective, SUMOP -#endif - use dynamics_vars, only : T_FVDYCORE_GRID - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - integer, intent(in) :: ltot ! number of quantities to be summed - real (r8) a(grid%ifirstxy:grid%ilastxy,ltot) ! input vector to be summed - -! !OUTPUT PARAMETERS: - real (r8) xsum(ltot) ! sum of all vector entries - -! !DESCRIPTION: -! This subroutine calculates the sum of "a" in a reproducible -! (sequentialized) fashion which should give bit-wise identical -! results irrespective of the number of MPI processes. -! -! !REVISION HISTORY: -! -! AAM 00.11.01 : Created -! WS 03.10.22 : pmgrid removed (now spmd_dyn) -! WS 04.10.04 : added grid as an argument; removed spmd_dyn -! WS 05.05.25 : removed ifirst, ilast, im as arguments (in grid) -! WS 06.12.24 : rewritten to use collective communication call -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! !Local - real(r8), parameter :: D0_0 = 0.0_r8 - real (r8) quan_all(grid%im,ltot) - integer i,l,ifirst,ilast,im - - quan_all = D0_0 - ifirst = grid%ifirstxy - ilast = grid%ilastxy - im = grid%im - do i=ifirst,ilast - do l=1,ltot - quan_all(i,l)=a(i,l) - enddo - enddo - -#if defined ( SPMD ) - if ( grid%nprxy_x > 1 ) then - call parcollective( grid%commxy_x, SUMOP, im, ltot, quan_all ) - endif -#endif - - do l=1,ltot - xsum(l) = D0_0 - do i=1,im - xsum(l) = xsum(l) + quan_all(i,l) - enddo - enddo - - return -!EOC - end subroutine par_xsum -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: par_xsum_r4 --- Calculate x-sum bit-wise consistently (real4) -! -! !INTERFACE: -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine par_xsum_r4(grid, a, ltot, sum) -!****6***0*********0*********0*********0*********0*********0**********72 -! -! !USES: -#if defined ( SPMD ) - use parutilitiesmodule, only : parexchangevector -#endif - use dynamics_vars, only : T_FVDYCORE_GRID - use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 - - implicit none - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - integer, intent(in) :: ltot ! number of quantities to be summed - real (r4) a(grid%ifirstxy:grid%ilastxy,ltot) ! input vector to be summed - -! !OUTPUT PARAMETERS: - real (r8) sum(ltot) ! sum of all vector entries - -! !DESCRIPTION: -! This subroutine calculates the sum of "a" in a reproducible -! (sequentialized) fashion which should give bit-wise identical -! results irrespective of the number of MPI processes. -! -! !REVISION HISTORY: -! -! WS 05.04.08 : Created from par_xsum -! WS 05.05.25 : removed ifirst, ilast, im as arguments (in grid) -! WS 06.06.28 : Fixed bug in sequential version -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! !Local - real(r4), parameter :: E0_0 = 0.0_r4 - integer :: nprxy_x, commxy_x - real (r4) quan_all(grid%im*ltot) - integer i,l,icount,ipe, ifirst,ilast,im - -#if defined ( SPMD ) - real (r4) quan_send(grid%nprxy_x*ltot*(grid%ilastxy-grid%ifirstxy+1)) - integer sendcount(grid%nprxy_x) - integer recvcount(grid%nprxy_x) -#endif - - ifirst = grid%ifirstxy - ilast = grid%ilastxy - im = grid%im -#if defined ( SPMD ) - nprxy_x = grid%nprxy_x - commxy_x = grid%commxy_x - - icount=0 - do ipe=1,nprxy_x - sendcount(ipe) = ltot*(ilast-ifirst+1) - do i=ifirst,ilast - do l=1,ltot - icount=icount+1 - quan_send(icount)=a(i,l) - enddo - enddo - enddo - call parexchangevector( commxy_x, sendcount, quan_send, & - recvcount, quan_all ) -#else - do l=1,ltot - do i=1,im - quan_all((i-1)*ltot+l)=a(i,l) - enddo - enddo -#endif - - do l=1,ltot - sum(l) = E0_0 - do i=1,im - sum(l) = sum(l) + quan_all((i-1)*ltot+l) - enddo - enddo - - return -!EOC - end subroutine par_xsum_r4 -!----------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pft_module.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pft_module.F90 deleted file mode 100644 index b7bee1801..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pft_module.F90 +++ /dev/null @@ -1,467 +0,0 @@ -module pft_module -!BOP -! -! !MODULE: pft_module --- polar filters -! -! !USES: - - use shr_kind_mod, only: r8 => shr_kind_r8 - -#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 - -! -! !PUBLIC MEMBER FUNCTIONS: - public pft2d, pft_cf, fftfax, pftinit, fftrans -! -! !DESCRIPTION: -! -! This module provides fast-Fourier transforms -! -! \begin{tabular}{|l|l|} \hline \hline -! pftinit & \\ \hline -! pft2d & \\ \hline -! pft\_cf & \\ \hline -! fftfax & \\ \hline -! fftrans & \\ \hline -! \hline -! \end{tabular} -! -! !REVISION HISTORY: -! 01.01.30 Lin Integrated into this module -! 01.03.26 Sawyer Added ProTeX documentation -! 05.05.25 Sawyer Merged CAM and GEOS5 versions (CAM vectorization) -! 05.07.26 Worley Revised module using for Cray X1 version -! 06.09.08 Sawyer Magic numbers isolated in F90 parameters -! -!EOP -!----------------------------------------------------------------------- - private - real(r8), parameter :: D0_0 = 0.0_r8 - real(r8), parameter :: D1EM20 = 1.0e-20_r8 - real(r8), parameter :: D0_5 = 0.5_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D1_01 = 1.01_r8 - real(r8), parameter :: D2_0 = 2.0_r8 - real(r8), parameter :: D4_0 = 4.0_r8 - real(r8), parameter :: D8_0 = 8.0_r8 - real(r8), parameter :: D180_0 =180.0_r8 - - integer, save :: ifax(13) !ECMWF fft - real(r8), allocatable, save :: trigs(:) ! reentrant code?? - -CONTAINS - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: pftinit --- Two-dimensional FFT initialization -! -! !INTERFACE: - subroutine pftinit(im) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im ! Total X dimension - -! !DESCRIPTION: -! -! Perform a two-dimensional FFT initialization -! -! !REVISION HISTORY: -! 05.05.15 Mirin Put into this module -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer icffta - real(r8) rcffta - -#if defined( LIBSCI_FFT ) - allocate( trigs(2*im+100) ) - icffta = 0 - rcffta = D0_0 - call dzfftm(0, im, icffta, rcffta, rcffta, icffta, & - rcffta, icffta, trigs, rcffta, icffta) -#else - allocate( trigs(3*im/2+1) ) - call fftfax(im, ifax, trigs) -#endif - - return -!EOC - end subroutine pftinit -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: pft2d --- Two-dimensional fast Fourier transform -! -! !INTERFACE: - subroutine pft2d(p, s, damp, im, jp, q1, q2) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im ! Total X dimension - integer jp ! Total Y dimension - real(r8) s(jp) ! 3-point algebraic filter - real(r8) damp(im,jp) ! FFT damping coefficients - -! !INPUT/OUTPUT PARAMETERS: - real(r8) q1( im+2, *) ! Work array - real(r8) q2(*) ! Work array - real(r8) p(im,jp) ! Array to be polar filtered - -! !DESCRIPTION: -! -! Perform a two-dimensional fast Fourier transformation. -! -! !REVISION HISTORY: -! 01.01.30 Lin Put into this module -! 01.03.26 Sawyer Added ProTeX documentation -! 02.04.05 Sawyer Integrated newest FVGCM version -! 05.05.17 Sawyer Merged CAM and GEOS-5 -! 05.07.26 Worley Removed ifax, trigs from arg list -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real(r8) rsc, bt - integer i, j, n, nj - -!Local Auto arrays: - real(r8) ptmp(0:im+1) -!!! real(r8) q1( im+2, jp) -!!! real(r8) q2( (im+1)*jp ) - integer jf(jp) - - nj = 0 - - do 200 j=1,jp - -#if !defined ( ALGEBRAIC_FILTER ) - if(s(j) > D1_01) then -#else - if(s(j) > D1_01 .and. s(j) <= D4_0) then - - rsc = D1_0/s(j) - bt = D0_5*(s(j)-D1_0) - - do i=1,im - ptmp(i) = p(i,j) - enddo - ptmp( 0) = p(im,j) - ptmp(im+1) = p(1 ,j) - - do i=1,im - p(i,j) = rsc * ( ptmp(i) + bt*(ptmp(i-1)+ptmp(i+1)) ) - enddo - - elseif(s(j) > D4_0) then -#endif - -! Packing for FFT - nj = nj + 1 - jf(nj) = j - - do i=1,im - q1(i,nj) = p(i,j) - enddo - q1(im+1,nj) = D0_0 - q1(im+2,nj) = D0_0 - - endif -200 continue - - if( nj == 0) return - - call fftrans(damp, im, jp, nj, jf, q1, q2) - - do n=1,nj - do i=1,im - p(i,jf(n)) = q1(i,n) - enddo - enddo - - return -!EOC - end subroutine pft2d -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: fftrans --- Two-dimensional fast Fourier transform -! -! !INTERFACE: - subroutine fftrans(damp, im, jp, nj, jf, q1, q2) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im ! Total X dimension - integer jp ! Total Y dimension - integer nj ! Number of transforms - integer jf(jp) ! J index versus transform number - real(r8) damp(im,jp) ! FFT damping coefficients - -! !INPUT/OUTPUT PARAMETERS: - real(r8) q1( im+2, *) ! Work array - real(r8) q2(*) ! Work array - -! !DESCRIPTION: -! -! Perform a two-dimensional fast Fourier transformation. -! -! !REVISION HISTORY: -! 05.05.15 Mirin Initial combined version -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i, n - real (r8) ooim - -!Local Auto arrays: - -#if defined( LIBSCI_FFT ) - real (r8) qwk(2*im+4, jp) - complex(r8) cqf(im/2+1, jp) - integer imo2p -#elif defined( SGI_FFT ) - integer*4 im_4, nj_4, imp2_4 -#endif - -#if defined( LIBSCI_FFT ) - imo2p = im/2 + 1 - ooim = D1_0/real(im,r8) - - call dzfftm(-1, im, nj, D1_0, q1, im+2, cqf, imo2p, & - trigs, qwk, 0) - - do n=1,nj - do i=3,imo2p - cqf(i,n) = cqf(i,n) * damp(2*i-2,jf(n)) - enddo - enddo - - call zdfftm( 1, im, nj, ooim, cqf, imo2p, q1, im+2, & - trigs, qwk, 0) -#elif defined( SGI_FFT ) - im_4 = im - nj_4 = nj - imp2_4 = im+2 - call dzfftm1du (-1, im_4, nj_4, q1, 1, imp2_4, trigs) - do n=1,nj - do i=5,im+2 - q1(i,n) = q1(i,n) * damp(i-2,jf(n)) - enddo - enddo - call dzfftm1du (1, im_4, nj_4, q1, 1, imp2_4, trigs) - ooim = D1_0/real(im,r8) - do n=1,nj - do i=1,im+2 - q1(i,n) = ooim*q1(i,n) - enddo - enddo -#else - call fft991 (q1, q2, trigs, ifax, 1, im+2, im, nj, -1) - do n=1,nj - do i=5,im+2 - q1(i,n) = q1(i,n) * damp(i-2,jf(n)) - enddo - enddo - call fft991 (q1, q2, trigs, ifax, 1, im+2, im, nj, 1) -#endif - - return -!EOC - end subroutine fftrans -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: pft_cf --- Calculate algebraic and FFT polar filters -! -! !INTERFACE: - subroutine pft_cf(im, jm, js2g0, jn2g0, jn1g1, sc, se, dc, de, & - cosp, cose, ycrit) - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im ! Total X dimension - integer jm ! Total Y dimension - integer js2g0 ! j south limit ghosted 0 (SP: from 2) - integer jn2g0 ! j north limit ghosted 0 (NP: from jm-1) - integer jn1g1 ! j north limit ghosted 1 (starts jm) - real (r8) cosp(jm) ! cosine array - real (r8) cose(jm) ! cosine array - real (r8) ycrit ! critical value - -! !OUTPUT PARAMETERS: - real (r8) sc(js2g0:jn2g0) ! Algebric filter at center - real (r8) se(js2g0:jn1g1) ! Algebric filter at edge - real (r8) dc(im,js2g0:jn2g0) ! FFT filter at center - real (r8) de(im,js2g0:jn1g1) ! FFT filter at edge - -! !DESCRIPTION: -! -! Compute coefficients for the 3-point algebraic and the FFT -! polar filters. -! -! !REVISION HISTORY: -! -! 99.01.01 Lin Creation -! 99.08.20 Sawyer/Lin Changes for SPMD mode -! 01.01.30 Lin Put into this module -! 01.03.26 Sawyer Added ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real (r8), parameter :: pi = 3.14159265358979323846_R8 - integer i, j - real (r8) dl, coszc, cutoff, phi, damp - - coszc = cos(ycrit*pi/D180_0) - -! INIT fft polar coefficients: - dl = pi/real(im,r8) - cutoff = D1EM20 - - do j=js2g0,jn2g0 - do i=1,im - dc(i,j) = D1_0 - enddo - enddo - - do j=js2g0,jn1g1 - do i=1,im - de(i,j) = D1_0 - enddo - enddo - -! write(6,*) '3-point polar filter coefficients:' - -!************ -! Cell center -!************ - do j=js2g0,jn2g0 - sc(j) = (coszc/cosp(j))**2 - -#if !defined ( ALGEBRAIC_FILTER ) - if( sc(j) > D1_0 ) then -#else - if(sc(j) > D1_0 .and. sc(j) <= D2_0) then - sc(j) = D1_0 + (sc(j)-D1_0)/(sc(j)+D1_0) - elseif(sc(j) > D2_0 .and. sc(j) <= D4_0) then - sc(j) = D1_0 + sc(j)/(D8_0-sc(j)) - elseif(sc(j) > D4_0 ) then -#endif - -! FFT filter - do i=1,im/2 - phi = dl * i - damp = min((cosp(j)/coszc)/sin(phi),D1_0)**2 - if(damp < cutoff) damp = D0_0 - dc(2*i-1,j) = damp - dc(2*i ,j) = damp - enddo - - endif - enddo - -!************ -! Cell edges -!************ - do j=js2g0,jn1g1 - se(j) = (coszc/cose(j))**2 - -#if !defined ( ALGEBRAIC_FILTER ) - if( se(j) > D1_0 ) then -#else - if(se(j) > D1_0 .and. se(j) <= D2_0 ) then - se(j) = D1_0 + (se(j)-D1_0)/(se(j)+D1_0) - elseif(se(j) > D2_0 .and. se(j) <= D4_0) then - se(j) = D1_0 + se(j)/(D8_0-se(j)) - elseif(se(j) > D4_0 ) then -#endif -! FFT - do i=1,im/2 - phi = dl * i - damp = min((cose(j)/coszc)/sin(phi), D1_0)**2 - if(damp < cutoff) damp = D0_0 - de(2*i-1,j) = damp - de(2*i ,j) = damp - enddo - endif - enddo - return -!EOC - end subroutine pft_cf -!----------------------------------------------------------------------- - - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: fftfax --- Initialize FFT -! -! !INTERFACE: - subroutine fftfax (n, ifaxx, trigss) - -! !USES: - implicit none - -! !DESCRIPTION: -! -! Initialize the fast Fourier transform. If CPP token SGI_FFT is -! set, SGI libraries will be used. Otherwise the Fortran code -! is inlined. -! -! !REVISION HISTORY: -! -! 99.11.24 Sawyer Added wrappers for SGI -! 01.03.26 Sawyer Added ProTeX documentation -! 05.07.26 Worley Modified version for Cray X1 -! -!EOP -!----------------------------------------------------------------------- -!BOC - - integer n - -#if defined( SGI_FFT ) - real(r8) trigss(1) - integer ifaxx(*) -! local - integer*4 nn - - nn=n - call dzfftm1dui (nn,trigss) -#else - integer ifaxx(13) - real(r8) trigss(3*n/2+1) - call set99(trigss,ifaxx,n) -#endif - return -!EOC - end subroutine fftfax -!----------------------------------------------------------------------- - -end module pft_module diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pkez.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pkez.F90 deleted file mode 100644 index 93e1de20c..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pkez.F90 +++ /dev/null @@ -1,187 +0,0 @@ -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: pkez --- Calculate solution to hydrostatic equation -! -! !INTERFACE: -!****6***0*********0*********0*********0*********0*********0**********72 - subroutine pkez(nx, im, km, jfirst, jlast, kfirst, klast, & - ifirst, ilast, pe, pk, akap, ks, peln, pkz, eta) -!****6***0*********0*********0*********0*********0*********0**********72 -! -! !USES: - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - -! -! This routine may be called assuming either yz or xy decompositions. -! For xy decomposition, the effective "nx" is 1. -! - -! !INPUT PARAMETERS: - integer nx ! SMP decomposition in x - integer im, km ! Dimensions - integer jfirst, jlast ! Latitude strip - integer kfirst, klast ! Vertical strip - integer ifirst, ilast ! Longitude strip - real (r8) pe(ifirst:ilast, kfirst:klast+1, jfirst:jlast) ! Edge pressure - integer ks - logical eta ! Is on ETA coordinate? - ! True: input pe ; output pk, pkz, peln - ! False: input pe, pk; output pkz, peln - real (r8) akap - -! !INPUT/OUTPUT PARAMETERS: - real (r8) pk(ifirst:ilast,jfirst:jlast,kfirst:klast+1) - -! !OUTPUT PARAMETERS - real (r8) pkz(ifirst:ilast,jfirst:jlast,kfirst:klast) - real (r8) peln(ifirst:ilast, kfirst:klast+1, jfirst:jlast) ! log pressure (pe) at layer edges - -! !DESCRIPTION: -! -! -! !CALLED FROM: -! te_map and fvccm3 -! -! !REVISION HISTORY: -! -! WS 99.05.19 : Removed fvcore.h -! WS 99.07.27 : Limited region to jfirst:jlast -! WS 99.10.22 : Deleted cp as argument (was not used) -! WS 99.11.05 : Documentation; pruning of arguments -! SJL 00.01.02 : SMP decomposition in i -! AAM 00.08.10 : Add kfirst:klast -! AAM 01.06.27 : Add ifirst:ilast -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! Local - real (r8) pk2(ifirst:ilast, kfirst:klast+1) - real (r8) pek - real (r8) lnp - integer i, j, k, itot, nxu - integer ixj, jp, it, i1, i2 - - itot = ilast - ifirst + 1 -! Use smaller block sizes only if operating on full i domain - nxu = 1 - if (itot .eq. im) nxu = nx - - it = itot / nxu - jp = nxu * ( jlast - jfirst + 1 ) - -!$omp parallel do & -!$omp default(shared) & -!$omp private(ixj, i1, i2, i, j, k, pek, lnp, pk2) - -! WS 99.07.27 : Limited region to jfirst:jlast - - do 1000 ixj=1,jp - - j = jfirst + (ixj-1) / nxu - i1 = ifirst + it * mod(ixj-1, nxu) - i2 = i1 + it - 1 - - if ( eta ) then - -! <<<<<<<<<<< Eta cordinate Coordinate >>>>>>>>>>>>>>>>>>> - if (kfirst .eq. 1) then - pek = pe(i1,1,j)**akap - lnp = log(pe(i1,1,j)) - - do i=i1,i2 - pk2(i,1) = pek - peln(i,1,j) = lnp - enddo - endif - - if(ks .ne. 0) then - do k=max(2,kfirst), min(ks+1,klast+1) - pek = pe(i1,k,j)**akap - lnp = log(pe(i1,k,j)) - do i=i1,i2 - pk2(i,k) = pek - peln(i,k,j) = lnp - enddo - enddo - - do k=kfirst, min(ks,klast) - pek = ( pk2(i1,k+1) - pk2(i1,k)) / & - (akap*(peln(i1,k+1,j) - peln(i1,k,j)) ) - do i=i1,i2 - pkz(i,j,k) = pek - enddo - enddo - endif - - do k=max(ks+2,kfirst), klast+1 -#if !defined( VECTOR_MATH ) - do i=i1,i2 - pk2(i,k) = pe(i,k,j)**akap - enddo -#else - call vlog(pk2(i1,k), pe(i1,k,j), it) - do i=i1,i2 - pk2(i,k) = akap * pk2(i,k) - enddo - call vexp(pk2(i1,k), pk2(i1,k), it) -#endif - enddo - - do k=max(ks+2,kfirst), klast+1 - do i=i1,i2 - peln(i,k,j) = log(pe(i,k,j)) - enddo - enddo - - do k=max(ks+1,kfirst), klast - do i=i1,i2 - pkz(i,j,k) = (pk2(i,k+1) - pk2(i,k)) / & - (akap*(peln(i,k+1,j) - peln(i,k,j)) ) - enddo - enddo - - do k=kfirst, klast+1 - do i=i1,i2 - pk(i,j,k) = pk2(i,k) - enddo - enddo - - else - -! <<<<<<<<<<< General Coordinate >>>>>>>>>>>>>>>>>>> - - if (kfirst .eq. 1) then - pek = pk(i1,j,1) - lnp = log(pe(i1,1,j)) - - do i=i1,i2 - pk2(i,1) = pek - peln(i,1,j) = lnp - enddo - endif - - do k=max(2,kfirst), klast+1 - do i=i1,i2 - peln(i,k,j) = log(pe(i,k,j)) - pk2(i,k) = pk(i,j,k) - enddo - enddo - - do k=kfirst, klast - do i=i1,i2 - pkz(i,j,k) = ( pk2(i,k+1) - pk2(i,k) ) / & - (akap*(peln(i,k+1,j) - peln(i,k,j)) ) - enddo - enddo - - endif -1000 continue - - return -!EOC - end -!----------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pmaxmin.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pmaxmin.F90 deleted file mode 100644 index 163268d6c..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/pmaxmin.F90 +++ /dev/null @@ -1,65 +0,0 @@ -! Parallelized utility routine for computing/printing -! max/min of an input array -! - subroutine pmaxmin( grid, qname, a, pmin, pmax, im, jt, fac ) - - use dynamics_vars, only : T_FVDYCORE_GRID - use shr_kind_mod, only : r8 => shr_kind_r8 -#if defined( SPMD ) -#define CPP_PRT_PREFIX if(gid.eq.0) - use parutilitiesmodule, only : commglobal, gid, maxop, parcollective -#else -#define CPP_PRT_PREFIX -#endif - - implicit none - - type (T_FVDYCORE_GRID), intent(in) :: grid - - character*(*) qname - integer im, jt - real(r8) a(im,jt) - real(r8) pmax, pmin - real(r8) fac ! multiplication factor - - integer :: two = 2 - integer i, j - - real(r8) qmin(jt), qmax(jt) - real(r8) pm1(2) - -!$omp parallel do private(i, j, pmax, pmin) - - do j=1,jt - pmax = a(1,j) - pmin = a(1,j) - do i=2,im - pmax = max(pmax, a(i,j)) - pmin = min(pmin, a(i,j)) - enddo - qmax(j) = pmax - qmin(j) = pmin - enddo -! -! Now find max/min of amax/amin -! - pmax = qmax(1) - pmin = qmin(1) - do j=2,jt - pmax = max(pmax, qmax(j)) - pmin = min(pmin, qmin(j)) - enddo - - -#if defined( SPMD ) - pm1(1) = pmax - pm1(2) = -pmin - call parcollective(commglobal, maxop, two, pm1 ) - pmax=pm1(1) - pmin=-pm1(2) -#endif - - CPP_PRT_PREFIX write(*,*) qname, ' max = ', pmax*fac, ' min = ', pmin*fac - - return - end diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/remap.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/remap.F90 deleted file mode 100644 index e25260941..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/remap.F90 +++ /dev/null @@ -1,158 +0,0 @@ - subroutine remap ( ple,u,v,thv,qtr,phis_in,phis_out,ak,bk,im,jm,lm,km ) - -!*********************************************************************** -! -! Purpose -! Driver for remapping fields to new topography -! -! Argument Description -! ple ...... model edge pressure -! u ....... model zonal wind -! v ....... model meridional wind -! thv ..... model virtual potential temperature -! q ....... model specific humidity -! o3 ...... model ozone -! phis_in... model surface geopotential (input) -! phis_out.. model surface geopotential (output) -! ak ....... model vertical dimension -! bk ....... model vertical dimension -! -! im ....... zonal dimension -! jm ....... meridional dimension -! lm ....... meridional dimension -! -!*********************************************************************** - - use MAPL - use dynamics_vars, only : T_TRACERS - - implicit none - integer im,jm,lm,km - -! Input variables -! --------------- - type(T_TRACERS) qtr(km) - real*8 ple(im,jm,lm+1) - real*8 u(im,jm,lm) - real*8 v(im,jm,lm) - real*8 thv(im,jm,lm) - real*8 q(im,jm,lm) - real*8 o3(im,jm,lm) - real*8 phis_in (im,jm) - real*8 phis_out(im,jm) - - real*8 ak(lm+1) - real*8 bk(lm+1) - -! Local variables -! --------------- - real*8, allocatable :: ps (:,:) - real*8, allocatable :: phi (:,:,:) - real*8, allocatable :: pke (:,:,:) - real*8, allocatable :: ple_out(:,:,:) - real*8, allocatable :: pke_out(:,:,:) - - real*8, allocatable :: delp(:,:,:) - real*8, allocatable :: u_out(:,:,:) - real*8, allocatable :: v_out(:,:,:) - real*8, allocatable :: thv_out(:,:,:) - real*8, allocatable :: q_in (:,:,:,:) - real*8, allocatable :: q_out(:,:,:,:) - - real*8 kappa,cp,rgas,eps,rvap - integer i,j,L,n,k - - kappa = MAPL_KAPPA - rgas = MAPL_RGAS - rvap = MAPL_RVAP - eps = rvap/rgas-1.0 - cp = rgas/kappa - - allocate( ps (im,jm) ) - allocate( phi (im,jm,lm+1) ) - allocate( pke (im,jm,lm+1) ) - allocate( ple_out(im,jm,lm+1) ) - allocate( pke_out(im,jm,lm+1) ) - - allocate( delp(im,jm,lm) ) - allocate( u_out(im,jm,lm) ) - allocate( v_out(im,jm,lm) ) - allocate( thv_out(im,jm,lm) ) - allocate( q_in (im,jm,lm,km)) - allocate( q_out(im,jm,lm,km)) - -! Construct Input Heights -! ----------------------- - pke(:,:,:) = ple(:,:,:)**kappa - - phi(:,:,lm+1) = phis_in(:,:) - do L=lm,1,-1 - phi(:,:,L) = phi(:,:,L+1) + cp*thv(:,:,L)*( pke(:,:,L+1)-pke(:,:,L) ) - enddo - -! Compute new surface pressure consistent with output topography -! -------------------------------------------------------------- - do j=1,jm - do i=1,im - L = lm - do while ( phi(i,j,L).lt.phis_out(i,j) ) - L = L-1 - enddo - ps(i,j) = ple(i,j,L+1)*( 1+(phi(i,j,L+1)-phis_out(i,j))/(cp*thv(i,j,L)*pke(i,j,L+1)) )**(1.0/kappa) - enddo - enddo - -! Construct fv pressure variables using new surface pressure -! ---------------------------------------------------------- - do L=1,lm+1 - do j=1,jm - do i=1,im - ple_out(i,j,L) = ak(L) + bk(L)*ps(i,j) - enddo - enddo - enddo - pke_out(:,:,:) = ple_out(:,:,:)**kappa - -! Map original fv state onto new eta grid -! --------------------------------------- - - do k=1,size(qtr) - if(qtr(k)%is_r4) then - q_in(:,:,:,k) = qtr(k)%content_r4 - else - q_in(:,:,:,k) = qtr(k)%content - end if - enddo - - call gmap ( im,jm,km, kappa, & - lm, pke ,ple ,u ,v ,thv ,q_in , & - lm, pke_out,ple_out,u_out,v_out,thv_out,q_out) - - do k=1,size(qtr) - if(qtr(k)%is_r4) then - qtr(k)%content_r4 = q_out(:,:,:,k) - else - qtr(k)%content = q_out(:,:,:,k) - end if - enddo - - ple(:,:,:) = ple_out(:,:,:) - u(:,:,:) = u_out(:,:,:) - v(:,:,:) = v_out(:,:,:) - thv(:,:,:) = thv_out(:,:,:) - - deallocate( ps ) - deallocate( phi ) - deallocate( pke ) - deallocate( ple_out ) - deallocate( pke_out ) - - deallocate( delp ) - deallocate( u_out ) - deallocate( v_out ) - deallocate( thv_out ) - deallocate( q_in ) - deallocate( q_out ) - - return - end diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/shr_kind_mod.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/shr_kind_mod.F90 deleted file mode 100644 index 6e17ed3eb..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/shr_kind_mod.F90 +++ /dev/null @@ -1,27 +0,0 @@ -!=============================================================================== -! CVS: $Id$ -! CVS: $Source$ -! CVS: $Name$ -!=============================================================================== - -MODULE shr_kind_mod - - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - public -#ifdef NO_R16 - integer,parameter :: SHR_KIND_R16= selected_real_kind(12) ! 8 byte real -#else - integer,parameter :: SHR_KIND_R16= selected_real_kind(24) ! 16 byte real -#endif - integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real - integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real - integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real - integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer - integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer - integer,parameter :: SHR_KIND_IN = kind(1) ! native integer - integer,parameter :: SHR_KIND_CL = 256 ! long char - integer,parameter :: SHR_KIND_CS = 80 ! short char - -END MODULE shr_kind_mod diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/sw_core.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/sw_core.F90 deleted file mode 100644 index 2b89e0936..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/sw_core.F90 +++ /dev/null @@ -1,1315 +0,0 @@ -module sw_core -!BOP -! -! !MODULE: sw_core --- Utilities for solving the shallow-water equation -! -! !USES: - use dynamics_vars, only: T_FVDYCORE_GRID - use shr_kind_mod, only : r8 => shr_kind_r8 - -#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 - -! -! !PUBLIC MEMBER FUNCTIONS: - public d2a2c_winds, c_sw, d_sw -! -! !DESCRIPTION: -! -! This module contains vertical independent part of the Lagrangian -! dynamics; in simpler terms, it solves the 2D shallow water equation -! (SWE). -! -! \begin{tabular}{|l|l|} \hline \hline -! c_sw & \\ \hline -! d_sw & -! \end{tabular} -! -! !REVISION HISTORY: -! 01.01.15 Lin Routines coalesced into this module -! 03.11.19 Sawyer Merged in CAM changes by Mirin -! 04.10.07 Sawyer ompinner now from dynamics_vars -! 05.03.25 Todling shr_kind_r8 can only be referenced once (MIPSpro-7.4.2) -! 05.05.25 Sawyer Merged CAM and GEOS5 versions (mostly CAM) -! 05.07.26 Worley Changes for Cray X1 -! 05.07.05 Sawyer Interfaces of c_sw and d_sw simplified with grid -! 05.10.12 Worley More changes for Cray X1(E), avoiding array segment copying -! 06.01.18 Putman Allowed Y-dir courant number and mass flux to accumulate -! at jlast+1 -! 06.09.06 Sawyer Isolated magic numbers as F90 parameters -! -!EOP - -! Magic numbers used in this module - - real(r8), parameter :: D0_0 = 0.0_r8 - real(r8), parameter :: D0_125 = 0.125_r8 - real(r8), parameter :: D0_25 = 0.25_r8 - real(r8), parameter :: D0_5 = 0.5_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D2_0 = 2.0_r8 - real(r8), parameter :: D1E30 = 1.0e30_r8 - -contains - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: c_sw --- Solve the SWE on a C grid -! -! !INTERFACE: - subroutine c_sw(grid, u, v, pt, delp, u2, v2, & - uc, vc, ptc, delpf, ptk, & - tiny, iord, jord) - -! Routine for shallow water dynamics on the C-grid - -! !USES: - - use tp_core - use pft_module, only : pft2d - - implicit none - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - integer, intent(in):: iord - integer, intent(in):: jord - - real(r8), intent(in):: u2(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8), intent(in):: v2(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d) - -! Prognostic variables: - real(r8), intent(in):: u(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_s) - real(r8), intent(in):: v(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d) - real(r8), intent(in):: pt(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8), intent(in):: delp(grid%im,grid%jfirst:grid%jlast) - real(r8), intent(in):: delpf(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - - real(r8), intent(in):: tiny - -! !INPUT/OUTPUT PARAMTERS: - real(r8), intent(inout):: uc(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8), intent(inout):: vc(grid%im,grid%jfirst-2:grid%jlast+2 ) - -! !OUTPUT PARAMETERS: - real(r8), intent(out):: ptc(grid%im,grid%jfirst:grid%jlast) - real(r8), intent(out):: ptk(grid%im,grid%jfirst:grid%jlast) - -! !DESCRIPTION: -! -! Routine for shallow water dynamics on the C-grid -! -! !REVISION HISTORY: -! WS 2003.11.19 Merged in CAM changes by Mirin -! WS 2004.10.07 Added ProTeX documentation -! WS 2005.07.01 Simplified interface by passing grid -! WP 2007.06.01 Refactoring to address cross-pole instability -! WS 2007.07.03 V2 (intent(in)) replaced by local array WK4 -! -!EOP -!----------------------------------------------------------------------- -!BOC - - -!-------------------------------------------------------------- -! Local - real(r8) :: zt_c - real(r8) :: dydt - real(r8) :: dtdy5 - real(r8) :: rcap - - real(r8), pointer:: sc(:) - real(r8), pointer:: dc(:,:) - real(r8), pointer:: se(:) - real(r8), pointer:: de(:,:) - - real(r8), pointer:: cosp(:) - real(r8), pointer:: acosp(:) - real(r8), pointer:: cose(:) - - real(r8), pointer:: dxdt(:) - real(r8), pointer:: dxe(:) - real(r8), pointer:: rdxe(:) - real(r8), pointer:: dtdx2(:) - real(r8), pointer:: dtdx4(:) - real(r8), pointer:: dtxe5(:) - real(r8), pointer:: dycp(:) - real(r8), pointer:: cye(:) - - real(r8), pointer:: fc(:) - - real(r8), pointer:: sinlon(:) - real(r8), pointer:: coslon(:) - real(r8), pointer:: sinl5(:) - real(r8), pointer:: cosl5(:) - - -! WS: introduced work array to avoid using v2 - real(r8) :: wk4(grid%im+2,grid%jfirst: grid%jlast+2) - - real(r8) :: fx(grid%im,grid%jfirst:grid%jlast) - real(r8) :: xfx(grid%im,grid%jfirst:grid%jlast) - real(r8) :: tm2(grid%im,grid%jfirst:grid%jlast) - - real(r8) :: va(grid%im,grid%jfirst-1:grid%jlast) - - real(r8) :: wk1(grid%im,grid%jfirst-1:grid%jlast+1) - real(r8) :: cry(grid%im,grid%jfirst-1:grid%jlast+1) - real(r8) :: fy(grid%im,grid%jfirst-1:grid%jlast+1) - - real(r8) :: ymass(grid%im,grid%jfirst: grid%jlast+1) - real(r8) :: yfx(grid%im,grid%jfirst: grid%jlast+1) - - real(r8) :: vort_u(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8) :: vort(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d) - - real(r8) :: crx(grid%im,grid%jfirst-grid%ng_c:grid%jlast+grid%ng_c) - - real(r8) :: fxjv(grid%im,grid%jfirst-1:grid%jn2g0) - real(r8) :: p1dv(grid%im,grid%jfirst-1:grid%jn2g0) - real(r8) :: cx1v(grid%im,grid%jfirst-1:grid%jn2g0) - - real(r8) :: qtmp(-grid%im/3:grid%im+grid%im/3) - real(r8) :: qtmpv(-grid%im/3:grid%im+grid%im/3, grid%jfirst-1:grid%jn2g0) - real(r8) :: slope(-grid%im/3:grid%im+grid%im/3) - real(r8) :: al(-grid%im/3:grid%im+grid%im/3) - real(r8) :: ar(-grid%im/3:grid%im+grid%im/3) - real(r8) :: a6(-grid%im/3:grid%im+grid%im/3) - - real(r8) :: us, vs, un, vn - real(r8) :: p1ke, p2ke - real(r8) :: uanp(grid%im), uasp(grid%im), vanp(grid%im), vasp(grid%im), r2im - - logical :: ffsl(grid%jm) - logical :: sldv(grid%jfirst-1:grid%jn2g0) - - integer :: i, j, im2 - integer :: js1g1, js2g1, js2gc1, js2gcp1, jn2gc, jn1g1, js2g0, js2gc, jn1gc - integer :: im, jm, jfirst, jlast, jn2g0, ng_s, ng_c, ng_d - - -! -! For convenience -! - - im = grid%im - jm = grid%jm - jfirst = grid%jfirst - jlast = grid%jlast - - jn2g0 = grid%jn2g0 - - ng_c = grid%ng_c - ng_d = grid%ng_d - ng_s = grid%ng_s - - rcap = grid%rcap - - zt_c = grid%zt_c - dydt = grid%dydt - dtdy5 = grid%dtdy5 - - sc => grid%sc - dc => grid%dc - se => grid%se - de => grid%de - - cosp => grid%cosp - acosp => grid%acosp - cose => grid%cose - - dxdt => grid%dxdt - dxe => grid%dxe - rdxe => grid%rdxe - dtdx2 => grid%dtdx2 - dtdx4 => grid%dtdx4 - dtxe5 => grid%dtxe5 - dycp => grid%dycp - cye => grid%cye - fc => grid%fc - - sinlon => grid%sinlon - coslon => grid%coslon - sinl5 => grid%sinl5 - cosl5 => grid%cosl5 - - -! Set loop limits - - im2 = im/2 - - js2g0 = max(2,jfirst) - js2gc = max(2,jfirst-ng_c) ! NG lats on S (starting at 2) - jn1gc = min(jm,jlast+ng_c) ! ng_c lats on N (ending at jm) - js1g1 = max(1,jfirst-1) - js2g1 = max(2,jfirst-1) - js2gcp1= max(2,jfirst-ng_c-1) ! NG-1 latitudes on S (starting at 2) - jn1g1 = min(jm,jlast+1) - jn2gc = min(jm-1,jlast+ng_c) ! NG latitudes on N (ending at jm-1) - js2gc1 = max(2,jfirst-ng_c+1) ! NG-1 latitudes on S (starting at 2) - -! MAT Initialize fx fy - - fx = D0_0 - fy = D0_0 - -! KE at poles - if ( jfirst-ng_d <= 1 ) then - p1ke = D0_125*(u2(1, 1)**2 + v2(1, 1)**2) - endif - - if ( jlast+ng_d >= jm ) then - p2ke = D0_125*(u2(1,jm)**2 + v2(1,jm)**2) - endif - - if ( jfirst /= 1 ) then - do i=1,im - cry(i,jfirst-1) = dtdy5*vc(i,jfirst-1) - enddo - - endif - - do j=js2g0,jn1g1 ! ymass needed on NS - do i=1,im - cry(i,j) = dtdy5*vc(i,j) - ymass(i,j) = cry(i,j)*cose(j) - enddo - enddo - -! New va definition - do j=js2g1,jn2g0 ! va needed on S (for YCC, iv==1) - do i=1,im - va(i,j) = D0_5*(cry(i,j)+cry(i,j+1)) - enddo - enddo - -! SJL: Check if FFSL integer fluxes need to be computed - - do j=js2gc,jn2gc ! ffsl needed on N*sg S*sg - do i=1,im - crx(i,j) = uc(i,j)*dtdx2(j) - enddo - ffsl(j) = .false. - if( cosp(j) < zt_c ) then - do i=1,im - if( abs(crx(i,j)) > D1_0 ) then - ffsl(j) = .true. -#if ( !defined UNICOSMP ) || ( !defined NEC_SX ) - exit -#endif - endif - enddo - endif - enddo - -! 2D transport of polar filtered delp (for computing fluxes!) -! Update is done on the unfiltered delp - - call tp2c( ptk, va(1,jfirst), delpf(1,jfirst-ng_c), & - crx(1,jfirst-ng_c), cry(1,jfirst), & - im, jm, iord, jord, ng_c, xfx, & - yfx, ffsl, rcap, acosp, & - crx(1,jfirst), ymass, cosp, & - 0, jfirst, jlast) - - do j=js2g0,jn2g0 ! xfx not ghosted - if( ffsl(j) ) then - do i=1,im - xfx(i,j) = xfx(i,j)/sign(max(abs(crx(i,j)),tiny),crx(i,j)) - enddo - endif - enddo - -! pt-advection using pre-computed mass fluxes -! use tm2 below as the storage for pt increment -! WS 99.09.20 : pt, crx need on N*ng S*ng, yfx on N - - call tp2c(tm2 ,va(1,jfirst), pt(1,jfirst-ng_c), & - crx(1,jfirst-ng_c), cry(1,jfirst), & - im, jm, iord, jord, ng_c, fx, & - fy(1,jfirst), ffsl, rcap, acosp, & - xfx, yfx, cosp, 1, jfirst, jlast) - -! use v2, crx as work arrays - call pft2d(ptk(1,js2g0), sc, & - dc, im, jn2g0-js2g0+1, & - wk4, crx ) - call pft2d(tm2(1,js2g0), sc, & - dc, im, jn2g0-js2g0+1, & - wk4, crx ) - - do j=jfirst,jlast - do i=1,im - ptk(i,j) = delp(i,j) + ptk(i,j) - ptc(i,j) = (pt(i,j)*delp(i,j) + tm2(i,j))/ptk(i,j) - enddo - enddo - -!------------------ -! Momentum equation -!------------------ - - call ycc(im, jm, fy, vc(1,jfirst-2), va(1,jfirst-1), & - va(1,jfirst-1), jord, 1, jfirst, jlast) - - do j=js2g1,jn2g0 - - do i=1,im - cx1v(i,j) = dtdx4(j)*u2(i,j) - enddo - - sldv(j) = .false. - if( cosp(j) < zt_c ) then - do i=1,im - if( abs(cx1v(i,j)) > D1_0 ) then - sldv(j) = .true. -#if ( !defined UNICOSMP ) || ( !defined NEC_SX ) - exit -#endif - endif - enddo - endif - - p1dv(im,j) = uc(1,j) - do i=1,im-1 - p1dv(i,j) = uc(i+1,j) - enddo - - enddo - - call xtpv(im, sldv, fxjv, p1dv, cx1v, iord, cx1v, & - cosp, 0, slope, qtmpv, al, ar, a6, & - jfirst, jlast, js2g1, jn2g0, jm, & - jfirst-1, jn2g0, jfirst-1, jn2g0, & - jfirst-1, jn2g0, jfirst-1, jn2g0, & - jfirst-1, jn2g0, jfirst-1, jn2g0) - - do j=js2g1,jn2g0 - do i=1,im - wk1(i,j) = dxdt(j)*fxjv(i,j) + dydt*fy(i,j) - enddo - enddo - - if ( jfirst == 1 ) then - do i=1,im - wk1(i,1) = p1ke - enddo - endif - - if ( jlast == jm ) then - do i=1,im - wk1(i,jm) = p2ke - enddo - endif - -! crx redefined - do j=js2gc1,jn1gc - crx(1,j) = dtxe5(j)*u(im,j) - do i=2,im - crx(i,j) = dtxe5(j)*u(i-1,j) - enddo - enddo - - if ( jfirst /=1 ) then - do i=1,im - cry(i,jfirst-1) = dtdy5*v(i,jfirst-1) - enddo - endif - - do j=jfirst,jlast - do i=1,im - cry(i,j) = dtdy5*v(i,j) - ymass(i,j) = cry(i,j)*cosp(j) ! ymass actually unghosted - enddo - enddo - - do j=js2g0,jlast - do i=1,im - tm2(i,j) = D0_5*(cry(i,j)+cry(i,j-1)) ! cry ghosted on S - enddo - enddo - -! Compute absolute vorticity on the C-grid. - - if ( jfirst-ng_d <= 1 ) then - do i=1,im - vort_u(i,1) = D0_0 - enddo - endif - - do j=js2gc,jn2gc - do i=1,im - vort_u(i,j) = uc(i,j)*cosp(j) - enddo - enddo - - if ( jlast+ng_d >= jm ) then - do i=1,im - vort_u(i,jm) = D0_0 - enddo - endif - - do j=js2gc1,jn1gc -! The computed absolute vorticity on C-Grid is assigned to vort - vort(1,j) = fc(j) + (vort_u(1,j-1)-vort_u(1,j))*cye(j) + & - (vc(1,j) - vc(im,j))*rdxe(j) - - do i=2,im - vort(i,j) = fc(j) + (vort_u(i,j-1)-vort_u(i,j))*cye(j) + & - (vc(i,j) - vc(i-1,j))*rdxe(j) - enddo - enddo - - do j=js2gc1,jn1gc ! ffsl needed on N*ng S*(ng-1) - ffsl(j) = .false. - if( cose(j) < zt_c ) then - do i=1,im - if( abs(crx(i,j)) > D1_0 ) then - ffsl(j) = .true. -#if ( !defined UNICOSMP ) || ( !defined NEC_SX ) - exit -#endif - endif - enddo - endif - enddo - - call tpcc( tm2, ymass, vort(1,jfirst-ng_d), crx(1,jfirst-ng_c), & - cry(1,jfirst), im, jm, ng_c, ng_d, & - iord, jord, fx, fy(1,jfirst), ffsl, cose, & - jfirst, jlast, slope, qtmp, al, ar, a6 ) - - do j=js2g0,jn2g0 - uc(1,j) = uc(1,j) + dtdx2(j)*(wk1(im,j)-wk1(1,j)) + dycp(j)*fy(1,j) - do i=2,im - uc(i,j) = uc(i,j) + dtdx2(j)*(wk1(i-1,j)-wk1(i,j)) + dycp(j)*fy(i,j) - enddo - enddo - - do j=js2g0,jlast - do i=1,im-1 - vc(i,j) = vc(i,j) + dtdy5*(wk1(i,j-1)-wk1(i,j))-dxe(j)*fx(i+1,j) - enddo - vc(im,j) = vc(im,j) + dtdy5*(wk1(im,j-1)-wk1(im,j))-dxe(j)*fx(1,j) - enddo - -!EOC - end subroutine c_sw -!-------------------------------------------------------------------------- - - - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: d_sw --- Solve the SWE on a D grid -! -! !INTERFACE: - subroutine d_sw( grid, u, v, uc, vc, & - pt, delp, delpf, cx3, cy3, & - mfx, mfy, ptfx, ptfy, cdx, cdy, iord, & - jord, tiny ) -!-------------------------------------------------------------------------- -! Routine for shallow water dynamics on the D-grid - -! !USES: - - use tp_core - use pft_module, only : pft2d - - implicit none - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - integer, intent(in):: iord - integer, intent(in):: jord - -! Prognostic variables: - real(r8), intent(inout):: u(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_s) - real(r8), intent(in):: v(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d) -! Delta pressure - real(r8), intent(inout):: delp(grid%im,grid%jfirst:grid%jlast) -! Potential temperature - real(r8), intent(inout):: pt(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - - real(r8), intent(inout):: delpf(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - - real(r8), intent(in):: cdx(grid%js2g0:grid%jn1g1) - real(r8), intent(in):: cdy(grid%js2g0:grid%jn1g1) - - real(r8), intent(in):: tiny - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout):: uc(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8), intent(inout):: vc(grid%im,grid%jfirst-2 :grid%jlast+2 ) - real(r8), intent(inout):: cx3(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d)! Accumulated Courant number in X - real(r8), intent(inout):: cy3(grid%im,grid%jfirst:grid%jlast+1) ! Accumulated Courant number in Y - real(r8), intent(inout):: mfx(grid%im,grid%jfirst:grid%jlast) ! Mass flux in X (unghosted) - real(r8), intent(inout):: mfy(grid%im,grid%jfirst:grid%jlast+1) ! Mass flux in Y - real(r8), intent(inout):: ptfx(grid%im,grid%jfirst:grid%jlast) ! Mass-weighted PT flux in X (unghosted) - real(r8), intent(inout):: ptfy(grid%im,grid%jfirst:grid%jlast+1) ! Mass-weyghted PT flux in Y - -! !DESCRIPTION: -! -! Routine for shallow water dynamics on the D-grid -! -! !REVISION HISTORY: -! WS 2003.11.19 Merged in CAM changes by Mirin -! WS 2004.10.07 Added ProTeX documentation -! WS 2005.07.05 Simplified interface using grid -! -!EOP -!----------------------------------------------------------------------- -!BOC - - -! Local - integer :: im - integer :: jm - integer :: jfirst - integer :: jlast - integer :: js2g0 - integer :: jn1g1 - integer :: ng_d - integer :: ng_s - integer :: nq - - real(r8) :: zt_d - real(r8) :: tdy5 - real(r8) :: rdy - real(r8) :: dtdy - real(r8) :: dtdy5 - real(r8) :: rcap - - real(r8), pointer:: sc(:) - real(r8), pointer:: dc(:,:) - real(r8), pointer:: se(:) - real(r8), pointer:: de(:,:) - - real(r8), pointer :: cosp(:) - real(r8), pointer :: acosp(:) - real(r8), pointer :: cose(:) - - real(r8), pointer :: sinlon(:) - real(r8), pointer :: coslon(:) - real(r8), pointer :: sinl5(:) - real(r8), pointer :: cosl5(:) - - real(r8), pointer :: dtdx(:) - real(r8), pointer :: dtdxe(:) - real(r8), pointer :: dx(:) - real(r8), pointer :: rdx(:) - real(r8), pointer :: cy(:) - real(r8), pointer :: dyce(:) - real(r8), pointer :: dtxe5(:) - real(r8), pointer :: txe5(:) - - real(r8), pointer :: f0(:) - - - real(r8) fx(grid%im,grid%jfirst:grid%jlast) - real(r8) xfx(grid%im,grid%jfirst:grid%jlast) - - real(r8) wk1(grid%im,grid%jfirst-1:grid%jlast+1) - real(r8) cry(grid%im,grid%jfirst-1:grid%jlast+1) - real(r8) fy(grid%im,grid%jfirst-1:grid%jlast+1) - - real(r8) ymass(grid%im,grid%jfirst: grid%jlast+1) - real(r8) yfx(grid%im,grid%jfirst: grid%jlast+1) - - real(r8) va(grid%im,grid%jfirst-1:grid%jlast) - real(r8) ub(grid%im,grid%jfirst: grid%jlast+1) - - real(r8) crx(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8) u2(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8) v2(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d) - - real(r8) fxjv(grid%im,grid%jfirst-1:grid%jn1g1) - real(r8) qtmpv(-grid%im/3:grid%im+grid%im/3, grid%jfirst-1:grid%jn1g1) - real(r8) slope(-grid%im/3:grid%im+grid%im/3) - real(r8) al(-grid%im/3:grid%im+grid%im/3) - real(r8) ar(-grid%im/3:grid%im+grid%im/3) - real(r8) a6(-grid%im/3:grid%im+grid%im/3) - - real(r8) c1, c2 - real(r8) uanp(grid%im), uasp(grid%im), vanp(grid%im), vasp(grid%im) - real(r8) un, vn, us, vs, r2im - - logical ffsl(grid%jm) - logical sldv(grid%jfirst-1:grid%jn1g1) - - integer i, j - integer js2gd, jn2g0, jn2g1, jn2gd, jn1gd - integer im2 - -! -! For convenience -! - nq = grid%nq - - im = grid%im - jm = grid%jm - jfirst = grid%jfirst - jlast = grid%jlast - ng_d = grid%ng_d - ng_s = grid%ng_s - js2g0 = grid%js2g0 - jn1g1 = grid%jn1g1 - - rcap = grid%rcap - zt_d = grid%zt_d - tdy5 = grid%tdy5 - rdy = grid%rdy - dtdy = grid%dtdy - dtdy5 = grid%dtdy5 - - sc => grid%sc - dc => grid%dc - se => grid%se - de => grid%de - - cosp => grid%cosp - acosp => grid%acosp - cose => grid%cose - - sinlon => grid%sinlon - coslon => grid%coslon - sinl5 => grid%sinl5 - cosl5 => grid%cosl5 - - dtdx => grid%dtdx - dtdxe => grid%dtdxe - dx => grid%dx - rdx => grid%rdx - cy => grid%cy - dyce => grid%dyce - dtxe5 => grid%dtxe5 - txe5 => grid%txe5 - - f0 => grid%f0 - -! Set loop limits - - jn2g0 = min(jm-1,grid%jlast) - jn2g1 = min(jm-1,grid%jlast+1) - js2gd = max(2,jfirst-ng_d) ! NG latitudes on S (starting at 1) - jn2gd = min(jm-1,grid%jlast+ng_d) ! NG latitudes on S (ending at jm-1) - jn1gd = min(jm,jlast+ng_d) ! NG latitudes on N (ending at jm) - -! Get C-grid U-wind at poles. - im2 = im/2 - r2im = 0.5_r16/real(im,r16) - -! MAT Initialize fx fy - - fx = D0_0 - fy = D0_0 - - if ( jfirst <= 1 ) then -! -! Treat SP -! - do i=1,im-1 - uasp(i) = uc(i,2) + uc(i+1,2) - vasp(i) = vc(i,2) + vc(i,3) - enddo - uasp(im) = uc(im,2) + uc(1,2) - vasp(im) = vc(im,2) + vc(im,3) - -! Projection at SP - - us = D0_0 - vs = D0_0 - do i=1,im2 - us = us + (uasp(i+im2)-uasp(i))*sinlon(i) & - + (vasp(i)-vasp(i+im2))*coslon(i) - vs = vs + (uasp(i+im2)-uasp(i))*coslon(i) & - + (vasp(i+im2)-vasp(i))*sinlon(i) - enddo - us = us*r2im - vs = vs*r2im - -! get U-wind at SP - - do i=1,im2 - uc(i, 1) = -us*sinl5(i) - vs*cosl5(i) - uc(i+im2, 1) = -uc(i, 1) - enddo - - endif - - if ( jlast >= jm ) then -! -! Treat NP -! - do i=1,im-1 - uanp(i) = uc(i,jm-1) + uc(i+1,jm-1) - vanp(i) = vc(i,jm-1) + vc(i,jm) - enddo - uanp(im) = uc(im,jm-1) + uc(1,jm-1) - vanp(im) = vc(im,jm-1) + vc(im,jm) - -! Projection at NP - - un = D0_0 - vn = D0_0 - do i=1,im2 - un = un + (uanp(i+im2)-uanp(i))*sinlon(i) & - + (vanp(i+im2)-vanp(i))*coslon(i) - vn = vn + (uanp(i)-uanp(i+im2))*coslon(i) & - + (vanp(i+im2)-vanp(i))*sinlon(i) - enddo - un = un*r2im - vn = vn*r2im - -! get U-wind at NP - - do i=1,im2 - uc(i,jm) = -un*sinl5(i) + vn*cosl5(i) - uc(i+im2,jm) = -uc(i,jm) - enddo - - endif - - do j=js2gd,jn2gd ! crx needed on N*ng S*ng - do i=1,im - crx(i,j) = dtdx(j)*uc(i,j) - enddo - enddo - - do j=js2gd,jn2gd ! ffsl needed on N*ng S*ng - ffsl(j) = .false. - if( cosp(j) < zt_d ) then - do i=1,im - if( abs(crx(i,j)) > D1_0 ) then - ffsl(j) = .true. -#if ( !defined UNICOSMP ) || ( !defined NEC_SX ) - exit -#endif - endif - enddo - endif - enddo - - do j=js2g0,jn1g1 ! cry, ymass needed on N - do i=1,im - cry(i,j) = dtdy*vc(i,j) - ymass(i,j) = cry(i,j)*cose(j) - enddo - enddo - - do j=js2g0,jn2g0 ! No ghosting - do i=1,im - if( cry(i,j)*cry(i,j+1) > D0_0 ) then - if( cry(i,j) > D0_0 ) then - va(i,j) = cry(i,j) - else - va(i,j) = cry(i,j+1) ! cry ghosted on N - endif - else - va(i,j) = D0_0 - endif - enddo - enddo - -! transport polar filtered delp - call tp2c(ub(1,jfirst), va(1,jfirst), delpf(1,jfirst-ng_d), & - crx(1,jfirst-ng_d),cry(1,jfirst),im,jm,iord,jord, & - ng_d, xfx, yfx, ffsl, & - rcap, acosp,crx(1,jfirst), ymass, & - cosp, 0, jfirst, jlast) - -#if defined(FILTER_MASS_FLUXES) - call pft2d( xfx(1,js2g0), sc, dc, im, jn2g0-js2g0+1, & - v2, u2 ) - call pft2d( yfx(1,js2g0), se, de, im, jn1g1-js2g0+1, & - v2, u2 ) - do j=js2g0,jn2g0 - do i=1,im-1 - ub(i,j) = xfx(i,j) - xfx(i+1,j) + (yfx(i,j)-yfx(i,j+1))*acosp(j) - enddo - ub(im,j) = xfx(im,j) - xfx(1,j) + (yfx(im,j)-yfx(im,j+1))*acosp(j) - enddo -#endif - -! <<< Save necessary data for large time step tracer transport >>> - if( nq > 0 ) then - do j=js2g0,jn2g0 ! No ghosting needed - do i=1,im - cx3(i,j) = cx3(i,j) + crx(i,j) - mfx(i,j) = mfx(i,j) + xfx(i,j) - enddo - enddo - - do j=js2g0,jlast ! No ghosting needed - do i=1,im - cy3(i,j) = cy3(i,j) + cry(i,j) - mfy(i,j) = mfy(i,j) + yfx(i,j) - enddo - enddo - endif - - do j=js2g0,jn2g0 ! No ghosting needed - if( ffsl(j) ) then - do i=1,im - xfx(i,j) = xfx(i,j)/sign(max(abs(crx(i,j)),tiny),crx(i,j)) - enddo - endif - enddo - -! Update delp - do j=jfirst,jlast - do i=1,im -! SAVE old delp: pressure thickness ~ "air density" - wk1(i,j) = delp(i,j) - delp(i,j) = wk1(i,j) + ub(i,j) - enddo - enddo - -! pt Advection - call tp2c(ub(1,jfirst),va(1,jfirst),pt(1,jfirst-ng_d), & - crx(1,jfirst-ng_d),cry(1,jfirst), & - im,jm,iord,jord,ng_d,fx,fy(1,jfirst), & - ffsl, rcap, acosp, & - xfx, yfx(1,jfirst), cosp, 1, jfirst,jlast) - -! Accumulate the PT fluxes fx,fy - ptfx(:,:) = ptfx(:,:) + fx(:,:) - ptfy(:,:) = ptfy(:,:) + fy(:,jfirst:jlast+1) - -! Update pt. - do j=jfirst,jlast - do i=1,im - pt(i,j) = (pt(i,j)*wk1(i,j)+ub(i,j)) / delp(i,j) - enddo - enddo - -! Compute upwind biased kinetic energy at the four cell corners - -! Start using ub as v (CFL) on B-grid (cell corners) - do j=js2g0,jn1g1 ! ub needed on N - ub(1,j) = dtdy5*(vc(1,j) + vc(im,j)) - do i=2,im - ub(i,j) = dtdy5*(vc(i,j) + vc(i-1,j)) - enddo - enddo - - call ytp(im, jm, fy(1,jfirst), v(1,jfirst-ng_d), ub(1,jfirst), & - ub(1,jfirst), ng_d, jord, 1, jfirst, jlast) -! End using ub as v (CFL) on B-grid - - do j=js2g0,jn1g1 ! ub needed on N - do i=1,im - ub(i,j) = dtxe5(j)*(uc(i,j) + uc(i,j-1)) -! uc will be used as wrok array after this point - enddo - enddo - - do j=js2g0,jn1g1 ! wk1 needed on N - sldv(j) = .false. - if( cose(j) < zt_d ) then - do i=1,im - if( abs(ub(i,j)) > D1_0 ) then ! ub ghosted on N - sldv(j) = .true. -#if ( !defined UNICOSMP ) || ( !defined NEC_SX ) - exit -#endif - endif - enddo - endif - enddo - - call xtpv(im, sldv, fxjv, u, ub, iord, ub, cose, & - 0, slope, qtmpv, al, ar, a6, & - jfirst, jlast, js2g0, jn1g1, jm, & - jfirst-1, jn1g1, jfirst-1, jn1g1, & - jfirst-ng_d, jlast+ng_s, jfirst, jlast+1, & - jfirst, jlast+1, jfirst-1, jn1g1) - - do j=js2g0,jn1g1 ! wk1 needed on N - do i=1,im - wk1(i,j) = txe5(j)*fxjv(i,j) + tdy5*fy(i,j) ! fy ghosted on N - enddo - enddo - -! Add divergence damping to vector invariant form of the momentum eqn -! (absolute vorticity is damped by ffsl scheme, therefore divergence damping -! provides more consistent dissipation to divergent part of the flow) - -!-------------------------- -! Perform divergence damping -!-------------------------- - - do j=max(2,jfirst-1), jn2g1 ! fy need on NS (below) - do i=1,im - fy(i,j) = v(i,j)*cosp(j) ! v ghosted on NS at least - enddo - enddo - - do j=js2g0,jn1g1 -! i=1 - uc(1,j) = u(im,j) - u(1,j) ! u ghosted on N at least - do i=2,im - uc(i,j) = u(i-1,j) - u(i,j) - enddo - enddo - - if ( jfirst == 1 ) then -! j=2 - do i=1,im - wk1(i,2) = wk1(i,2) - cdy(2)*fy(i, 2) + cdx(2)*uc(i,2) - enddo - endif - - do j=max(3,jfirst),jn2g1 ! wk1 needed on N (after TP2D) - do i=1,im - wk1(i,j) = wk1(i,j) + cdy(j)*(fy(i,j-1) - fy(i,j)) & - + cdx(j)*uc(i,j) - enddo - enddo - - if ( jlast == jm ) then - do i=1,im - wk1(i,jm) = wk1(i,jm) + cdy(jm)*fy(i,jm-1) + cdx(jm)*uc(i,jm) - enddo - endif -!------------------------------------ -! End divergence damping computation -!------------------------------------ - - -! Compute Vorticity on the D grid -! delpf used as work array - - do j=js2gd,jn1gd - do i=1,im - delpf(i,j) = u(i,j)*cose(j) ! u ghosted on N*ng S*ng - enddo - enddo - - - if ( jfirst-ng_d <= 1 ) then - c1 = D0_0 - do i=1,im - c1 = c1 + delpf(i,2) - end do - c1 = -c1*rdy*rcap - - do i=1,im - uc(i,1) = c1 - enddo - endif - - if ( jlast+ng_d >= jm ) then - c2 = D0_0 - do i=1,im - c2 = c2 + delpf(i,jm) - end do - c2 = c2*rdy*rcap - - do i=1,im - uc(i,jm) = c2 - enddo - else - -! This is an attempt to avoid ghosting u on N*(ng+1) - do i=1,im -! DEBUG -! uc(i,jn2gd) = 0.0 -! testing - uc(i,jn2gd) = D1E30 - enddo - endif - - do j=js2gd, min(jm-1,jlast+ng_d-1) - do i=1,im-1 - uc(i,j) = ( delpf(i,j) - delpf(i,j+1)) * cy(j) + & - (v(i+1,j) - v(i,j)) * rdx(j) - enddo - uc(im,j) = (delpf(im,j) - delpf(im,j+1)) * cy(j) + & - (v(1,j) - v(im,j)) * rdx(j) - enddo - -! uc is relative vorticity at this point - - do j=max(1,jfirst-ng_d), jn1gd - do i=1,im - uc(i,j) = uc(i,j) + f0(j) -! uc is absolute vorticity - enddo - enddo - - call tp2d(va(1,jfirst), uc(1,jfirst-ng_d), crx(1,jfirst-ng_d), & - cry(1,jfirst), im, jm, iord, jord, ng_d, fx, & - fy(1,jfirst), ffsl, crx(1,jfirst), & - ymass, cosp, 0, jfirst, jlast) - - do j=js2g0,jlast - do i=1,im-1 - uc(i,j) = dtdxe(j)*(wk1(i,j)-wk1(i+1,j)) + dyce(j)*fy(i,j) - enddo - uc(im,j) = dtdxe(j)*(wk1(im,j)-wk1(1,j)) + dyce(j)*fy(im,j) - enddo - - do j=js2g0,jn2g0 - do i=1,im - vc(i,j) = dtdy*(wk1(i,j)-wk1(i,j+1)) - dx(j)*fx(i,j) - enddo - enddo - - end subroutine d_sw -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: d2a2c_winds --- Interpolate winds -! -! !INTERFACE: - subroutine d2a2c_winds(grid, u, v, ua, va, uc, vc, reset_winds, u_cen, v_cen) - - implicit none - -! !PARAMETERS: - type (T_FVDYCORE_GRID), intent(in) :: grid - - real(r8), intent(in ):: u(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_s) - real(r8), intent(inout):: v(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d) - real(r8), intent( out):: ua(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8), intent( out):: va(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d) - real(r8), intent( out):: uc(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8), intent( out):: vc(grid%im,grid%jfirst-2:grid%jlast+2 ) - -! cell centered winds - logical , intent(in):: reset_winds - real(r8), intent(in):: u_cen(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) - real(r8), intent(in):: v_cen(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d) - -! !DESCRIPTION: -! -! Calculate the cell-centered (A-grid) winds and the cell-wall perpendicular -! (C-grid) winds from the cell-wall parallel (D-grid) winds. -! -! This routine assumes that U and V have complete haloes! As a result, -! the A-grid and C-grid results should have complete haloes from +/- ng_c -! (which is generally smaller than ng_d). This feature has not been -! thoroughly tested. -! -! !REVISION HISTORY: -! WP 2007.06.01 Creation -! WS 2004.07.03 Added ProTeX documentation, removed unused vars. -! -!EOP -!----------------------------------------------------------------------- -!BOC - - real(r8) us, vs, un, vn - real(r8) uanp(grid%im), uasp(grid%im), vanp(grid%im), vasp(grid%im), r2im - - real(r8), pointer:: sinlon(:) - real(r8), pointer:: coslon(:) - real(r8), pointer:: sinl5(:) - real(r8), pointer:: cosl5(:) - - integer :: i, j, im2 - integer :: im, jm, jfirst, jlast, ng_s, ng_c, ng_d - integer :: js2gcp1, jn2gc, js2gc, jn1gc - - im = grid%im - jm = grid%jm - jfirst = grid%jfirst - jlast = grid%jlast - - ng_c = grid%ng_c - ng_d = grid%ng_d - ng_s = grid%ng_s - - im2 = im/2 - - js2gc = max(2,jfirst-ng_c) ! NG lats on S (starting at 2) - jn1gc = min(jm,jlast+ng_c) ! ng_c lats on N (ending at jm) - js2gcp1= max(2,jfirst-ng_c-1) ! NG-1 latitudes on S (starting at 2) - jn2gc = min(jm-1,jlast+ng_c) ! NG latitudes on N (ending at jm-1) - - sinlon => grid%sinlon - coslon => grid%coslon - sinl5 => grid%sinl5 - cosl5 => grid%cosl5 - -! Get D-grid V-wind at the poles. - - r2im = 0.5_r16/real(im,r16) - - if ( jfirst-ng_d <= 1 ) then - -! -! Treat SP -! - do i=1,im-1 - uasp(i) = u(i,2) + u(i,3) - vasp(i) = v(i,2) + v(i+1,2) - enddo - - uasp(im) = u(im,2) + u(im,3) - vasp(im) = v(im,2) + v(1,2) - -! Projection at SP - - us = D0_0 - vs = D0_0 - - do i=1,im2 - us = us + (uasp(i+im2)-uasp(i))*sinlon(i) & - + (vasp(i)-vasp(i+im2))*coslon(i) - vs = vs + (uasp(i+im2)-uasp(i))*coslon(i) & - + (vasp(i+im2)-vasp(i))*sinlon(i) - enddo - us = us*r2im - vs = vs*r2im - -! get V-wind at SP - - do i=1,im2 - v(i, 1) = us*cosl5(i) - vs*sinl5(i) - v(i+im2,1) = -v(i, 1) - enddo - - endif - - if ( jlast+ng_d >= jm ) then - -! -! Treat NP -! - do i=1,im-1 - uanp(i) = u(i,jm-1) + u(i,jm) - vanp(i) = v(i,jm-1) + v(i+1,jm-1) - enddo - - uanp(im) = u(im,jm-1) + u(im,jm) - vanp(im) = v(im,jm-1) + v(1,jm-1) - -! Projection at NP - - un = D0_0 - vn = D0_0 - do i=1,im2 - un = un + (uanp(i+im2)-uanp(i))*sinlon(i) & - + (vanp(i+im2)-vanp(i))*coslon(i) - vn = vn + (uanp(i)-uanp(i+im2))*coslon(i) & - + (vanp(i+im2)-vanp(i))*sinlon(i) - enddo - un = un*r2im - vn = vn*r2im - -! get V-wind at NP - - do i=1,im2 - v(i,jm) = -un*cosl5(i) - vn*sinl5(i) - v(i+im2,jm) = -v(i,jm) - enddo - - endif - - do j=js2gcp1,jn2gc - do i=1,im-1 - va(i,j) = v(i,j) + v(i+1,j) - enddo - va(im,j) = v(im,j) + v(1,j) - enddo - - do j=js2gc,jn2gc - do i=1,im - ua(i,j) = u(i,j) + u(i,j+1) - enddo - enddo - -! -! reset cell center winds to the offline meteorlogy data -! - - if (reset_winds) then - ua(:,:) = D2_0*u_cen(:,:) - va(:,:) = D2_0*v_cen(:,:) - endif - - if ( jfirst-ng_d <= 1 ) then -! Projection at SP - if ( .not. reset_winds ) then - us = D0_0 - vs = D0_0 - - do i=1,im2 - us = us + (ua(i+im2,2)-ua(i ,2))*sinlon(i) & - + (va(i ,2)-va(i+im2,2))*coslon(i) - vs = vs + (ua(i+im2,2)-ua(i ,2))*coslon(i) & - + (va(i+im2,2)-va(i ,2))*sinlon(i) - enddo - - us = us/im - vs = vs/im - - ! SP - do i=1,im2 - ua(i,1) = -us*sinlon(i) - vs*coslon(i) - va(i,1) = us*coslon(i) - vs*sinlon(i) - ua(i+im2,1) = -ua(i,1) - va(i+im2,1) = -va(i,1) - enddo - endif - - endif - - if ( jlast+ng_d >= jm ) then - -! Projection at NP - if ( .not. reset_winds ) then - un = D0_0 - vn = D0_0 - - j = jm-1 - do i=1,im2 - un = un + (ua(i+im2,j)-ua(i ,j))*sinlon(i) & - + (va(i+im2,j)-va(i ,j))*coslon(i) - vn = vn + (ua(i ,j)-ua(i+im2,j))*coslon(i) & - + (va(i+im2,j)-va(i ,j))*sinlon(i) - enddo - - un = un/im - vn = vn/im - - ! NP - do i=1,im2 - ua(i,jm) = -un*sinlon(i) + vn*coslon(i) - va(i,jm) = -un*coslon(i) - vn*sinlon(i) - ua(i+im2,jm) = -ua(i,jm) - va(i+im2,jm) = -va(i,jm) - enddo - endif - - endif - -! A -> C - do j=js2gc,jn2gc ! uc needed N*ng S*ng -! i=1 - uc(1,j) = D0_25*(ua(1,j)+ua(im,j)) - - - do i=2,im - - uc(i,j) = D0_25*(ua(i,j)+ua(i-1,j)) - enddo - enddo - - do j=js2gc,jn1gc ! vc needed N*ng, S*ng (for ycc) - do i=1,im - vc(i,j) = D0_25*(va(i,j)+va(i,j-1)) ! va needed N*ng S*(ng+1) - enddo - enddo -!EOC - end subroutine d2a2c_winds -!----------------------------------------------------------------------- - - - end module sw_core diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/te_map.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/te_map.F90 deleted file mode 100644 index 3f88dfe36..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/te_map.F90 +++ /dev/null @@ -1,1213 +0,0 @@ -#define DGRID - -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: te_map --- Map vertical Lagrangian coordinates to normal grid -! -! !INTERFACE: - - subroutine te_map(grid, consv, convt, ps, oma, & - pe, delp, pkz, pk, mdt, & - nx, u, v, pt, tracer, & - hs, cp, akap, kord, peln, & - te0, te, dz, mfx, mfy, & - te_method, dthconsv, dtmp ) -! -! !USES: - - use shr_kind_mod, only : r8 => shr_kind_r8 - use dynamics_vars, only : T_FVDYCORE_GRID, T_TRACERS - use mapz_module, only : map1_cubic_te, map1_ppm, mapn_ppm_tracer - -#if defined( SPMD ) - use parutilitiesmodule, only: sumop, bcstop, parcollective - use mod_comm, only: commglobal, mp_send3d, mp_recv3d -#endif - - implicit none - -#if defined( SPMD ) -#define CPP_PRT_PREFIX if(grid%iam==0) -#else -#define CPP_PRT_PREFIX -#endif - -! !INPUT PARAMETERS: - type (T_FVDYCORE_GRID), intent(inout) :: grid ! grid for XY decomp - logical consv ! flag to force TE conservation - logical convt ! flag to control pt output (see below) - integer mdt ! mapping time step (same as phys) - integer nx ! number of SMP "decomposition" in x - real(r8) hs(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) ! surface geopotential - real(r8) cp - real(r8) te0 - integer, intent(in) :: te_method ! Method for vertical total energy remapping - ! 0 : piecewise-parabolic - ! 1 : cubic interpolation - -! !INPUT/OUTPUT PARAMETERS: - real(r8) pk(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km+1) ! pe to the kappa - real(r8) u(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! u-wind (m/s) - real(r8) v(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! v-wind (m/s) -! tracers including specific humidity - type (t_tracers), intent(inout) :: tracer(grid%ntotq) ! Array of pointers to individual tracers - real(r8) pe(grid%ifirstxy:grid%ilastxy,grid%km+1,grid%jfirstxy:grid%jlastxy) ! pressure at layer edges - real(r8) ps(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) ! surface pressure - real(r8) pt(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! virtual potential temperature as input - ! Output: virtual temperature if convt is true - ! false: output is (virtual) potential temperature - real(r8) te(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! Work array (cache performance) - real(r8) dz(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! Work array (cache performance) - real(r8) mfx(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - real(r8) mfy(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) - -! !OUTPUT PARAMETERS: - real(r8) delp(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! pressure thickness - real(r8) oma (grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! vertical press. velocity (pascal/sec) - real(r8) peln(grid%ifirstxy:grid%ilastxy,grid%km+1,grid%jfirstxy:grid%jlastxy) ! log(pe) - real(r8) pkz(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! layer-mean pk for converting t to pt - - real(r8) dthconsv(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! THV Increment due to Consv=TRUE - -! !DESCRIPTION: -! -! !REVISION HISTORY: -! -! WS 99.05.19 : Replaced IMR, JMR, JNP and NL with IM, JM-1, JM and KM -! WS 99.05.25 : Revised conversions with IMR and JMR; removed fvcore.h -! WS 99.07.29 : Reduced computation region to grid%jfirstxy:jlast -! WS 99.07.30 : Tested concept with message concatenation of te_map calls -! WS 99.10.01 : Documentation; indentation; cleaning -! SJL 99.12.31: SMP "decomposition" in-E-W direction -! WS 00.05.14 : Renamed ghost indices as per Kevin's definitions -! WS 00.07.13 : Changed PILGRIM API -! AM 00.08.29 : Variables in this routine will ultimately be decomposed in (i,j). -! AM 01.06.13 : 2-D decomposition; reordering summation causes roundoff difference. -! WS 01.06.10 : Removed "if(first)" section in favor of a variable module -! AM 01.06.27 : Merged yz decomposition technology into ccm code. -! WS 02.01.14 : Upgraded to mod_comm -! WS 02.04.22 : Use mapz_module from FVGCM -! WS 02.04.25 : New mod_comm interfaces -! WS 03.08.12 : Introduced unorth -! WS 03.11.19 : Merged in CAM changes by Mirin -! WS 03.12.03 : Added GRID as argument, dynamics_vars removed -! WS 04.08.25 : Simplified interface by using GRID -! WS 04.10.07 : Removed dependency on spmd_dyn; info now in GRID -! WS 05.03.25 : Changed tracer to type T_TRACERS -! WS 05.04.12 : Call mapn_ppm_tracer instead of mapn_ppm -! AT 05.05.11 : Merged with the version Cerebus (unique pole issues) -! WS 05.05.18 : Merged CAM and GEOS5 versions (mostly GEOS5) -! LT 05.11.14 : Call map1_cubic_te for Cubic Interpolation of Total Energy -! WP 06.01.18 : Added calls to map1_ppm for horizontal mass fluxes -! LT 06.02.08 : Implement code for partial remapping option -! WS 06.11.29 : Merge CAM/GEOS5; magic numbers isolated; te_method -! LT 06.12.13 : Compute A-Grid Kinetic Energy -! CC 07.01.29 : Additions for proper calculation of OMGA -! LT 07.06.04 : Removed OMEGA calculations (moved to FV_Wrapper) except for remapping -! WS 09.04.01 : Upgraded to PILGRIM from cam3_6_33 -! -!EOP -!----------------------------------------------------------------------- -!BOC -! !LOCAL VARIABLES: - -! Magic numbers used in this module - real(r8), parameter :: D0_0 = 0.0_r8 - real(r8), parameter :: D0_125 = 0.125_r8 - real(r8), parameter :: D0_25 = 0.25_r8 - real(r8), parameter :: D0_5 = 0.5_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D2_0 = 2.0_r8 - real(r8), parameter :: D10_0 = 10.0_r8 - real(r8), parameter :: D1E4 = 1.0e4_r8 - - integer :: im, jm, km ! x, y, z dimensions - integer :: nq ! number of tracers to be advected - integer :: ntotq ! Total number of tracers - integer :: ifirst, ilast ! starting & ending longitude index - integer :: jfirst, jlast ! starting & ending latitude index - integer :: myidxy_y, iam - integer :: nprxy_x, nprxy_y - -! Local variables for Partial Remapping -! ------------------------------------- - real(r8) :: pref(grid%km+1) - real(r8) :: fac(grid%km+1) - real(r8) :: zz(grid%km+1) - real(r8) :: z1,z2 - - real(r8), parameter :: alf = 0.042_r8 - real(r8), parameter :: pa = 1.0_r8 - real(r8), parameter :: pb = 500.0_r8 - real(r8), parameter :: psurf = 100001.0_r8 - real(r8), parameter :: bet = D2_0*alf/(D1_0+alf) - -! Local arrays: -! ------------- - real(r8) rmin(nx*grid%jm), rmax(nx*grid%jm) - real(r8) tte(grid%jm) -! x-y - real(r8) u2(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy+1) - real(r8) v2(grid%ifirstxy:grid%ilastxy+1,grid%jfirstxy:grid%jlastxy) - real(r8) t2(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) - real(r8) veast(grid%jfirstxy:grid%jlastxy,grid%km) -! y-z - real(r8) pe0(grid%ifirstxy:grid%ilastxy,grid%km+1) - real(r8) pe1(grid%ifirstxy:grid%ilastxy,grid%km+1) - real(r8) pe2(grid%ifirstxy:grid%ilastxy,grid%km+1) - real(r8) pe3(grid%ifirstxy:grid%ilastxy,grid%km+1) - real(r8) phis(grid%ifirstxy:grid%ilastxy,grid%km+1) - real(r8) u2_sp(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) v2_sp(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) t2_sp(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) u2_np(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) v2_np(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) t2_np(grid%ifirstxy:grid%ilastxy,grid%km) - -! x - real(r8) gz(grid%ifirstxy:grid%ilastxy) - real(r8) ratio(grid%ifirstxy:grid%ilastxy) - real(r8) bte(grid%ifirstxy:grid%ilastxy) -! z - real(r8) pe1w(grid%km+1) - real(r8) pe2w(grid%km+1) - - integer i1w, nxu - integer i, j, k, js2g0, jn2g0, jn1g1 - integer kord - integer krd - - real(r8) akap, dak, bkh, qmax, qmin - real(r8) te_sp(grid%km), te_np(grid%km) - real(r8) xysum(grid%jfirstxy:grid%jlastxy,2) - real(r8) tmpik(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) tmpij(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,2) - real(r8) omga_ik(grid%ifirstxy:grid%ilastxy,grid%km) ! vertical press. velocity (tmp 2-d array) - real(r8) dtmp - real(r8) sum - real(r8) rdt5 - real(r8) rg - real(r8) te1 - real(r8) dlnp - real(r8) tvm - - integer ixj, jp, it, i1, i2 - -#if defined( SPMD ) - integer :: dest, src - real(r8) unorth(grid%ifirstxy:grid%ilastxy,grid%km) - real(r8) pewest(grid%km+1,grid%jfirstxy:grid%jlastxy) - real(r8), allocatable :: pesouth(:,:) -#endif - - integer comm_use, npry_use, itot - - logical diag - - data diag /.false./ - - z1 = log(pa/psurf) - z2 = log(pb/psurf) - - im = grid%im - jm = grid%jm - km = grid%km - nq = grid%nq - - ifirst = grid%ifirstxy - ilast = grid%ilastxy - jfirst = grid%jfirstxy - jlast = grid%jlastxy - - iam = grid%iam - myidxy_y = grid%myidxy_y - nprxy_x = grid%nprxy_x - nprxy_y = grid%nprxy_y - -! Intialize PREF and FAC for Partial Remapping (above 100-mb) -! ----------------------------------------------------------- - do k=1,km+1 - pref(k) = grid%ak(k) + grid%bk(k)*psurf - enddo - zz = log( pref/psurf ) - zz = D10_0*(zz-z2)/z1 - zz = (D1_0-bet)*tanh(zz) - do k=1,km+1 -! if( pref(k).le.D1E4 ) then -! fac(k) = (D1_0-zz(k))/(D2_0-bet) -! else - fac(k) = D1_0 -! endif - enddo - -! WS 99.07.27 : Set loop limits appropriately -! -------------------------------------------- - js2g0 = max(2,jfirst) - jn1g1 = min(jm,jlast+1) - jn2g0 = min(jm-1,jlast) - do j=jfirst,jlast - xysum(j,1) = D0_0 - xysum(j,2) = D0_0 - enddo - do j=jfirst,jlast - do i=ifirst,ilast - tmpij(i,j,1) = D0_0 - tmpij(i,j,2) = D0_0 - enddo - enddo - do k=1,km - do i=ifirst,ilast - tmpik(i,k) = D0_0 - enddo - enddo - - itot = ilast-ifirst+1 - nxu = 1 - if (itot == im) nxu = nx - -#if defined( SPMD ) - comm_use = grid%commxy_y - npry_use = nprxy_y - - call mp_send3d( commglobal, iam-nprxy_x, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jfirst, jfirst, 1, km, u ) -! Nontrivial x decomposition - if (itot /= im) then - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1,km, & - ifirst, ifirst, jfirst, jlast, 1, km, v ) - endif -#endif - call pkez(nxu, im, km, jfirst, jlast, 1, km, ifirst, ilast, & - pe, pk, akap, grid%ks, peln, pkz, .false.) - -! Single subdomain case (periodic) - do k=1,km - do j=jfirst,jlast - veast(j,k) = v(ifirst,j,k) - enddo - enddo -#if defined( SPMD ) - call mp_recv3d( commglobal, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, unorth ) -! Nontrivial x decomposition - if (itot /= im) then - call mp_recv3d( commglobal, src, im, jm, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, veast ) - dest = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, km+1, jm, & - ifirst, ilast, 1, km+1, jfirst, jlast, & - ilast, ilast, 1, km+1, jfirst, jlast, pe ) - endif - call mp_send3d( commglobal, iam+nprxy_x, iam-nprxy_x, im, km+1, jm,& - ifirst, ilast, 1, km+1, jfirst, jlast, & - ifirst, ilast, 1, km+1, jlast, jlast, pe ) -#endif - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,j, k, u2, v2, t2) - -! Compute cp*T + KE - - do 1000 k=1,km - - do j=js2g0,jlast - do i=ifirst,ilast -#ifdef DGRID - u2(i,j) = u(i,j,k)**2 ! D-Grid KE -#else - u2(i,j) = u(i,j,k) ! A-Grid KE -#endif - enddo - enddo -#if defined( SPMD ) - if ( jlast < jm ) then - do i=ifirst,ilast -#ifdef DGRID - u2(i,jlast+1) = unorth(i,k)**2 ! fill ghost zone -#else - u2(i,jlast+1) = unorth(i,k) ! fill ghost zone -#endif - enddo - endif -#endif - - do j=js2g0,jn2g0 - do i=ifirst,ilast -#ifdef DGRID - v2(i,j) = v(i,j,k)**2 -#else - v2(i,j) = v(i,j,k) -#endif - enddo -#ifdef DGRID - v2(ilast+1,j) = veast(j,k)**2 -#else - v2(ilast+1,j) = veast(j,k) -#endif - enddo - - do j=jfirst,jlast - do i=ifirst,ilast - t2(i,j) = cp*pt(i,j,k) - enddo - enddo - - do j=js2g0,jn2g0 - do i=ifirst,ilast -#ifdef DGRID - te(i,j,k) = D0_25 * ( u2(i,j) + u2(i,j+1) & - + v2(i,j) + v2(i+1,j) ) & - + t2(i,j)*pkz(i,j,k) -#else - te(i,j,k) = D0_125*( (u2(i,j)+u2(i,j+1))**2 & - + (v2(i,j)+v2(i+1,j))**2 ) & - + t2(i,j)*pkz(i,j,k) -#endif - enddo - enddo - -! WS 99.07.29 : Restructuring creates small round-off. Not clear why... - -! Do collective Mpisum (in i) for te_sp and te_np below (AAM) -! - if ( jfirst == 1 ) then -! South pole - do i=ifirst,ilast -#ifdef DGRID - u2_sp(i,k) = u2(i,2) - v2_sp(i,k) = v2(i,2) -#else - u2_sp(i,k) = u2(i,2)**2 - v2_sp(i,k) = v2(i,2)**2 -#endif - t2_sp(i,k) = t2(i,1) - enddo - endif - - if ( jlast == jm ) then -! North pole - do i=ifirst,ilast -#ifdef DGRID - u2_np(i,k) = u2(i,jm ) - v2_np(i,k) = v2(i,jm-1) -#else - u2_np(i,k) = u2(i,jm )**2 - v2_np(i,k) = v2(i,jm-1)**2 -#endif - t2_np(i,k) = t2(i,jm) - enddo - endif - -! Compute dz; geo-potential increments - do j=jfirst,jlast - do i=ifirst,ilast - dz(i,j,k) = t2(i,j)*(pk(i,j,k+1)-pk(i,j,k)) - enddo - enddo -1000 continue - -#if defined( SPMD ) - allocate( pesouth(ifirst:ilast,km+1) ) - if (itot /= im) then - call mp_recv3d( commglobal, src, im, km+1, jm, & - ifirst-1, ifirst-1, 1, km+1, jfirst, jlast, & - ifirst-1, ifirst-1, 1, km+1, jfirst, jlast, pewest ) - endif - call mp_recv3d( commglobal, iam-nprxy_x, im, km+1, jm, & - ifirst, ilast, 1, km+1, jfirst-1, jfirst-1, & - ifirst, ilast, 1, km+1, jfirst-1, jfirst-1, pesouth ) -#endif - - if ( jfirst == 1 ) then - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, k) - - do k = 1, km - te_sp(k) = D0_0 - do i=ifirst,ilast - tmpik(i,k) = D0_5*( u2_sp(i,k) + v2_sp(i,k) ) + t2_sp(i,k)*pkz(i,1,k) - enddo - enddo - - call par_xsum( grid, tmpik, km, te_sp) - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, k) - - do k = 1, km - te_sp(k) = te_sp(k)/real(im,r8) - do i=ifirst,ilast - te(i, 1,k) = te_sp(k) - enddo - enddo - endif - - if ( jlast == jm ) then - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, k) - - do k = 1, km - te_np(k) = D0_0 - do i=ifirst,ilast - tmpik(i,k) = D0_5*( u2_np(i,k) + v2_np(i,k) ) + t2_np(i,k)*pkz(i,jm,k) - enddo - enddo - - call par_xsum( grid, tmpik, km, te_np) - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, k) - - do k = 1, km - te_np(k) = te_np(k)/real(im,r8) - do i=ifirst,ilast - te(i,jm,k) = te_np(k) - enddo - enddo - endif - - it = itot / nxu - jp = nxu * ( jlast - jfirst + 1 ) - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,j,k,i1w,pe0,pe1,pe2,pe3,ratio) & -!$omp private(dak,bkh,rdt5,phis,krd, ixj,i1,i2) & -!$omp private(pe1w, pe2w, omga_ik ) - -! do 2000 j=jfirst,jlast - do 2000 ixj=1,jp - - j = jfirst + (ixj-1) / nxu - i1 = ifirst + it * mod(ixj-1, nxu) - i2 = i1 + it - 1 - -! Copy data to local 2D arrays. - i1w = i1-1 - if (i1 == 1) i1w = im - do k=1,km+1 - do i=i1,i2 - pe1(i,k) = pe(i,k,j) - enddo - if( itot == im ) then - pe1w(k) = pe(i1w,k,j) -#if defined( SPMD ) - else - pe1w(k) = pewest(k,j) -#endif - endif - enddo - - do k=1,grid%ks+1 - do i=i1,i2 - pe0(i,k) = grid%ak(k) - pe2(i,k) = grid%ak(k) - pe3(i,k) = grid%ak(k) - enddo - enddo - - do k=grid%ks+2,km - do i=i1,i2 - pe0(i,k) = grid%ak(k) + grid%bk(k)* ps(i,j) ! Remapped PLE based on Old PS - pe2(i,k) = grid%ak(k) + grid%bk(k)*pe1(i,km+1) ! Remapped PLE based on Updated PS - enddo - enddo - - do i=i1,i2 - pe0(i,km+1) = ps(i,j) - pe2(i,km+1) = pe1(i,km+1) - enddo - -! Ghosting for v mapping - do k=grid%ks+2,km - pe2w(k) = grid%ak(k) + grid%bk(k)*pe1w(km+1) - enddo - pe2w(km+1) = pe1w(km+1) - -! update ps -! --------- - do i=i1,i2 - ps(i,j) = pe1(i,km+1) - enddo - -! Compute GeoPotential Heights and add to Total Energy -! Note: GeoPotential Height(L) => d(Pe*PHI)/dPe -! ---------------------------------------------------- - - do i=i1,i2 - phis(i,km+1) = hs(i,j) - enddo - - do k=km,1,-1 - do i=i1,i2 - phis(i,k) = phis(i,k+1) + dz(i,j,k) - enddo - enddo - - do k=1,km+1 - do i=i1,i2 - phis(i,k) = phis(i,k) * pe1(i,k) - enddo - enddo - - do k=1,km - do i=i1,i2 - te(i,j,k) = te(i,j,k) + (phis(i,k+1) - phis(i,k)) / & - (pe1(i,k+1) - pe1(i,k) ) - enddo - enddo - -! ####################################################################### -! # ReMap Total Energy -! ####################################################################### - -! Compute Target Pressures for Partial Remapping -! ---------------------------------------------- - do k=1,km+1 - do i=i1,i2 - pe2(i,k) = fac(k)*pe2(i,k) + (D1_0-fac(k))*pe1(i,k) - enddo - enddo - -! Update Delta-Pressure (from final remapped pressures) -! ----------------------------------------------------- - do k=1,km - do i=i1,i2 - delp(i,j,k) = pe2(i,k+1) - pe2(i,k) - enddo - enddo - -! ReMap Total Energy -! ------------------ - select case ( te_method ) - case (0) - call map1_ppm ( km, pe1, te, & - km, pe2, te, 0, 0, & - itot, i1-ifirst+1, i2-ifirst+1, & - j, jfirst, jlast, 1, kord) - case (1) - call map1_cubic_te ( km, pe1, te, & - km, pe2, te, 0, 0, & - itot, i1-ifirst+1, i2-ifirst+1, & - j, jfirst, jlast, 1, kord) - case default - call map1_ppm ( km, pe1, te, & - km, pe2, te, 0, 0, & - itot, i1-ifirst+1, i2-ifirst+1, & - j, jfirst, jlast, 1, kord) - endselect - -! ReMap Omega -! ----------- - do k=1,km - do i=i1,i2 - omga_ik(i,k) = oma(i,j,k) - end do - end do - call map1_ppm ( km, pe1, omga_ik, & - km, pe2, omga_ik, 0, 0, & - itot, i1-ifirst+1, i2-ifirst+1, & - 1, 1, 1, 1, kord) - do k=1,km - do i=i1,i2 - oma(i,j,k) = omga_ik(i,k) - end do - end do - -! ####################################################################### -! # ReMap Constituents -! ####################################################################### - - if( nq /= 0 ) then - if(kord == 8) then - krd = 8 - else - krd = 7 - endif - - call mapn_ppm_tracer ( km, pe1, tracer, nq, & - km, pe2, i1, i2, & - j, ifirst, ilast, jfirst, jlast, 0, krd) - endif - -! ####################################################################### -! # ReMap U-Wind -! ####################################################################### - - if(j /= 1) then - -! WS 99.07.29 : protect j==jfirst case - if (j > jfirst) then - do k=2,km+1 - do i=i1,i2 - pe0(i,k) = D0_5*(pe1(i,k)+pe(i,k,j-1)) - enddo - enddo - - do k=grid%ks+2,km+1 - bkh = D0_5*grid%bk(k) - do i=i1,i2 - pe3(i,k) = grid%ak(k) + bkh*(pe1(i,km+1)+pe(i,km+1,j-1)) - enddo - enddo - -#if defined( SPMD ) - else -! WS 99.10.01 : Read in pe(:,:,jfirst-1) from the pesouth buffer - do k=2,km+1 - do i=i1,i2 - pe0(i,k) = D0_5*(pe1(i,k)+pesouth(i,k)) - enddo - enddo - - do k=grid%ks+2,km+1 - bkh = D0_5*grid%bk(k) - do i=i1,i2 - pe3(i,k) = grid%ak(k) + bkh*(pe1(i,km+1)+pesouth(i,km+1)) - enddo - enddo -#endif - endif - - -! Compute Target Pressures for Partial Remapping -! ---------------------------------------------- - do k=1,km+1 - do i=i1,i2 - pe3(i,k) = fac(k)*pe3(i,k) + (D1_0-fac(k))*pe0(i,k) - enddo - enddo - -! ReMap U-Wind (D-Grid Location) -! ------------------------------ - call map1_ppm ( km, pe0, u, km, pe3, u, & - 0, 0, itot, i1-ifirst+1, i2-ifirst+1, & - j, jfirst, jlast, -1, kord) - - -! ReMap Y-Mass Flux (C-Grid Location) -! ----------------------------------- - do k=1,km - do i=i1,i2 - mfy(i,j,k) = mfy(i,j,k)/(pe0(i,k+1)-pe0(i,k)) - enddo - enddo - call map1_ppm ( km, pe0, mfy, km, pe3, mfy, & - 0, 0, itot, i1-ifirst+1, i2-ifirst+1, & - j, jfirst, jlast, -1, kord) - do k=1,km - do i=i1,i2 - mfy(i,j,k) = mfy(i,j,k)*(pe3(i,k+1)-pe3(i,k)) - enddo - enddo - endif - -! ####################################################################### -! # ReMap V-Wind -! ####################################################################### - - if(j /= 1 .and. j /= jm) then - do k=2,km+1 -! pe1(i1-1,1:km+1) must be ghosted - pe0(i1,k) = D0_5*(pe1(i1,k)+pe1w(k)) - do i=i1+1,i2 - pe0(i ,k) = D0_5*(pe1(i,k)+pe1(i-1,k)) - enddo - enddo - - do k=grid%ks+2,km+1 -! pe1(i1-1,grid%ks+2:km+1) must be ghosted - bkh = D0_5*grid%bk(k) - pe3(i1,k) = grid%ak(k) + bkh*(pe1(i1,km+1)+pe1w(km+1)) - do i=i1+1,i2 - pe3(i,k) = grid%ak(k) + bkh*(pe1(i,km+1)+pe1(i-1,km+1)) - enddo - enddo - -! Compute Target Pressures for Partial Remapping -! ---------------------------------------------- - do k=1,km+1 - do i=i1,i2 - pe3(i,k) = fac(k)*pe3(i,k) + (D1_0-fac(k))*pe0(i,k) - enddo - enddo - -! ReMap V-Wind (D-Grid Location) -! ------------------------------ - call map1_ppm ( km, pe0, v, km, pe3, v, & - 0, 0, itot, i1-ifirst+1, i2-ifirst+1, & - j, jfirst, jlast, -1, kord) - -! ReMap X-Mass Flux (C-Grid Location) -! ----------------------------------- - do k=1,km - do i=i1,i2 - mfx(i,j,k) = mfx(i,j,k)/(pe0(i,k+1)-pe0(i,k)) - enddo - enddo - call map1_ppm ( km, pe0, mfx, km, pe3, mfx, & - 0, 0, itot, i1-ifirst+1, i2-ifirst+1, & - j, jfirst, jlast, -1, kord) - do k=1,km - do i=i1,i2 - mfx(i,j,k) = mfx(i,j,k)*(pe3(i,k+1)-pe3(i,k)) - enddo - enddo - endif - -! Save new PE to temp storage peln -! -------------------------------- - do k=2,km - do i=i1,i2 - peln(i,k,j) = pe2(i,k) - enddo - enddo - -! Check deformation. - if( diag ) then - rmax(ixj) = D0_0 - rmin(ixj) = D1_0 - do k=1,km - do i=i1,i2 - ratio(i) = (pe1(i,k+1)-pe1(i,k)) / (pe2(i,k+1)-pe2(i,k)) - enddo - - do i=i1,i2 - if(ratio(i) > rmax(ixj)) then - rmax(ixj) = ratio(i) - elseif(ratio(i) < rmin(ixj)) then - rmin(ixj) = ratio(i) - endif - enddo - enddo - endif -2000 continue - - -#if defined( SPMD ) - deallocate( pesouth ) - -! Send u southward - call mp_send3d( commglobal, iam-nprxy_x, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ilast, jfirst, jfirst, 1, km, u ) - if (itot /= im) then - dest = myidxy_y*nprxy_x + MOD(iam+nprxy_x-1,nprxy_x) - src = myidxy_y*nprxy_x + MOD(iam+1,nprxy_x) - call mp_send3d( commglobal, dest, src, im, jm, km, & - ifirst, ilast, jfirst, jlast, 1, km, & - ifirst, ifirst, jfirst, jlast, 1, km, v ) - endif -#endif - - if( diag ) then - qmin = rmin(1) - do ixj=2, jp - if(rmin(ixj) < qmin) then - qmin = rmin(ixj) - endif - enddo - CPP_PRT_PREFIX write(6,*) 'rmin=', qmin - - qmax = rmax(1) - do ixj=2, jp - if(rmax(ixj) > qmax) then - qmax = rmax(ixj) - endif - enddo - CPP_PRT_PREFIX write(6,*) 'rmax=', qmax - endif - -! Recover Final Edge-Pressures and Compute Mid-Level PKZ -! ------------------------------------------------------ - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,j,k) - - do j=jfirst,jlast - do k=2,km - do i=ifirst,ilast - pe(i,k,j) = peln(i,k,j) - enddo - enddo - enddo - - do k=1,km+1 - do j=jfirst,jlast - do i=ifirst,ilast - pk(i,j,k) = pe(i,k,j)**akap - enddo - enddo - enddo - call pkez(nxu, im, km, jfirst, jlast, 1, km, ifirst, ilast, & - pe, pk, akap, grid%ks, peln, pkz, .false.) - -! Single x-subdomain case (periodic) - do k = 1, km - do j = jfirst, jlast - veast(j,k) = v(ifirst,j,k) - enddo - enddo - -#if defined( SPMD ) -! Recv u from north - call mp_recv3d( commglobal, iam+nprxy_x, im, jm, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, & - ifirst, ilast, jlast+1, jlast+1, 1, km, unorth ) - if (itot /= im) then - call mp_recv3d( commglobal, src, im, jm, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, & - ilast+1, ilast+1, jfirst, jlast, 1, km, veast ) - endif -#endif - -! ((((((((((((((((( compute globally integrated TE >>>>>>>>>>>>>>>> - - if( consv ) then - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,j,k) - - do k=1,km - do j=jfirst,jlast - do i=ifirst,ilast - dz(i,j,k) = te(i,j,k) * delp(i,j,k) - enddo - enddo - enddo - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,j,k,bte) - -! Perform vertical integration - - do 4000 j=jfirst,jlast - - if ( j == 1 ) then -! SP - tte(1) = D0_0 - - do k=1,km - tte(1) = tte(1) + dz(ifirst,1,k) - enddo - - elseif ( j == jm) then -! NP - tte(jm) = D0_0 - - do k=1,km - tte(jm) = tte(jm) + dz(ifirst,jm,k) - enddo - - else -! Interior - do i=ifirst,ilast - bte(i) = D0_0 - enddo - - do k=1,km - do i=ifirst,ilast - bte(i) = bte(i) + dz(i,j,k) - enddo - enddo - - xysum(j,1) = D0_0 - do i=ifirst,ilast - xysum(j,1) = xysum(j,1) + bte(i) - tmpij(i,j,1) = bte(i) - enddo - - endif -4000 continue - -#if defined (SPMD) - if (nprxy_x > 1) then - call par_xsum( grid, tmpij, jlast-jfirst+1, xysum) - endif -#endif - -!$omp parallel do & -!$omp default(shared) & -!$omp private(j) - - do j = max(jfirst,2), min(jlast,jm-1) - tte(j) = xysum(j,1)*grid%cosp(j) - enddo - - if ( jfirst == 1 ) tte(1) = grid%acap * tte(1) - if ( jlast == jm ) tte(jm) = grid%acap * tte(jm) - - te1 = D0_0 - call par_vecsum(jm, jfirst, jlast, tte, te1, comm_use, npry_use) - -!$omp parallel do & -!$omp& default(shared) & -!$omp& private(i,j) - - do j=js2g0, jn2g0 - xysum(j,1) = D0_0 - xysum(j,2) = D0_0 - do i=ifirst,ilast - xysum(j,1) = xysum(j,1) + ps(i,j) - xysum(j,2) = xysum(j,2) + peln(i,km+1,j) - tmpij(i,j,1) = ps(i,j) - tmpij(i,j,2) = peln(i,km+1,j) - enddo - enddo - -#if defined( SPMD ) - if (nprxy_x > 1) then - call par_xsum( grid, tmpij, 2*(jlast-jfirst+1), xysum) - endif -#endif - -!$omp parallel do & -!$omp default(shared) & -!$omp private(j) - - do j=js2g0, jn2g0 - tte(j) = cp*grid%cosp(j)*(xysum(j,1) - grid%ptop*real(im,r8) - & - akap*grid%ptop*(xysum(j,2) - peln(ifirst,1,j)*real(im,r8)) ) -! peln(i,1,j) should be independent of i (AAM) - enddo - - if ( jfirst == 1 ) tte(1) = grid%acap*cp * (ps(ifirst,1) - grid%ptop - & - akap*grid%ptop*(peln(ifirst,km+1,1) - peln(ifirst,1,1) ) ) - if ( jlast == jm ) tte(jm)= grid%acap*cp * (ps(ifirst,jm) - grid%ptop - & - akap*grid%ptop*(peln(ifirst,km+1,jm) - peln(ifirst,1,jm) ) ) - - sum=D0_0 - call par_vecsum(jm, jfirst, jlast, tte, sum, comm_use, npry_use) - - dtmp = (te0 - te1) / sum - -#if defined( SPMD ) -! Kludge to fix non-reproducibility on discover (LLT 6/4/2009) -! ------------------------------------------------------------ - call parcollective( commglobal,bcstop,dtmp ) -#endif - if( diag ) then - write(6,1001) grid%iam,te0,te1,sum,dtmp - 1001 format(1x,'IAM: ',i2,' TE0: ',g20.10,' TE1: ',g20.10,' sum: ',g20.10,' DelT: ',g20.10) - endif - - else - dtmp = D0_0 - endif ! end consv check - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i,j,k, u2, v2) - -! -------------------------------------------------------------------- -! --- Recover Tv from remapped Total Energy and its components --- -! -------------------------------------------------------------------- - - do 8000 k=1,km - -! Intialize Kinetic Energy -! ------------------------ - do j=js2g0,jlast - do i=ifirst,ilast -#ifdef DGRID - u2(i,j) = u(i,j,k)**2 -#else - u2(i,j) = u(i,j,k) -#endif - enddo - enddo -#if defined( SPMD ) - if ( jlast < jm ) then - do i=ifirst,ilast -#ifdef DGRID - u2(i,jlast+1) = unorth(i,k)**2 ! fill ghost zone -#else - u2(i,jlast+1) = unorth(i,k) ! fill ghost zone -#endif - enddo - endif -#endif - - do j=js2g0,jn2g0 - do i=ifirst,ilast -#ifdef DGRID - v2(i,j) = v(i,j,k)**2 -#else - v2(i,j) = v(i,j,k) -#endif - enddo -#ifdef DGRID - v2(ilast+1,j) = veast(j,k)**2 -#else - v2(ilast+1,j) = veast(j,k) -#endif - enddo - -! Subtract Kinetic Energy from Total Energy (Leaving Internal + Potential) -! ------------------------------------------------------------------------ - do j=js2g0,jn2g0 - do i=ifirst,ilast -#ifdef DGRID - te(i,j,k) = te(i,j,k) - D0_25 * ( u2(i,j) + u2(i,j+1) & - + v2(i,j) + v2(i+1,j) ) -#else - te(i,j,k) = te(i,j,k) - D0_125*( (u2(i,j)+u2(i,j+1))**2 & - + (v2(i,j)+v2(i+1,j))**2 ) -#endif - enddo - enddo - -! South pole -! ---------- - if ( jfirst == 1 ) then - do i=ifirst,ilast -#ifdef DGRID - u2_sp(i,k) = u2(i,2) - v2_sp(i,k) = v2(i,2) -#else - u2_sp(i,k) = u2(i,2)**2 - v2_sp(i,k) = v2(i,2)**2 -#endif - enddo - endif - -! North pole -! ---------- - if ( jlast == jm ) then - do i=ifirst,ilast -#ifdef DGRID - u2_np(i,k) = u2(i,jm ) - v2_np(i,k) = v2(i,jm-1) -#else - u2_np(i,k) = u2(i,jm )**2 - v2_np(i,k) = v2(i,jm-1)**2 -#endif - enddo - endif - -8000 continue - -! South pole -! ---------- - if ( jfirst == 1 ) then - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, k) - - do k = 1, km - te_sp(k) = D0_0 - do i=ifirst,ilast - tmpik(i,k) = D0_5*( u2_sp(i,k) + v2_sp(i,k) ) - enddo - enddo - - call par_xsum( grid, tmpik, km, te_sp) - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, k) - - do k = 1, km - te_sp(k) = te_sp(k)/real(im,r8) - do i=ifirst,ilast - te(i,1,k) = te(i,1,k) - te_sp(k) - enddo - enddo - endif - -! North pole -! ---------- - if ( jlast == jm ) then - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, k) - - do k = 1, km - te_np(k) = D0_0 - do i=ifirst,ilast - tmpik(i,k) = D0_5*( u2_np(i,k) + v2_np(i,k) ) - enddo - enddo - - call par_xsum( grid, tmpik, km, te_np) - -!$omp parallel do & -!$omp default(shared) & -!$omp private(i, k) - - do k = 1, km - te_np(k) = te_np(k)/real(im,r8) - do i=ifirst,ilast - te(i,jm,k) = te(i,jm,k) - te_np(k) - enddo - enddo - endif - -!$omp parallel do & -!$omp default(shared) & -!$omp private(ixj, i1, i2, i, j, k, rg, gz, tvm, dlnp) - -! Recover Tv from remapped Total Energy and its components -! -------------------------------------------------------- - do 9000 ixj=1,jp - - j = jfirst + (ixj-1) / nxu - i1 = ifirst + it * mod(ixj-1, nxu) - i2 = i1 + it - 1 - - rg = akap * cp - do i=i1,i2 - gz(i) = hs(i,j) ! Initialize GeoPotential Heights - enddo - - do k=km,1,-1 - do i=i1,i2 - dlnp = rg*(peln(i,k+1,j) - peln(i,k,j)) - tvm = delp(i,j,k)*(te(i,j,k) - gz(i)) / & - ( cp*delp(i,j,k) - pe(i,k,j)*dlnp ) - gz(i) = gz(i) + dlnp*tvm ! Update GeoPotential Heights - pt(i,j,k) = tvm ! pt is now (virtual) temperature - enddo - - if( consv ) then - do i=i1,i2 - pt(i,j,k) = pt(i,j,k) + dtmp - dthconsv(i,j,k) = dtmp/pkz(i,j,k) - enddo - else - do i=i1,i2 - dthconsv(i,j,k) = D0_0 - enddo - endif - - if( .not. convt ) then - do i=i1,i2 - pt(i,j,k) = pt(i,j,k) / pkz(i,j,k) ! Scaled Virtual Potential Temperature - enddo - endif - enddo ! end k-loop -9000 continue - - return -!EOC - end subroutine te_map -!----------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/tp_core.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/tp_core.F90 deleted file mode 100644 index 11704e6cd..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/tp_core.F90 +++ /dev/null @@ -1,2644 +0,0 @@ -#if defined( UNICOSMP ) || defined ( NEC_SX ) -#define VECTORIZE -#endif -module tp_core -!BOP -! -! !MODULE: tp_core --- Utilities for the transport core -! -! !USES: - use shr_kind_mod, only : r8 => shr_kind_r8 - -! -! !PUBLIC MEMBER FUNCTIONS: - public tp2c, tp2d, xtp, xtpv, fxppm, xmist, steepx, lmppm - public huynh, ytp, ymist, fyppm, tpcc, ycc -! -! !DESCRIPTION: -! -! This module provides -! -! \begin{tabular}{|l|l|} \hline \hline -! tp2c & \\ \hline -! tp2d & \\ \hline -! xtp & \\ \hline -! fxppm & \\ \hline -! xmist & \\ \hline -! steepx & \\ \hline -! lmppm & \\ \hline -! huynh & \\ \hline -! ytp & \\ \hline -! ymist & \\ \hline -! fyppm & \\ \hline -! tpcc & \\ \hline -! ycc & \\ \hline -! \hline -! \end{tabular} -! -! !REVISION HISTORY: -! 01.01.15 Lin Routines coalesced into this module -! 01.03.26 Sawyer Additional ProTeX documentation -! 03.11.19 Sawyer Merged in CAM changes by Mirin -! 04.10.07 Sawyer ompinner now from dynamics_vars -! 05.03.25 Todling shr_kind_r8 can only be referenced once (MIPSpro-7.4.2) -! 05.05.25 Sawyer Merged CAM and GEOS5 versions (mostly CAM) -! 06.09.06 Sawyer Turned "magic numbers" into F90 parameters -! -!EOP -!----------------------------------------------------------------------- - -! Magic numbers used in this module - - private - real(r8), parameter :: D0_0 = 0.0_r8 - real(r8), parameter :: D0_05 = 0.05_r8 - real(r8), parameter :: D0_25 = 0.25_r8 - real(r8), parameter :: D0_5 = 0.5_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D2_0 = 2.0_r8 - real(r8), parameter :: D3_0 = 3.0_r8 - real(r8), parameter :: D4_0 = 4.0_r8 - real(r8), parameter :: D8_0 = 8.0_r8 - real(r8), parameter :: D12_0 = 12.0_r8 - real(r8), parameter :: D24_0 = 24.0_r8 - -CONTAINS - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: tp2c --- Perform transport on a C grid -! -! !INTERFACE: - subroutine tp2c(dh, va, h, crx, cry, im, jm, & - iord, jord, ng, fx, fy, ffsl, & - rcap, acosp, xfx, yfx, cosp, id, jfirst, jlast) -!----------------------------------------------------------------------- - - implicit none - -! !INPUT PARAMETERS: - integer im, jm ! Dimensions - integer jfirst, jlast ! Latitude strip - integer iord, jord ! Interpolation order in x,y - integer ng ! Max. NS dependencies - integer id ! density (0) (mfx = C) - real (r8) rcap ! Ask S.-J. (polar constant?) - real (r8) acosp(jm) ! Ask S.-J. (difference to cosp??) - logical ffsl(jm) ! Use flux-form semi-Lagrangian trans.? - ! (N*NG S*NG) - real (r8) cosp(jm) ! Critical angle - real (r8) va(im,jfirst:jlast) ! Courant (unghosted) - real (r8) h(im,jfirst-ng:jlast+ng) ! Pressure ( N*NG S*NG ) - real (r8) crx(im,jfirst-ng:jlast+ng) ! Ask S.-J. ( N*NG S*NG ) - real (r8) cry(im,jfirst:jlast+1) ! Ask S.-J. ( N like FY ) - real (r8) xfx(im,jfirst:jlast) ! Ask S.-J. ( unghosted like FX ) - real (r8) yfx(im,jfirst:jlast+1) ! Ask S.-J. ( N like FY ) - -! !OUTPUT PARAMETERS: - real (r8) dh(im,jfirst:jlast) ! Ask S.-J. ( unghosted ) - real (r8) fx(im,jfirst:jlast) ! Flux in x ( unghosted ) - real (r8) fy(im,jfirst:jlast+1) ! Flux in y ( N, see tp2c ) - -! !DESCRIPTION: -! Perform transport on a C grid. The number of ghost -! latitudes (NG) depends on what method (JORD) will be used -! subsequentally. NG is equal to MIN(ABS(JORD),3). -! Ask S.-J. how exactly this differs from TP2C. -! -! !REVISION HISTORY: -! -!EOP -!----------------------------------------------------------------------- -!BOC - integer i, j, js2g0, jn2g0 - real (r8) sum1 - - js2g0 = max(2,jfirst) ! No ghosting - jn2g0 = min(jm-1,jlast) ! No ghosting - - fy = D0_0 - - call tp2d(va, h, crx, cry, im, jm, iord, jord, ng,fx, fy, ffsl, & - xfx, yfx, cosp, id, jfirst, jlast) - - do j=js2g0,jn2g0 - do i=1,im-1 - dh(i,j) = fx(i,j) - fx(i+1,j) + (fy(i,j)-fy(i,j+1))*acosp(j) - enddo - dh(im,j) = fx(im,j) - fx(1,j) + (fy(im,j)-fy(im,j+1))*acosp(j) - enddo - -! Poles - if ( jfirst == 1 ) then -! sum1 = - SUM( fy(1:im, 2) ) * rcap - sum1 = D0_0 - do i=1,im - sum1 = sum1 + fy(i,2) - enddo - sum1 = -sum1*rcap - do i=1,im - dh(i, 1) = sum1 - enddo - endif - - if ( jlast == jm ) then -! sum1 = SUM( fy(1:im,jm) ) * rcap - sum1 = D0_0 - do i=1,im - sum1 = sum1 + fy(i,jm) - enddo - sum1 = sum1*rcap - do i=1,im - dh(i,jm) = sum1 - enddo - endif - return -!EOC - end subroutine tp2c -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: tp2d --- Perform transport on a D grid -! -! !INTERFACE: - subroutine tp2d(va, q, crx, cry, im, jm, iord, jord, ng, fx, fy, & - ffsl, xfx, yfx, cosp, id, jfirst, jlast) -!----------------------------------------------------------------------- -! !USES: - - implicit none - -! !INPUT PARAMETERS: - integer im, jm ! Dimensions - integer jfirst, jlast ! Latitude strip - integer iord, jord ! Interpolation order in x,y - integer ng ! Max. NS dependencies - integer id ! density (0) (mfx = C) - ! mixing ratio (1) (mfx = mass flux) - logical ffsl(jm) ! Use flux-form semi-Lagrangian trans.? - ! ghosted N*ng S*ng - real (r8) cosp(jm) ! Critical angle - real (r8) va(im,jfirst:jlast) ! Courant (unghosted) - real (r8) q(im,jfirst-ng:jlast+ng) ! transported scalar ( N*NG S*NG ) - real (r8) crx(im,jfirst-ng:jlast+ng) ! Ask S.-J. ( N*NG S*NG ) - real (r8) cry(im,jfirst:jlast+1) ! Ask S.-J. ( N like FY ) - real (r8) xfx(im,jfirst:jlast) ! Ask S.-J. ( unghosted like FX ) - real (r8) yfx(im,jfirst:jlast+1) ! Ask S.-J. ( N like FY ) - -! !OUTPUT PARAMETERS: - real (r8) fx(im,jfirst:jlast) ! Flux in x ( unghosted ) - real (r8) fy(im,jfirst:jlast+1) ! Flux in y ( N, see tp2c ) - -! !DESCRIPTION: -! Perform transport on a D grid. The number of ghost -! latitudes (NG) depends on what method (JORD) will be used -! subsequentally. NG is equal to MIN(ABS(JORD),3). -! -! -! !REVISION HISTORY: -! WS 99.04.13: Added jfirst:jlast concept -! 99.04.21: Removed j1 and j2 (j1=2, j2=jm-1 consistently) -! 99.04.27: Removed dc, wk2 as arguments (local to YTP) -! 99.04.27: Removed adx as arguments (local here) -! SJL 99.07.26: ffsl flag added -! WS 99.09.07: Restructuring, cleaning, documentation -! WS 99.10.22: NG now argument; arrays pruned -! WS 00.05.14: Renamed ghost indices as per Kevin's definitions -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! Local: - integer i, j, iad, jp, js2g0, js2gng, jn2g0, jn2gng - real (r8) adx(im,jfirst-ng:jlast+ng) - real (r8) wk1v(im,jfirst-ng:jlast+ng) - real (r8) dm(-im/3:im+im/3) - real (r8) qtmpv(-im/3:im+im/3,jfirst-ng:jlast+ng) - real (r8) al(-im/3:im+im/3) - real (r8) ar(-im/3:im+im/3) - real (r8) a6(-im/3:im+im/3) - -! Number of ghost latitudes - js2g0 = max(2,jfirst) ! No ghosting - js2gng = max(2,jfirst-ng) ! Number needed on S - jn2g0 = min(jm-1,jlast) ! No ghosting - jn2gng = min(jm-1,jlast+ng) ! Number needed on N - iad = 1 - - fy = D0_0 - - call xtpv(im, ffsl, wk1v, q, crx, iad, crx, & - cosp, 0, dm, qtmpv, al, ar, a6, & - jfirst, jlast, js2gng, jn2gng, jm, & - 1, jm, jfirst-ng, jlast+ng, & - jfirst-ng, jlast+ng, jfirst-ng, jlast+ng, & - jfirst-ng, jlast+ng, jfirst-ng, jlast+ng) - - do j=js2gng,jn2gng ! adx needed on N*ng S*ng - - do i=1,im-1 - adx(i,j) = q(i,j) + D0_5 * & - (wk1v(i,j)-wk1v(i+1,j) + q(i,j)*(crx(i+1,j)-crx(i,j))) - enddo - adx(im,j) = q(im,j) + D0_5 * & - (wk1v(im,j)-wk1v(1,j) + q(im,j)*(crx(1,j)-crx(im,j))) - enddo - -! WS 99.09.07 : Split up north and south pole - - if ( jfirst-ng <= 1 ) then - do i=1,im - adx(i, 1) = q(i,1) - enddo - endif - if ( jlast+ng >= jm ) then - do i=1,im - adx(i,jm) = q(i,jm) - enddo - endif - - call ytp(im,jm,fy, adx,cry,yfx,ng,jord,0,jfirst,jlast) - - do j=js2g0,jn2g0 - do i=1,im - jp = j-va(i,j) - wk1v(i,j) = q(i,j) +D0_5*va(i,j)*(q(i,jp)-q(i,jp+1)) - enddo - enddo - - call xtpv(im, ffsl, fx, wk1v, crx, iord, xfx, & - cosp, id, dm, qtmpv, al, ar, a6, & - jfirst, jlast, js2g0, jn2g0, jm, & - 1, jm, jfirst, jlast, & - jfirst-ng, jlast+ng, jfirst-ng, jlast+ng, & - jfirst, jlast, jfirst-ng, jlast+ng) - - return -!EOC - end subroutine tp2d -!----------------------------------------------------------------------- - -#ifndef VECTORIZE -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: xtpv -! -! !INTERFACE: - subroutine xtpv(im, ffslv, fxv, qv, cv, iord, mfxv, & - cosav, id, dmw, qtmpv, alw, arw, a6w, & - jfirst, jlast, jlow, jhigh, jm, & - jl2, jh2, jl3, jh3, & - jl4, jh4, jl5, jh5, & - jl7, jh7, jl11, jh11) -!----------------------------------------------------------------------- - - implicit none - -! !INPUT PARAMETERS: - integer id ! ID = 0: density (mfx = C) - ! ID = 1: mixing ratio (mfx is mass flux) - - integer im ! Total longitudes - integer iord - integer jfirst, jlast, jlow, jhigh, jm - integer jl2, jh2, jl3, jh3, jl4, jh4, jl5, jh5 - integer jl7, jh7, jl11, jh11 - real (r8) cv(im,jl5:jh5) ! Courant numbers - real (r8) qv(im,jl4:jh4) - real (r8) mfxv(im,jl7:jh7) - logical ffslv(jl2:jh2) - real (r8) cosav(jm) - -! !INPUT/OUTPUT PARAMETERS: - real (r8) qtmpv(-im/3:im+im/3,jl11:jh11) ! Input work arrays: - real (r8) dmw(-im/3:im+im/3) - real (r8) alw(-im/3:im+im/3) - real (r8) arw(-im/3:im+im/3) - real (r8) a6w(-im/3:im+im/3) - -! !OUTPUT PARAMETERS: - real (r8) fxv(im,jl3:jh3) - -! !DESCRIPTION: -! -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC - -! Local: - real (r8) cos_upw !critical cosine for upwind - real (r8) cos_van !critical cosine for van Leer - real (r8) cos_ppm !critical cosine for ppm - - parameter (cos_upw = D0_05) !roughly at 87 deg. - parameter (cos_van = D0_25) !roughly at 75 deg. - parameter (cos_ppm = D0_25) - - integer i, imp, j - real (r8) qmax, qmin - real (r8) rut, tmp - integer iu, itmp, ist - integer isave(im) - integer iuw, iue - real (r8) dm(-im/3:im+im/3) - real (r8) al(-im/3:im+im/3) - real (r8) ar(-im/3:im+im/3) - real (r8) a6(-im/3:im+im/3) - - imp = im + 1 - - do j = jlow, jhigh - - do i=1,im - qtmpv(i,j) = qv(i,j) - enddo - - if( ffslv(j) ) then -! Flux-Form Semi-Lagrangian transport - -! Figure out ghost zone for the western edge: - iuw = -cv(1,j) - iuw = min(0, iuw) - - do i=iuw, 0 - qtmpv(i,j) = qv(im+i,j) - enddo - -! Figure out ghost zone for the eastern edge: - iue = im - cv(im,j) - iue = max(imp, iue) - - do i=imp, iue - qtmpv(i,j) = qv(i-im,j) - enddo - - if( iord == 1 .or. cosav(j) < cos_upw) then - do i=1,im - iu = cv(i,j) - if(cv(i,j) .le. D0_0) then - itmp = i - iu - isave(i) = itmp - 1 - else - itmp = i - iu - 1 - isave(i) = itmp + 1 - endif - fxv(i,j) = (cv(i,j)-iu) * qtmpv(itmp,j) - enddo - else - - do i=1,im -! 2nd order slope - tmp = D0_25*(qtmpv(i+1,j) - qtmpv(i-1,j)) - qmax = max(qtmpv(i-1,j), qtmpv(i,j), qtmpv(i+1,j)) - qtmpv(i,j) - qmin = qtmpv(i,j) - min(qtmpv(i-1,j), qtmpv(i,j), qtmpv(i+1,j)) - dm(i) = sign(min(abs(tmp),qmax,qmin), tmp) - enddo - - - do i=iuw, 0 - dm(i) = dm(im+i) - enddo - - do i=imp, iue - dm(i) = dm(i-im) - enddo - - if(iord .ge. 3 .and. cosav(j) .gt. cos_ppm) then - call fxppm(im, cv(:,j), mfxv(:,j), qtmpv(:,j), dm, fxv(:,j), iord, al, ar, a6, & - iuw, iue, ffslv(j), isave) - else - do i=1,im - iu = cv(i,j) - rut = cv(i,j) - iu - if(cv(i,j) .le. D0_0) then - itmp = i - iu - isave(i) = itmp - 1 - fxv(i,j) = rut*(qtmpv(itmp,j)-dm(itmp)*(D1_0+rut)) - else - itmp = i - iu - 1 - isave(i) = itmp + 1 - fxv(i,j) = rut*(qtmpv(itmp,j)+dm(itmp)*(D1_0-rut)) - endif - enddo - endif - - endif - - do i=1,im - if(cv(i,j) .ge. D1_0) then - do ist = isave(i),i-1 - fxv(i,j) = fxv(i,j) + qtmpv(ist,j) - enddo - elseif(cv(i,j) .le. -D1_0) then - do ist = i,isave(i) - fxv(i,j) = fxv(i,j) - qtmpv(ist,j) - enddo - endif - enddo - - if(id .ne. 0) then - do i=1,im - fxv(i,j) = fxv(i,j)*mfxv(i,j) - enddo - endif - - else -! Regular PPM (Eulerian without FFSL extension) - - qtmpv(imp,j) = qv(1,j) - qtmpv( 0,j) = qv(im,j) - - if(iord == 1 .or. cosav(j) < cos_upw) then - do i=1,im - iu = real(i,r8) - cv(i,j) - fxv(i,j) = mfxv(i,j)*qtmpv(iu,j) - enddo - else - - qtmpv(-1,j) = qv(im-1,j) - qtmpv(imp+1,j) = qv(2,j) - - if(iord > 0 .or. cosav(j) < cos_van) then - call xmist(im, qtmpv(:,j), dm, 2) - else - call xmist(im, qtmpv(:,j), dm, iord) - endif - - dm(0) = dm(im) - - if( abs(iord).eq.2 .or. cosav(j) .lt. cos_van ) then - do i=1,im - iu = real(i,r8) - cv(i,j) - fxv(i,j) = mfxv(i,j)*(qtmpv(iu,j)+dm(iu)*(sign(D1_0,cv(i,j))-cv(i,j))) - -! if(cv(i,j) .le. 0.) then -! fxv(i,j) = qtmpv(i,j) - dm(i)*(1.+cv(i,j)) -! else -! fxv(i,j) = qtmpv(i-1,j) + dm(i-1)*(1.-cv(i,j)) -! endif -! fxv(i,j) = fxv(i,j)*mfxv(i,j) - - enddo - else - call fxppm(im, cv(:,j), mfxv(:,j), qtmpv(:,j), dm, fxv(:,j), iord, al, ar, a6, & - iuw, iue, ffslv(j), isave) - endif - endif - - endif - - enddo - - return -!EOC - end subroutine xtpv -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: xmist -! -! !INTERFACE: - subroutine xmist(im, q, dm, id) -!----------------------------------------------------------------------- - - implicit none - -! !INPUT PARAMETERS: - integer im ! Total number of longitudes - integer id ! ID = 0: density (mfx = C) - ! ID = 1: mixing ratio (mfx is mass flux) - real(r8) q(-im/3:im+im/3) ! Input latitude - -! !OUTPUT PARAMETERS: - real(r8) dm(-im/3:im+im/3) ! - -! !DESCRIPTION: -! -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC - - real(r8) r24 - parameter( r24 = D1_0/D24_0) - - integer i - real(r8) qmin, qmax - - if(id .le. 2) then - do i=1,im - dm(i) = r24*(D8_0*(q(i+1) - q(i-1)) + q(i-2) - q(i+2)) - enddo - else - do i=1,im - dm(i) = D0_25*(q(i+1) - q(i-1)) - enddo - endif - - if( id < 0 ) return - -! Apply monotonicity constraint (Lin et al. 1994, MWR) - do i=1,im - qmax = max( q(i-1), q(i), q(i+1) ) - q(i) - qmin = q(i) - min( q(i-1), q(i), q(i+1) ) - dm(i) = sign( min(abs(dm(i)), qmax, qmin), dm(i) ) - enddo - return -!EOC - end subroutine xmist -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: fxppm -! -! !INTERFACE: - subroutine fxppm(im, c, mfx, p, dm, fx, iord, al, ar, a6, & - iuw, iue, ffsl, isave) -!----------------------------------------------------------------------- -! -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im, iord - real (r8) c(im) - real (r8) p(-im/3:im+im/3) - real (r8) dm(-im/3:im+im/3) - real (r8) mfx(im) - integer iuw, iue - logical ffsl - integer isave(im) - -! !INPUT/OUTPUT PARAMETERS: - real (r8) al(-im/3:im+im/3) - real (r8) ar(-im/3:im+im/3) - real (r8) a6(-im/3:im+im/3) - -! !OUTPUT PARAMETERS: - real (r8) fx(im) - -! !DESCRIPTION: -! -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real (r8) r3, r23 - parameter ( r3 = D1_0/D3_0, r23 = D2_0/D3_0 ) - - integer i, lmt - integer iu, itmp - real (r8) ru - logical steep - - if( iord == 6 ) then - steep = .true. - else - steep = .false. - endif - - do i=1,im - al(i) = D0_5*(p(i-1)+p(i)) + (dm(i-1) - dm(i))*r3 - enddo - - if( steep ) call steepx( im, p, al(1), dm ) - - do i=1,im-1 - ar(i) = al(i+1) - enddo - ar(im) = al(1) - - if(iord == 7) then - call huynh(im, ar(1), al(1), p(1), a6(1), dm(1)) - else - if(iord .eq. 3 .or. iord .eq. 5) then - do i=1,im - a6(i) = D3_0*(p(i)+p(i) - (al(i)+ar(i))) - enddo - endif - lmt = iord - 3 - call lmppm( dm(1), a6(1), ar(1), al(1), p(1), im, lmt ) - endif - - if( ffsl ) then - - do i=iuw, 0 - al(i) = al(im+i) - ar(i) = ar(im+i) - a6(i) = a6(im+i) - enddo - - do i=im+1, iue - al(i) = al(i-im) - ar(i) = ar(i-im) - a6(i) = a6(i-im) - enddo - - do i=1,im - iu = c(i) - ru = c(i) - iu - if(c(i) .gt. D0_0) then - itmp = i - iu - 1 - isave(i) = itmp + 1 - fx(i) = ru*(ar(itmp)+D0_5*ru*(al(itmp)-ar(itmp) + & - a6(itmp)*(D1_0-r23*ru)) ) - else - itmp = i - iu - isave(i) = itmp - 1 - fx(i) = ru*(al(itmp)-D0_5*ru*(ar(itmp)-al(itmp) + & - a6(itmp)*(D1_0+r23*ru)) ) - endif - enddo - - else - al(0) = al(im) - ar(0) = ar(im) - a6(0) = a6(im) - do i=1,im - if(c(i) .gt. D0_0) then - fx(i) = ar(i-1) + D0_5*c(i)*(al(i-1) - ar(i-1) + & - a6(i-1)*(D1_0-r23*c(i)) ) - else - fx(i) = al(i) - D0_5*c(i)*(ar(i) - al(i) + & - a6(i)*(D1_0+r23*c(i))) - endif - fx(i) = mfx(i) * fx(i) - enddo - endif - return -!EOC - end subroutine fxppm -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: steepx -! -! !INTERFACE: - subroutine steepx(im, p, al, dm) -!----------------------------------------------------------------------- - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im - real (r8) p(-im/3:im+im/3) - real (r8) dm(-im/3:im+im/3) - -! !INPUT/OUTPUT PARAMETERS: - real (r8) al(im) - -! !DESCRIPTION: -! -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i - real (r8) r3 - parameter ( r3 = D1_0/D3_0 ) - - real (r8) dh(0:im) - real (r8) d2(0:im+1) - real (r8) eta(0:im) - real (r8) xxx, bbb, ccc - - do i=0,im - dh(i) = p(i+1) - p(i) - enddo - -! Needs dh(0:im) - do i=1,im - d2(i) = dh(i) - dh(i-1) - enddo - d2(0) = d2(im) - d2(im+1) = d2(1) - -! needs p(-1:im+2), d2(0:im+1) - do i=1,im - if( d2(i+1)*d2(i-1).lt.D0_0 .and. p(i+1).ne.p(i-1) ) then - xxx = D1_0 - D0_5 * ( p(i+2) - p(i-2) ) / ( p(i+1) - p(i-1) ) - eta(i) = max(D0_0, min(xxx, D0_5) ) - else - eta(i) = D0_0 - endif - enddo - - eta(0) = eta(im) - -! needs eta(0:im), dh(0:im-1), dm(0:im) - do i=1,im - bbb = ( D2_0*eta(i ) - eta(i-1) ) * dm(i-1) - ccc = ( D2_0*eta(i-1) - eta(i ) ) * dm(i ) - al(i) = al(i) + D0_5*( eta(i-1) - eta(i)) * dh(i-1) + (bbb - ccc) * r3 - enddo - return -!EOC - end subroutine steepx -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: lmppm -! -! !INTERFACE: - subroutine lmppm(dm, a6, ar, al, p, im, lmt) -!----------------------------------------------------------------------- - - implicit none - -! !INPUT PARAMETERS: - integer im ! Total longitudes - integer lmt ! LMT = 0: full monotonicity - ! LMT = 1: Improved and simplified full monotonic constraint - ! LMT = 2: positive-definite constraint - ! LMT = 3: Quasi-monotone constraint - real(r8) p(im) - real(r8) dm(im) - -! !OUTPUT PARAMETERS: - real(r8) a6(im) - real(r8) ar(im) - real(r8) al(im) - -! !DESCRIPTION: -! -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real (r8) r12 - parameter ( r12 = D1_0/D12_0 ) - - real (r8) da1, da2, fmin, a6da - real (r8) dr, dl - - integer i - -! LMT = 0: full monotonicity -! LMT = 1: Improved and simplified full monotonic constraint -! LMT = 2: positive-definite constraint -! LMT = 3: Quasi-monotone constraint - - if( lmt == 0 ) then - -! Full constraint - do i=1,im - if(dm(i) .eq. D0_0) then - ar(i) = p(i) - al(i) = p(i) - a6(i) = D0_0 - else - da1 = ar(i) - al(i) - da2 = da1**2 - a6da = a6(i)*da1 - if(a6da .lt. -da2) then - a6(i) = D3_0*(al(i)-p(i)) - ar(i) = al(i) - a6(i) - elseif(a6da .gt. da2) then - a6(i) = D3_0*(ar(i)-p(i)) - al(i) = ar(i) - a6(i) - endif - endif - enddo - - elseif( lmt == 1 ) then - -! Improved (Lin 2001?) full constraint - do i=1,im - da1 = dm(i) + dm(i) - dl = sign(min(abs(da1),abs(al(i)-p(i))), da1) - dr = sign(min(abs(da1),abs(ar(i)-p(i))), da1) - ar(i) = p(i) + dr - al(i) = p(i) - dl - a6(i) = D3_0*(dl-dr) - enddo - - elseif( lmt == 2 ) then -! Positive definite constraint - do 250 i=1,im - if(abs(ar(i)-al(i)) .ge. -a6(i)) go to 250 - fmin = p(i) + D0_25*(ar(i)-al(i))**2/a6(i) + a6(i)*r12 - if(fmin.ge.D0_0) go to 250 - if(p(i).lt.ar(i) .and. p(i).lt.al(i)) then - ar(i) = p(i) - al(i) = p(i) - a6(i) = D0_0 - elseif(ar(i) .gt. al(i)) then - a6(i) = D3_0*(al(i)-p(i)) - ar(i) = al(i) - a6(i) - else - a6(i) = D3_0*(ar(i)-p(i)) - al(i) = ar(i) - a6(i) - endif -250 continue - - elseif(lmt .eq. 3) then -! Quasi-monotone constraint - do i=1,im - da1 = D4_0*dm(i) - dl = sign(min(abs(da1),abs(al(i)-p(i))), da1) - dr = sign(min(abs(da1),abs(ar(i)-p(i))), da1) - ar(i) = p(i) + dr - al(i) = p(i) - dl - a6(i) = D3_0*(dl-dr) - enddo - endif - return -!EOC - end subroutine lmppm -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: huynh --- Enforce Huynh's 2nd constraint in 1D periodic domain -! -! !INTERFACE: - subroutine huynh(im, ar, al, p, d2, d1) -!----------------------------------------------------------------------- - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - integer im - real(r8) p(im) - -! !OUTPUT PARAMETERS: - real(r8) ar(im) - real(r8) al(im) - real(r8) d2(im) - real(r8) d1(im) - -! !DESCRIPTION: -! -! Enforce Huynh's 2nd constraint in 1D periodic domain -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i - real(r8) pmp - real(r8) lac - real(r8) pmin - real(r8) pmax - -! Compute d1 and d2 - d1(1) = p(1) - p(im) - do i=2,im - d1(i) = p(i) - p(i-1) - enddo - - do i=1,im-1 - d2(i) = d1(i+1) - d1(i) - enddo - d2(im) = d1(1) - d1(im) - -! Constraint for AR -! i = 1 - pmp = p(1) + D2_0 * d1(1) - lac = p(1) + D0_5 * (d1(1)+d2(im)) + d2(im) - pmin = min(p(1), pmp, lac) - pmax = max(p(1), pmp, lac) - ar(1) = min(pmax, max(ar(1), pmin)) - - do i=2, im - pmp = p(i) + D2_0*d1(i) - lac = p(i) + D0_5*(d1(i)+d2(i-1)) + d2(i-1) - pmin = min(p(i), pmp, lac) - pmax = max(p(i), pmp, lac) - ar(i) = min(pmax, max(ar(i), pmin)) - enddo - -! Constraint for AL - do i=1, im-1 - pmp = p(i) - D2_0*d1(i+1) - lac = p(i) + D0_5*(d2(i+1)-d1(i+1)) + d2(i+1) - pmin = min(p(i), pmp, lac) - pmax = max(p(i), pmp, lac) - al(i) = min(pmax, max(al(i), pmin)) - enddo - -! i=im - i = im - pmp = p(im) - D2_0*d1(1) - lac = p(im) + D0_5*(d2(1)-d1(1)) + d2(1) - pmin = min(p(im), pmp, lac) - pmax = max(p(im), pmp, lac) - al(im) = min(pmax, max(al(im), pmin)) - -! compute A6 (d2) - do i=1, im - d2(i) = D3_0*(p(i)+p(i) - (al(i)+ar(i))) - enddo - return -!EOC - end subroutine huynh -!----------------------------------------------------------------------- -#endif - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: ytp -! -! !INTERFACE: - subroutine ytp(im, jm, fy, q, c, yfx, ng, jord, iv, jfirst, jlast) -!----------------------------------------------------------------------- - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im, jm ! Dimensions - integer jfirst, jlast ! Latitude strip - integer ng ! Max. NS dependencies - integer jord ! order of subgrid dist - integer iv ! Scalar=0, Vector=1 - real (r8) q(im,jfirst-ng:jlast+ng) ! advected scalar N*jord S*jord - real (r8) c(im,jfirst:jlast+1) ! Courant N (like FY) - real (r8) yfx(im,jfirst:jlast+1) ! Backgrond mass flux - -! !OUTPUT PARAMETERS: - real (r8) fy(im,jfirst:jlast+1) ! Flux N (see tp2c) - -! !DESCRIPTION: -! This routine calculates the flux FX. The method chosen -! depends on the order of the calculation JORD (currently -! 1, 2 or 3). -! -! !CALLED FROM: -! cd_core -! tp2d -! -! !REVISION HISTORY: -! -! SJL 99.04.13: Delivery -! WS 99.04.13: Added jfirst:jlast concept -! WS 99.04.21: Removed j1 and j2 (j1=2, j2=jm-1 consistently) -! removed a6,ar,al from argument list -! WS 99.04.27: DM made local to this routine -! WS 99.09.09: Documentation; indentation; cleaning -! WS 99.10.22: Added NG as argument; pruned arrays -! SJL 99.12.24: Revised documentation; optimized for better cache usage -! WS 00.05.14: Renamed ghost indices as per Kevin's definitions -! -!EOP -!--------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i, j, jt - integer js2g0, jn1g1 - -! work arrays (should pass in eventually for performance enhancement): - real (r8) dm(im,jfirst-ng:jlast+ng) - -! real (r8) ar(im,jfirst-1:jlast+1) ! AR needs to be ghosted on NS -! real (r8) al(im,jfirst-1:jlast+2) ! AL needs to be ghosted on N2S -! real (r8) a6(im,jfirst-1:jlast+1) ! A6 needs to be ghosted on NS - - js2g0 = max(2,jfirst) ! No ghosting - jn1g1 = min(jm,jlast+1) ! Ghost N*1 - - fy = D0_0 - - if(jord == 1) then - do j=js2g0,jn1g1 - do i=1,im - jt = real(j,r8) - c(i,j) - fy(i,j) = q(i,jt) - enddo - enddo - else - -! -! YMIST requires q on NS; Only call to YMIST here -! - call ymist(im, jm, q, dm, ng, jord, iv, jfirst, jlast) - - if( abs(jord) .ge. 3 ) then - - call fyppm(c,q,dm,fy,im,jm,ng,jord,iv,jfirst,jlast) - - else -! -! JORD can either have the value 2 or -2 at this point -! - do j=js2g0,jn1g1 - do i=1,im - jt = real(j,r8) - c(i,j) - fy(i,j) = q(i,jt) + (sign(D1_0,c(i,j))-c(i,j))*dm(i,jt) - enddo - enddo - endif - endif - - do j=js2g0,jn1g1 - do i=1,im - fy(i,j) = fy(i,j)*yfx(i,j) - enddo - enddo - return -!EOC - end subroutine ytp -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: ymist -! -! !INTERFACE: - subroutine ymist(im, jm, q, dm, ng, jord, iv, jfirst, jlast) -!----------------------------------------------------------------------- - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im, jm ! Dimensions - integer jfirst, jlast ! Latitude strip - integer ng ! NS dependencies - integer jord ! order of subgrid distribution - integer iv ! Scalar (==0) Vector (==1) - real (r8) q(im,jfirst-ng:jlast+ng) ! transported scalar N*ng S*ng - -! !OUTPUT PARAMETERS: - real (r8) dm(im,jfirst-ng:jlast+ng) ! Slope only N*(ng-1) S*(ng-1) used - -! !DESCRIPTION: -! Calculate the slope of the pressure. The number of ghost -! latitudes (NG) depends on what method (JORD) will be used -! subsequentally. NG is equal to MIN(ABS(JORD),3). -! -! !CALLED FROM: -! ytp -! -! !REVISION HISTORY: -! -! SJL 99.04.13: Delivery -! WS 99.04.13: Added jfirst:jlast concept -! WS 99.09.09: Documentation; indentation; cleaning -! SJL 00.01.06: Documentation -! WS 00.05.14: Renamed ghost indices as per Kevin's definitions -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! Local variables - - integer i, j, jm1, im2, js2gng1, jn2gng1 - real (r8) qmax, qmin, tmp - - js2gng1 = max(2, jfirst-ng+1) ! Number needed on S - jn2gng1 = min(jm-1,jlast+ng-1) ! Number needed on N - - jm1 = jm - 1 - im2 = im / 2 - - do j=js2gng1,jn2gng1 - do i=1,im - dm(i,j) = D0_25*(q(i,j+1) - q(i,j-1)) - enddo - enddo - - if( iv == 0 ) then - - if ( jfirst-ng <= 1 ) then -! S pole - do i=1,im2 - tmp = D0_25*(q(i,2)-q(i+im2,2)) - qmax = max(q(i,2),q(i,1), q(i+im2,2)) - q(i,1) - qmin = q(i,1) - min(q(i,2),q(i,1), q(i+im2,2)) - dm(i,1) = sign(min(abs(tmp),qmax,qmin),tmp) - enddo - - do i=im2+1,im - dm(i, 1) = - dm(i-im2, 1) - enddo - endif - - if ( jlast+ng >= jm ) then -! N pole - do i=1,im2 - tmp = D0_25*(q(i+im2,jm1)-q(i,jm1)) - qmax = max(q(i+im2,jm1),q(i,jm), q(i,jm1)) - q(i,jm) - qmin = q(i,jm) - min(q(i+im2,jm1),q(i,jm), q(i,jm1)) - dm(i,jm) = sign(min(abs(tmp),qmax,qmin),tmp) - enddo - - do i=im2+1,im - dm(i,jm) = - dm(i-im2,jm) - enddo - endif - - else - - if ( jfirst-ng <= 1 ) then -! South - do i=1,im2 - tmp = D0_25*(q(i,2)+q(i+im2,2)) - qmax = max(q(i,2),q(i,1), -q(i+im2,2)) - q(i,1) - qmin = q(i,1) - min(q(i,2),q(i,1),-q(i+im2,2)) - dm(i,1) = sign(min(abs(tmp),qmax,qmin),tmp) - enddo - - do i=im2+1,im - dm(i, 1) = dm(i-im2, 1) - enddo - endif - - if ( jlast+ng >= jm ) then -! North - do i=1,im2 - tmp = -D0_25*(q(i+im2,jm1)+q(i,jm1)) - qmax = max(-q(i+im2,jm1),q(i,jm), q(i,jm1)) - q(i,jm) - qmin = q(i,jm) - min(-q(i+im2,jm1),q(i,jm), q(i,jm1)) - dm(i,jm) = sign(min(abs(tmp),qmax,qmin),tmp) - enddo - - do i=im2+1,im - dm(i,jm) = dm(i-im2,jm) - enddo - endif - - endif - - if( jord > 0 ) then -! -! Applies monotonic slope constraint (off if jord less than zero) -! - do j=js2gng1,jn2gng1 - do i=1,im - qmax = max(q(i,j-1),q(i,j),q(i,j+1)) - q(i,j) - qmin = q(i,j) - min(q(i,j-1),q(i,j),q(i,j+1)) - dm(i,j) = sign(min(abs(dm(i,j)),qmin,qmax),dm(i,j)) - enddo - enddo - endif - return -!EOC - end subroutine ymist -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: fyppm -! -! !INTERFACE: - subroutine fyppm(c, q, dm, flux, im, jm, ng, jord, iv, jfirst, jlast) -!----------------------------------------------------------------------- - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im, jm ! Dimensions - integer jfirst, jlast ! Latitude strip - integer ng ! Max. NS dependencies - integer jord ! Approximation order - integer iv ! Scalar=0, Vector=1 - real (r8) q(im,jfirst-ng:jlast+ng) ! mean value needed only N*2 S*2 - real (r8) dm(im,jfirst-ng:jlast+ng) ! Slope needed only N*2 S*2 - real (r8) c(im,jfirst:jlast+1) ! Courant N (like FLUX) - -! !INPUT/OUTPUT PARAMETERS: - real (r8) ar(im,jfirst-1:jlast+1) ! AR needs to be ghosted on NS - real (r8) al(im,jfirst-1:jlast+2) ! AL needs to be ghosted on N2S - real (r8) a6(im,jfirst-1:jlast+1) ! A6 needs to be ghosted on NS - -! !OUTPUT PARAMETERS: - real (r8) flux(im,jfirst:jlast+1) ! Flux N (see tp2c) - -! !DESCRIPTION: -! -! NG is passed from YTP for convenience -- it is actually 1 more in NS -! than the actual number of latitudes needed here. But in the shared-memory -! case it becomes 0, which is much cleaner. -! -! !CALLED FROM: -! ytp -! -! !REVISION HISTORY: -! -! SJL 99.04.13: Delivery -! WS 99.04.19: Added jfirst:jlast concept; FYPPM only called from YTP -! WS 99.04.21: Removed j1, j2 (j1=2, j2=jm-1 consistently) -! removed a6,ar,al from argument list -! WS 99.09.09: Documentation; indentation; cleaning -! WS 99.10.22: Added ng as argument; Pruned arrays -! WS 00.05.14: Renamed ghost indices as per Kevin's definitions -! -!EOP -!--------------------------------------------------------------------- -!BOC - real (r8) r3, r23 - parameter ( r3 = D1_0/D3_0, r23 = D2_0/D3_0 ) - integer i, j, imh, jm1, lmt - integer js1g1, js2g0, js2g1, jn1g2, jn1g1, jn2g1 - integer jan, jlow, jhigh, ilow, ihigh - integer ja(jlast-jfirst+3) -! logical steep - -! if(jord .eq. 6) then -! steep = .true. -! else -! steep = .false. -! endif - - imh = im / 2 - jm1 = jm - 1 - - flux = D0_0 - - js1g1 = max(1,jfirst-1) ! Ghost S*1 - js2g0 = max(2,jfirst) ! No ghosting - js2g1 = max(2,jfirst-1) ! Ghost S*1 - jn1g1 = min(jm,jlast+1) ! Ghost N*1 - jn1g2 = min(jm,jlast+2) ! Ghost N*2 - jn2g1 = min(jm-1,jlast+1) ! Ghost N*1 - - do j=js2g1,jn1g2 ! AL needed N2S - do i=1,im ! P, dm ghosted N2S2 (at least) - al(i,j) = D0_5*(q(i,j-1)+q(i,j)) + r3*(dm(i,j-1) - dm(i,j)) - enddo - enddo - -! Yeh's steepening procedure; to be implemented -! if(steep) call steepy(im, jm, jfirst, jlast, & -! ng, q, al, dm ) - - do j=js1g1,jn2g1 ! AR needed NS - do i=1,im - ar(i,j) = al(i,j+1) ! AL ghosted N2S - enddo - enddo - -! WS 990726 : Added condition to decide if poles are on this processor - -! Poles: - - if( iv == 0 ) then - - if ( jfirst == 1 ) then - do i=1,imh - al(i, 1) = al(i+imh,2) - al(i+imh,1) = al(i, 2) - enddo - endif - - if ( jlast == jm ) then - do i=1,imh - ar(i, jm) = ar(i+imh,jm1) - ar(i+imh,jm) = ar(i, jm1) - enddo - endif - - else - - if ( jfirst == 1 ) then - do i=1,imh - al(i, 1) = -al(i+imh,2) - al(i+imh,1) = -al(i, 2) - enddo - endif - - if ( jlast == jm ) then - do i=1,imh - ar(i, jm) = -ar(i+imh,jm1) - ar(i+imh,jm) = -ar(i, jm1) - enddo - endif - - endif - - if( jord == 3 .or. jord == 5 ) then - do j=js1g1,jn1g1 ! A6 needed NS - do i=1,im - a6(i,j) = D3_0*(q(i,j)+q(i,j) - (al(i,j)+ar(i,j))) - enddo - enddo - endif - - lmt = jord - 3 - -! do j=js1g1,jn1g1 ! A6, AR, AL needed NS -! call lmppm(dm(1,j),a6(1,j),ar(1,j),al(1,j),q(1,j),im,lmt) -! enddo - -#ifdef VECTORIZE - jan = 1 - ja(1) = 1 - ilow = 1 - ihigh = im*(jn1g1-js1g1+1) - jlow = 1 - jhigh = 1 - call lmppmv(dm(1,js1g1), a6(1,js1g1), ar(1,js1g1), & - al(1,js1g1), q(1,js1g1), im*(jn1g1-js1g1+1), lmt, & - jan, ja, ilow, ihigh, jlow, jhigh, jlow, jhigh) -#else - call lmppm(dm(1,js1g1), a6(1,js1g1), ar(1,js1g1), & - al(1,js1g1), q(1,js1g1), im*(jn1g1-js1g1+1), lmt) -#endif - - do j=js2g0,jn1g1 ! flux needed N - do i=1,im - if(c(i,j).gt.D0_0) then - flux(i,j) = ar(i,j-1) + D0_5*c(i,j)*(al(i,j-1) - ar(i,j-1) + & - a6(i,j-1)*(D1_0-r23*c(i,j)) ) - else - flux(i,j) = al(i,j) - D0_5*c(i,j)*(ar(i,j) - al(i,j) + & - a6(i,j)*(D1_0+r23*c(i,j))) - endif - enddo - enddo - return -!EOC - end subroutine fyppm -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: tpcc -! -! !INTERFACE: - subroutine tpcc(va, ymass, q, crx, cry, im, jm, ng_c, ng_d, & - iord, jord, fx, fy, ffsl, cose, jfirst, jlast, & - dm, qtmp, al, ar, a6 ) -!----------------------------------------------------------------------- - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im, jm ! Dimensions - integer ng_c ! - integer ng_d ! - integer jfirst, jlast ! Latitude strip - integer iord, jord ! Interpolation order in x,y - logical ffsl(jm) ! Flux-form semi-Lagrangian transport? - real (r8) cose(jm) ! Critical cosine (replicated) - real (r8) va(im,jfirst:jlast) ! Courant (unghosted like FX) - real (r8) q(im,jfirst-ng_d:jlast+ng_d) ! - real (r8) crx(im,jfirst-ng_c:jlast+ng_c) - real (r8) cry(im,jfirst:jlast) ! Courant # (ghosted like FY) - real (r8) ymass(im,jfirst:jlast) ! Background y-mass-flux (ghosted like FY) - -! Input 1D work arrays: - real (r8) dm(-im/3:im+im/3) - real (r8) qtmp(-im/3:im+im/3) - real (r8) al(-im/3:im+im/3) - real (r8) ar(-im/3:im+im/3) - real (r8) a6(-im/3:im+im/3) - -! !OUTPUT PARAMETERS: - real (r8) fx(im,jfirst:jlast) ! Flux in x (unghosted) - real (r8) fy(im,jfirst:jlast) ! Flux in y (unghosted since iv==0) - -! !DESCRIPTION: -! In this routine the number -! of north ghosted latitude min(abs(jord),2), and south ghosted -! latitudes is XXXX -! -! !CALLED FROM: -! cd_core -! -! !REVISION HISTORY: -! SJL 99.04.13: Delivery -! WS 99.04.13: Added jfirst:jlast concept -! WS 99.05.10: Replaced JNP with JM, JMR with JM-1, IMR with IM -! WS 99.05.10: Removed fvcore.h and JNP, IMH, IML definitions -! WS 99.10.20: Pruned arrays -! WS 00.05.14: Renamed ghost indices as per Kevin's definitions -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - - real (r8) adx(im,jfirst-1:jlast+2) - integer north, south - integer i, j, jp, im2, js2g0, js2gs, jn2g0, jn1g0, jn1gn - real (r8) wk1v(im,jfirst-1:jlast+2) - real (r8) fx1(im) - real (r8) qtmpv(-im/3:im+im/3,jfirst-1:jlast+2) - - im2 = im/2 - north = min(2,abs(jord)) ! north == 1 or 2 - south = north-1 ! south == 0 or 1 - js2g0 = max(2,jfirst) - js2gs = max(2,jfirst-south) - jn2g0 = min(jm-1,jlast) - jn1gn = min(jm,jlast+north) - jn1g0 = min(jm,jlast) - -! This loop must be ghosted N*NG, S*NG - - call xtpv( im, ffsl, wk1v, q, crx, 1, crx, & - cose, 0, dm, qtmpv, al, ar, a6, & - jfirst, jlast, js2gs, jn1gn, jm, & - 1, jm, jfirst-1, jlast+2, & - jfirst-ng_d, jlast+ng_d, jfirst-ng_c, jlast+ng_c, & - jfirst-ng_c, jlast+ng_c, jfirst-1, jlast+2) - - do j=js2gs,jn1gn - - do i=1,im-1 - adx(i,j) = q(i,j) + D0_5 * & - (wk1v(i,j)-wk1v(i+1,j) + q(i,j)*(crx(i+1,j)-crx(i,j))) - enddo - - adx(im,j) = q(im,j) + D0_5 * & - (wk1v(im,j)-wk1v(1,j) + q(im,j)*(crx(1,j)-crx(im,j))) - enddo - - call ycc(im, jm, fy, adx, cry, ymass, jord, 0,jfirst,jlast) - -! For Scalar only!!! - if ( jfirst-ng_d <= 1 ) then - do i=1,im2 - q(i,1) = q(i+im2, 2) - enddo - do i=im2+1,im - q(i,1) = q(i-im2, 2) - enddo - endif - - if ( jlast == jm ) then - do i=1,im2 - fx1(i) = q(i+im2,jm) - enddo - do i=im2+1,im - fx1(i) = q(i-im2,jm) - enddo - - do i=1,im - if(va(i,jm) .gt. D0_0) then - adx(i,jm) = q(i,jm) + D0_5*va(i,jm)*(q(i,jm-1)-q(i,jm)) - else - adx(i,jm) = q(i,jm) + D0_5*va(i,jm)*(q(i,jm)-fx1(i)) - endif - enddo - endif - - do j=js2g0,jn2g0 - do i=1,im - jp = j-va(i,j) -! jp = j if va < 0 -! jp = j -1 if va < 0 -! q needed max(1, jfirst-1) - adx(i,j) = q(i,j) + D0_5*va(i,j)*(q(i,jp)-q(i,jp+1)) - enddo - enddo - - call xtpv( im, ffsl, fx, adx, crx, iord, crx, & - cose, 0, dm, qtmpv, al, ar, a6, & - jfirst, jlast, js2g0, jn1g0, jm, & - 1, jm, jfirst, jlast, & - jfirst-1, jlast+2,jfirst-ng_c, jlast+ng_c, & - jfirst-ng_c, jlast+ng_c, jfirst-1, jlast+2) - - return -!EOC - end subroutine tpcc -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: ycc -! -! !INTERFACE: - subroutine ycc(im, jm, fy, q, vc, ymass, jord, iv, jfirst, jlast) -!----------------------------------------------------------------------- - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im, jm ! Dimensions - integer jfirst, jlast ! Latitude strip - integer jord ! Approximation order - integer iv ! Scalar=0, Vector=1 - real (r8) q(im,jfirst-1-iv:jlast+2) ! Field (N*2 S*(iv+1)) - real (r8) vc(im,jfirst-iv:jlast) ! Courant (like FY) - real (r8) ymass(im,jfirst-iv:jlast) ! background mass flux - -! !OUTPUT PARAMETERS: - real (r8) fy(im,jfirst-iv:jlast) ! Flux (S if iv=1) - -! !DESCRIPTION: -! Will Sawyer's note: In this routine the number -! of ghosted latitudes NG is min(abs(jord),2). The scalar/vector -! flag determines whether the flux FY needs to be ghosted on the -! south. If called from CD\_CORE (iv==1) then it does, if called -! from TPCC (iv==0) it does not. -! -! !CALLED FROM: -! cd_core -! tpcc -! -! !REVISION HISTORY: -! -! SJL 99.04.13: Delivery -! WS 99.04.19: Added jfirst:jlast concept -! WS 99.04.27: DC removed as argument (local to this routine); DC on N -! WS 99.05.10: Replaced JNP with JM, JMR with JM-1, IMR with IM -! WS 99.05.10: Removed fvcore.h -! WS 99.07.27: Built in tests for SP or NP -! WS 99.09.09: Documentation; indentation; cleaning; pole treatment -! WS 99.09.14: Loop limits -! WS 00.05.14: Renamed ghost indices as per Kevin's definitions -! -!EOP -!--------------------------------------------------------------------- -!BOC - -! !LOCAL VARIABLES: - real (r8) dc(im,jfirst-iv:jlast+1) - real (r8) qmax, qmin - integer i, j, jt, im2, js2giv, js3giv, jn2g1, jn2g0 - - - im2 = im/2 - - js2giv = max(2,jfirst-iv) - js3giv = max(3,jfirst-iv) - jn2g1 = min(jm-1,jlast+1) - jn2g0 = min(jm-1,jlast) - - if(jord == 1) then - do j=js2giv,jn2g0 ! FY needed on S*iv - do i=1,im -! jt=j if vc > 0; jt=j+1 if vc <=0 - jt = real(j+1,r8) - vc(i,j) ! VC ghosted like fy - fy(i,j) = q(i,jt)*ymass(i,j) ! ymass ghosted like fy - enddo ! q ghosted N*1, S*iv - enddo - - else - - do j=js3giv,jn2g1 ! dc needed N*1, S*iv - do i=1,im - dc(i,j) = D0_25*(q(i,j+1)-q(i,j-1)) ! q ghosted N*2, S*(iv+1) - enddo - enddo - - if(iv.eq.0) then -! Scalar. - -! WS 99.07.27 : Split loops in SP and NP regions, added SP/NP tests - - if ( jfirst-iv <= 2 ) then - do i=1,im2 - dc(i, 2) = D0_25 * ( q(i,3) - q(i+im2,2) ) - enddo - - do i=im2+1,im - dc(i, 2) = D0_25 * ( q(i,3) - q(i-im2,2) ) - enddo - endif - - if ( jlast == jm ) then - do i=1,im2 - dc(i,jm) = D0_25 * ( q(i+im2,jm) - q(i,jm-1) ) - enddo - - do i=im2+1,im - dc(i,jm) = D0_25 * ( q(i-im2,jm) - q(i,jm-1) ) - enddo - endif - - else -! Vector winds - -! WS 99.07.27 : Split loops in SP and NP regions, added SP/NP tests - - if ( jfirst-iv <= 2 ) then - do i=1,im2 - dc(i, 2) = D0_25 * ( q(i,3) + q(i+im2,2) ) - enddo - - do i=im2+1,im - dc(i, 2) = D0_25 * ( q(i,3) + q(i-im2,2) ) - enddo - endif - - if ( jlast == jm ) then - do i=1,im2 - dc(i,jm) = -D0_25 * ( q(i,jm-1) + q(i+im2,jm) ) - enddo - - do i=im2+1,im - dc(i,jm) = -D0_25 * ( q(i,jm-1) + q(i-im2,jm) ) - enddo - endif - - endif - - if( jord > 0 ) then -! Monotonic constraint - do j=js3giv,jn2g1 ! DC needed N*1, S*iv - do i=1,im ! P ghosted N*2, S*(iv+1) - qmax = max(q(i,j-1),q(i,j),q(i,j+1)) - q(i,j) - qmin = q(i,j) - min(q(i,j-1),q(i,j),q(i,j+1)) - dc(i,j) = sign(min(abs(dc(i,j)),qmin,qmax),dc(i,j)) - enddo - enddo -! -! WS 99.08.03 : Following loop split into SP and NP part -! - if ( jfirst-iv <= 2 ) then - do i=1,im - dc(i, 2) = D0_0 - enddo - endif - if ( jlast == jm ) then - do i=1,im - dc(i,jm) = D0_0 - enddo - endif - endif - - do j=js2giv,jn2g0 ! fy needed S*iv - do i=1,im - jt = real(j+1,r8) - vc(i,j) ! vc, ymass ghosted like fy - fy(i,j) = (q(i,jt)+(sign(D1_0,vc(i,j))-vc(i,j))*dc(i,jt))*ymass(i,j) - enddo - enddo - endif - return -!EOC - end subroutine ycc -!----------------------------------------------------------------------- - -#ifdef VECTORIZE -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: xtpv -! -! !INTERFACE: - subroutine xtpv(im, ffslv, fxv, qv, cv, iord, mfxv, & - cosav, id, dm, qtmpv, al, ar, a6, & - jfirst, jlast, jlow, jhigh, jm, & - jl2, jh2, jl3, jh3, & - jl4, jh4, jl5, jh5, & - jl7, jh7, jl11, jh11) -!----------------------------------------------------------------------- - - implicit none - -! !INPUT PARAMETERS: - integer id ! ID = 0: density (mfx = C) - ! ID = 1: mixing ratio (mfx is mass flux) - - integer im ! Total longitudes - real (r8) cv(im,jl5:jh5) ! Courant numbers - real (r8) qv(im,jl4:jh4) - real (r8) mfxv(im,jl7:jh7) - logical ffslv(jl2:jh2) - integer iord - integer jfirst, jlast, jlow, jhigh, jm - integer jl2, jh2, jl3, jh3, jl4, jh4, jl5, jh5 - integer jl7, jh7, jl11, jh11 - real (r8) cosav(jm) - -! !INPUT/OUTPUT PARAMETERS: - real (r8) qtmpv(-im/3:im+im/3,jl11:jh11) ! Input work arrays: - real (r8) dm(-im/3:im+im/3) - real (r8) al(-im/3:im+im/3) - real (r8) ar(-im/3:im+im/3) - real (r8) a6(-im/3:im+im/3) - -! !OUTPUT PARAMETERS: - real (r8) fxv(im,jl3:jh3) - -! !DESCRIPTION: -! -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC - -! Local: - real (r8) cos_upw !critical cosine for upwind - real (r8) cos_van !critical cosine for van Leer - real (r8) cos_ppm !critical cosine for ppm - - parameter (cos_upw = D0_05) !roughly at 87 deg. - parameter (cos_van = D0_25) !roughly at 75 deg. - parameter (cos_ppm = D0_25) - - real (r8) r24 - parameter (r24 = D1_0/D24_0) - - integer i, imp, j - real (r8) qmax, qmin - real (r8) rut, tmp - real (r8) dmv(-im/3:im+im/3,jlow:jhigh) - integer iu, itmp, ist - integer isave(im,jlow:jhigh) - integer iuwv(jlow:jhigh), iuev(jlow:jhigh) - - integer jatn, jafn, ja - integer jat(jhigh-jlow+1), jaf(jhigh-jlow+1) - integer jattn, jatfn, jaftn, jaffn - integer jatt(jhigh-jlow+1), jatf(jhigh-jlow+1) - integer jaft(jhigh-jlow+1), jaff(jhigh-jlow+1) - integer jatftn, jatffn - integer jatft(jhigh-jlow+1), jatff(jhigh-jlow+1) - integer jafftn1, jafffn1 - integer jafft1(jhigh-jlow+1), jafff1(jhigh-jlow+1) - integer jafftn2, jafffn2 - integer jafft2(jhigh-jlow+1), jafff2(jhigh-jlow+1) - real (r8) qsum((-im/3)-1:im+im/3,jlow:jhigh) ! work arrays - - - jatn = 0 - jafn = 0 - jattn = 0 - jatfn = 0 - jaftn = 0 - jaffn = 0 - jatftn = 0 - jatffn = 0 - jafftn1 = 0 - jafffn1 = 0 - jafftn2 = 0 - jafffn2 = 0 -!call ftrace_region_begin("xtpv_1") - do j = jlow, jhigh - if (ffslv(j)) then - jatn = jatn + 1 - jat(jatn) = j - if( iord == 1 .or. cosav(j) < cos_upw) then - jattn = jattn + 1 - jatt(jattn) = j - else - jatfn = jatfn + 1 - jatf(jatfn) = j - if(iord .ge. 3 .and. cosav(j) .gt. cos_ppm) then - jatftn = jatftn + 1 - jatft(jatftn) = j - else - jatffn = jatffn + 1 - jatff(jatffn) = j - endif - endif - else - jafn = jafn + 1 - jaf(jafn) = j - if( iord == 1 .or. cosav(j) < cos_upw) then - jaftn = jaftn + 1 - jaft(jaftn) = j - else - jaffn = jaffn + 1 - jaff(jaffn) = j - if(iord > 0 .or. cosav(j) < cos_van) then - jafftn1 = jafftn1 + 1 - jafft1(jafftn1) = j - else - jafffn1 = jafffn1 + 1 - jafff1(jafffn1) = j - endif - if( abs(iord).eq.2 .or. cosav(j) .lt. cos_van ) then - jafftn2 = jafftn2 + 1 - jafft2(jafftn2) = j - else - jafffn2 = jafffn2 + 1 - jafff2(jafffn2) = j - endif - endif - endif - enddo -!call ftrace_region_end("xtpv_1") - - imp = im + 1 - - do j = jlow, jhigh - do i=1,im - qtmpv(i,j) = qv(i,j) - enddo - enddo - -! Flux-Form Semi-Lagrangian transport - -!call ftrace_region_begin("xtpv_2") -!dir$ concurrent - do ja = 1, jatn - j = jat(ja) - -! Figure out ghost zone for the western edge: - iuwv(j) = -cv(1,j) - iuwv(j) = min(0, iuwv(j)) - - do i=iuwv(j), 0 - qtmpv(i,j) = qv(im+i,j) - enddo - -! Figure out ghost zone for the eastern edge: - iuev(j) = im - cv(im,j) - iuev(j) = max(imp, iuev(j)) - - do i=imp, iuev(j) - qtmpv(i,j) = qv(i-im,j) - enddo - - enddo -!call ftrace_region_end("xtpv_2") - -!dir$ concurrent -!call ftrace_region_begin("xtpv_3") - do ja = 1, jattn - j = jatt(ja) - - do i=1,im - iu = cv(i,j) - if(cv(i,j) .le. D0_0) then - itmp = i - iu - isave(i,j) = itmp - 1 - else - itmp = i - iu - 1 - isave(i,j) = itmp + 1 - endif - fxv(i,j) = (cv(i,j)-iu) * qtmpv(itmp,j) - enddo - - enddo -!call ftrace_region_end("xtpv_3") - -!dir$ concurrent -!call ftrace_region_begin("xtpv_4") - do ja = 1, jatfn - j = jatf(ja) - - do i=1,im -! 2nd order slope - tmp = D0_25*(qtmpv(i+1,j) - qtmpv(i-1,j)) - qmax = max(qtmpv(i-1,j), qtmpv(i,j), qtmpv(i+1,j)) - qtmpv(i,j) - qmin = qtmpv(i,j) - min(qtmpv(i-1,j), qtmpv(i,j), qtmpv(i+1,j)) - dmv(i,j) = sign(min(abs(tmp),qmax,qmin), tmp) - enddo - - do i=iuwv(j), 0 - dmv(i,j) = dmv(im+i,j) - enddo - - do i=imp, iuev(j) - dmv(i,j) = dmv(i-im,j) - enddo - - enddo -!call ftrace_region_end("xtpv_4") - - call fxppmv(im, cv, mfxv, qtmpv, dmv, fxv, iord, & - iuwv, iuev, ffslv, isave, jatftn, jatft, jlow, jhigh, & - jl2, jh2, jl3, jh3, jl5, jh5, jl7, jh7, jl11, jh11) - -!dir$ concurrent -!call ftrace_region_begin("xtpv_5") - do ja = 1, jatffn - j = jatff(ja) - - do i=1,im - iu = cv(i,j) - rut = cv(i,j) - iu - if(cv(i,j) .le. D0_0) then - itmp = i - iu - isave(i,j) = itmp - 1 - fxv(i,j) = rut*(qtmpv(itmp,j)-dmv(itmp,j)*(D1_0+rut)) - else - itmp = i - iu - 1 - isave(i,j) = itmp + 1 - fxv(i,j) = rut*(qtmpv(itmp,j)+dmv(itmp,j)*(D1_0-rut)) - endif - enddo - - enddo -!call ftrace_region_end("xtpv_5") - -!dir$ concurrent -!call ftrace_region_begin("xtpv_6") - do ja = 1, jatn - j = jat(ja) - qsum(iuwv(j)-1,j) = D0_0 - do i = iuwv(j), iuev(j) - qsum(i,j) = qsum(i-1,j) + qtmpv(i,j) - end do - -! -! The boolean terms: -! a) .and. (isave(i,j) < i) -! b) .and. (i <= isave(i,j)) -! are needed in the IF statements below because I cannot prove to myself -! that the relationship between i and isave are such to guarantee that -! there is always at least one term from qsum (qtmpv,j) contributed to fxv. -! - - do i=1,im - if(cv(i,j) >= D1_0 .and. (isave(i,j) < i) ) then - fxv(i,j) = fxv(i,j) + (qsum(i-1,j) - qsum(isave(i,j) - 1,j)) - else if (cv(i,j) <= -D1_0 .and. (i <= isave(i,j)) ) then - fxv(i,j) = fxv(i,j) - (qsum(isave(i,j),j) - qsum(i-1,j)) - end if - end do - - if(id .ne. 0) then - do i=1,im - fxv(i,j) = fxv(i,j)*mfxv(i,j) - enddo - endif - - enddo -!call ftrace_region_end("xtpv_6") - -! Regular PPM (Eulerian without FFSL extension) - -!call ftrace_region_begin("xtpv_7") -!dir$ concurrent -!cdir nodep - do ja = 1, jafn - j = jaf(ja) - - qtmpv(imp,j) = qv(1,j) - qtmpv( 0,j) = qv(im,j) - enddo - -!dir$ concurrent - do ja = 1, jaftn - j = jaft(ja) - - do i=1,im - iu = real(i,r8) - cv(i,j) - fxv(i,j) = mfxv(i,j)*qtmpv(iu,j) - enddo - enddo - -!dir$ concurrent -!cdir nodep - do ja = 1, jaffn - j = jaff(ja) - - qtmpv(-1,j) = qv(im-1,j) - qtmpv(imp+1,j) = qv(2,j) - - enddo -!call ftrace_region_end("xtpv_7") - -!dir$ concurrent -!call ftrace_region_begin("xtpv_8") - do ja = 1, jafftn1 - j = jafft1(ja) - -! In-line xmist - - do i=1,im - dmv(i,j) = r24*(D8_0*(qtmpv(i+1,j) - qtmpv(i-1,j)) + qtmpv(i-2,j) - qtmpv(i+2,j)) - enddo - -! Apply monotonicity constraint (Lin et al. 1994, MWR) - do i=1,im - qmax = max( qtmpv(i-1,j), qtmpv(i,j), qtmpv(i+1,j) ) - qtmpv(i,j) - qmin = qtmpv(i,j) - min( qtmpv(i-1,j), qtmpv(i,j), qtmpv(i+1,j) ) - dmv(i,j) = sign( min(abs(dmv(i,j)), qmax, qmin), dmv(i,j) ) - enddo - - enddo -!call ftrace_region_end("xtpv_8") - -!dir$ concurrent -!call ftrace_region_begin("xtpv_9") - do ja = 1, jafffn1 - j = jafff1(ja) - -! In-line xmist - - if(iord .le. 2) then - do i=1,im - dmv(i,j) = r24*(D8_0*(qtmpv(i+1,j) - qtmpv(i-1,j)) + qtmpv(i-2,j) - qtmpv(i+2,j)) - enddo - else - do i=1,im - dmv(i,j) = D0_25*(qtmpv(i+1,j) - qtmpv(i-1,j)) - enddo - endif - - if( iord >= 0 ) then - -! Apply monotonicity constraint (Lin et al. 1994, MWR) - do i=1,im - qmax = max( qtmpv(i-1,j), qtmpv(i,j), qtmpv(i+1,j) ) - qtmpv(i,j) - qmin = qtmpv(i,j) - min( qtmpv(i-1,j), qtmpv(i,j), qtmpv(i+1,j) ) - dmv(i,j) = sign( min(abs(dmv(i,j)), qmax, qmin), dmv(i,j) ) - enddo - endif - - enddo -!call ftrace_region_end("xtpv_9") - -!call ftrace_region_begin("xtpv_10") -!dir$ concurrent -!cdir nodep - do ja = 1, jaffn - j = jaff(ja) - - dmv(0,j) = dmv(im,j) - - enddo -!call ftrace_region_end("xtpv_10") - -!dir$ concurrent -!call ftrace_region_begin("xtpv_11") - do ja = 1, jafftn2 - j = jafft2(ja) - - do i=1,im - iu = real(i,r8) - cv(i,j) - fxv(i,j) = mfxv(i,j)*(qtmpv(iu,j)+dmv(iu,j)*(sign(D1_0,cv(i,j))-cv(i,j))) - enddo - - enddo -!call ftrace_region_end("xtpv_11") - - call fxppmv(im, cv, mfxv, qtmpv, dmv, fxv, iord, & - iuwv, iuev, ffslv, isave, jafffn2, jafff2, jlow, jhigh, & - jl2, jh2, jl3, jh3, jl5, jh5, jl7, jh7, jl11, jh11) - - return -!EOC - end subroutine xtpv -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: fxppmv -! -! !INTERFACE: - - subroutine fxppmv(im, c, mfx, p, dm, fx, iord, & - iuw, iue, ffsl, isave, jan, ja, jlow, jhigh, & - jl2, jh2, jl3, jh3, jl5, jh5, jl7, jh7, jl11, jh11) -!----------------------------------------------------------------------- -! -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer jan, ja(jan), jlow, jhigh, jj, j - integer jl2, jh2, jl3, jh3, jl5, jh5, jl7, jh7, jl11, jh11 - integer im, iord - real (r8) c(im,jl5:jh5) - real (r8) p(-im/3:im+im/3,jl11:jh11) - real (r8) dm(-im/3:im+im/3,jlow:jhigh) - real (r8) mfx(im,jl7:jh7) - integer iuw(jlow:jhigh), iue(jlow:jhigh) - logical ffsl(jl2:jh2) - integer isave(im,jlow:jhigh) - -! !OUTPUT PARAMETERS: - real (r8) fx(im,jl3:jh3) - -! !DESCRIPTION: -! -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real (r8) r3, r23 - parameter ( r3 = D1_0/D3_0, r23 = D2_0/D3_0 ) - - integer i, lmt - integer iu, itmp - real (r8) ru - logical steep - real (r8) al(-im/3:im+im/3,jlow:jhigh) - real (r8) ar(-im/3:im+im/3,jlow:jhigh) - real (r8) a6(-im/3:im+im/3,jlow:jhigh) - - integer jbtn, jbfn - integer jbt(jan), jbf(jan) - integer ilow, ihigh - - ilow = -im/3 - ihigh = im + im/3 - - if( iord == 6 ) then - steep = .true. - else - steep = .false. - endif - -!dir$ concurrent - do jj = 1, jan - j = ja(jj) - - do i=1,im - al(i,j) = D0_5*(p(i-1,j)+p(i,j)) + (dm(i-1,j) - dm(i,j))*r3 - enddo - - enddo - - if (steep) then - - call steepxv( im, p, al, dm, jan, ja, jlow, jhigh, jl11, jh11 ) - - endif - -!dir$ concurrent - do jj = 1, jan - j = ja(jj) - - do i=1,im-1 - ar(i,j) = al(i+1,j) - enddo - ar(im,j) = al(1,j) - - enddo - - if(iord == 7) then - - call huynhv(im, ar, al, p, a6, dm, jan, ja, jlow, jhigh, jl11, jh11 ) - - else - - if(iord .eq. 3 .or. iord .eq. 5) then - -!dir$ concurrent - do jj = 1, jan - j = ja(jj) - - do i=1,im - a6(i,j) = D3_0*(p(i,j)+p(i,j) - (al(i,j)+ar(i,j))) - enddo - - enddo - endif - - lmt = iord - 3 - - call lmppmv( dm, a6, ar, al, p, im, lmt, jan, ja, ilow, ihigh, & - jlow, jhigh, jl11, jh11 ) - - endif - - jbtn = 0 - jbfn = 0 -!dir$ concurrent - do jj = 1, jan - j = ja(jj) - if( ffsl(j) ) then - jbtn = jbtn + 1 - jbt(jbtn) = j - else - jbfn = jbfn + 1 - jbf(jbfn) = j - endif - enddo - -!dir$ concurrent - do jj = 1, jbtn - j = jbt(jj) - - do i=iuw(j), 0 - al(i,j) = al(im+i,j) - ar(i,j) = ar(im+i,j) - a6(i,j) = a6(im+i,j) - enddo - - do i=im+1, iue(j) - al(i,j) = al(i-im,j) - ar(i,j) = ar(i-im,j) - a6(i,j) = a6(i-im,j) - enddo - - do i=1,im - iu = c(i,j) - ru = c(i,j) - iu - if(c(i,j) .gt. D0_0) then - itmp = i - iu - 1 - isave(i,j) = itmp + 1 - fx(i,j) = ru*(ar(itmp,j)+D0_5*ru*(al(itmp,j)-ar(itmp,j) + & - a6(itmp,j)*(D1_0-r23*ru)) ) - else - itmp = i - iu - isave(i,j) = itmp - 1 - fx(i,j) = ru*(al(itmp,j)-D0_5*ru*(ar(itmp,j)-al(itmp,j) + & - a6(itmp,j)*(D1_0+r23*ru)) ) - endif - enddo - - enddo - -!dir$ concurrent - do jj = 1, jbfn - j = jbf(jj) - - al(0,j) = al(im,j) - ar(0,j) = ar(im,j) - a6(0,j) = a6(im,j) - do i=1,im - if(c(i,j) .gt. D0_0) then - fx(i,j) = ar(i-1,j) + D0_5*c(i,j)*(al(i-1,j) - ar(i-1,j) + & - a6(i-1,j)*(D1_0-r23*c(i,j)) ) - else - fx(i,j) = al(i,j) - D0_5*c(i,j)*(ar(i,j) - al(i,j) + & - a6(i,j)*(D1_0+r23*c(i,j))) - endif - fx(i,j) = mfx(i,j) * fx(i,j) - enddo - - enddo - - return -!EOC - end subroutine fxppmv -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: steepxv -! -! !INTERFACE: - subroutine steepxv(im, p, al, dm, jan, ja, jlow, jhigh, jl11, jh11 ) -!----------------------------------------------------------------------- - -! !USES: - implicit none - -! !INPUT PARAMETERS: - integer im - integer jan, ja(jan), jlow, jhigh, jl11, jh11 - real (r8) p(-im/3:im+im/3,jl11:jh11) - real (r8) dm(-im/3:im+im/3,jlow:jhigh) - -! !INPUT/OUTPUT PARAMETERS: - real (r8) al(im,jlow:jhigh) - -! !DESCRIPTION: -! -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i, jj, j - real (r8) r3 - parameter ( r3 = D1_0/D3_0 ) - - real (r8) dh(0:im,jlow:jhigh) - real (r8) d2(0:im+1,jlow:jhigh) - real (r8) eta(0:im,jlow:jhigh) - real (r8) xxx, bbb, ccc - -!dir$ concurrent - do jj = 1, jan - j = ja(jj) - - do i=0,im - dh(i,j) = p(i+1,j) - p(i,j) - enddo - -! Needs dh(0:im,j) - do i=1,im - d2(i,j) = dh(i,j) - dh(i-1,j) - enddo - d2(0,j) = d2(im,j) - d2(im+1,j) = d2(1,j) - -! needs p(-1:im+2,j), d2(0:im+1,j) - do i=1,im - if( d2(i+1,j)*d2(i-1,j).lt.D0_0 .and. p(i+1,j).ne.p(i-1,j) ) then - xxx = D1_0 - D0_5 * ( p(i+2,j) - p(i-2,j) ) / ( p(i+1,j) - p(i-1,j) ) - eta(i,j) = max(D0_0, min(xxx, D0_5) ) - else - eta(i,j) = D0_0 - endif - enddo - - eta(0,j) = eta(im,j) - -! needs eta(0:im,j), dh(0:im-1,j), dm(0:im,j) - do i=1,im - bbb = ( D2_0*eta(i,j ) - eta(i-1,j) ) * dm(i-1,j) - ccc = ( D2_0*eta(i-1,j) - eta(i,j ) ) * dm(i,j ) - al(i,j) = al(i,j) + D0_5*( eta(i-1,j) - eta(i,j)) * dh(i-1,j) + (bbb - ccc) * r3 - enddo - - enddo - - return -!EOC - end subroutine steepxv -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: huynhv --- Enforce Huynh's 2nd constraint in 1D periodic domain -! -! !INTERFACE: - subroutine huynhv(im, ar, al, p, d2, d1, jan, ja, jlow, jhigh, jl11, jh11) -!----------------------------------------------------------------------- - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - integer im - integer jan, ja(jan), jlow, jhigh, jl11, jh11 - real(r8) p(im,jl11:jh11) - -! !OUTPUT PARAMETERS: - real(r8) ar(im,jlow:jhigh) - real(r8) al(im,jlow:jhigh) - real(r8) d2(im,jlow:jhigh) - real(r8) d1(im,jlow:jhigh) - -! !DESCRIPTION: -! -! Enforce Huynh's 2nd constraint in 1D periodic domain -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - integer i, jj, j - real(r8) pmp - real(r8) lac - real(r8) pmin - real(r8) pmax - -!dir$ concurrent - do jj = 1, jan - j = ja(jj) - -! Compute d1 and d2 - d1(1,j) = p(1,j) - p(im,j) - do i=2,im - d1(i,j) = p(i,j) - p(i-1,j) - enddo - - do i=1,im-1 - d2(i,j) = d1(i+1,j) - d1(i,j) - enddo - d2(im,j) = d1(1,j) - d1(im,j) - -! Constraint for AR -! i = 1 - pmp = p(1,j) + D2_0 * d1(1,j) - lac = p(1,j) + D0_5 * (d1(1,j)+d2(im,j)) + d2(im,j) - pmin = min(p(1,j), pmp, lac) - pmax = max(p(1,j), pmp, lac) - ar(1,j) = min(pmax, max(ar(1,j), pmin)) - - do i=2, im - pmp = p(i,j) + D2_0*d1(i,j) - lac = p(i,j) + D0_5*(d1(i,j)+d2(i-1,j)) + d2(i-1,j) - pmin = min(p(i,j), pmp, lac) - pmax = max(p(i,j), pmp, lac) - ar(i,j) = min(pmax, max(ar(i,j), pmin)) - enddo - -! Constraint for AL - do i=1, im-1 - pmp = p(i,j) - D2_0*d1(i+1,j) - lac = p(i,j) + D0_5*(d2(i+1,j)-d1(i+1,j)) + d2(i+1,j) - pmin = min(p(i,j), pmp, lac) - pmax = max(p(i,j), pmp, lac) - al(i,j) = min(pmax, max(al(i,j), pmin)) - enddo - -! i=im - i = im - pmp = p(im,j) - D2_0*d1(1,j) - lac = p(im,j) + D0_5*(d2(1,j)-d1(1,j)) + d2(1,j) - pmin = min(p(im,j), pmp, lac) - pmax = max(p(im,j), pmp, lac) - al(im,j) = min(pmax, max(al(im,j), pmin)) - -! compute A6 (d2) - do i=1, im - d2(i,j) = D3_0*(p(i,j)+p(i,j) - (al(i,j)+ar(i,j))) - enddo - - enddo - - return -!EOC - end subroutine huynhv -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: lmppmv -! -! !INTERFACE: - subroutine lmppmv(dm, a6, ar, al, p, im, lmt, jan, ja, & - ilow, ihigh, jlow, jhigh, jl11, jh11) -!----------------------------------------------------------------------- - - implicit none - -! !INPUT PARAMETERS: - integer im ! Total longitudes - integer jan, ja(jan), ilow, ihigh, jlow, jhigh, jl11, jh11 - integer lmt ! LMT = 0: full monotonicity - ! LMT = 1: Improved and simplified full monotonic constraint - ! LMT = 2: positive-definite constraint - ! LMT = 3: Quasi-monotone constraint - real(r8) p(ilow:ihigh,jl11:jh11) - real(r8) dm(ilow:ihigh,jlow:jhigh) - -! !OUTPUT PARAMETERS: - real(r8) a6(ilow:ihigh,jlow:jhigh) - real(r8) ar(ilow:ihigh,jlow:jhigh) - real(r8) al(ilow:ihigh,jlow:jhigh) - -! !DESCRIPTION: -! -! -! !REVISION HISTORY: -! 99.01.01 Lin Creation -! 01.03.27 Sawyer Additional ProTeX documentation -! -!EOP -!----------------------------------------------------------------------- -!BOC -! -! !LOCAL VARIABLES: - real (r8) r12 - parameter ( r12 = D1_0/D12_0 ) - - real (r8) da1, da2, fmin, a6da - real (r8) dr, dl - - integer i, jj, j - -! LMT = 0: full monotonicity -! LMT = 1: Improved and simplified full monotonic constraint -! LMT = 2: positive-definite constraint -! LMT = 3: Quasi-monotone constraint - - if( lmt == 0 ) then - -! Full constraint - -!dir$ concurrent - do jj = 1, jan - j = ja(jj) - - do i=1,im - if(dm(i,j) .eq. D0_0) then - ar(i,j) = p(i,j) - al(i,j) = p(i,j) - a6(i,j) = D0_0 - else - da1 = ar(i,j) - al(i,j) - da2 = da1**2 - a6da = a6(i,j)*da1 - if(a6da .lt. -da2) then - a6(i,j) = D3_0*(al(i,j)-p(i,j)) - ar(i,j) = al(i,j) - a6(i,j) - elseif(a6da .gt. da2) then - a6(i,j) = D3_0*(ar(i,j)-p(i,j)) - al(i,j) = ar(i,j) - a6(i,j) - endif - endif - enddo - - enddo - - elseif( lmt == 1 ) then - -! Improved (Lin 2001?) full constraint - -!dir$ concurrent - do jj = 1, jan - j = ja(jj) - - do i=1,im - da1 = dm(i,j) + dm(i,j) - dl = sign(min(abs(da1),abs(al(i,j)-p(i,j))), da1) - dr = sign(min(abs(da1),abs(ar(i,j)-p(i,j))), da1) - ar(i,j) = p(i,j) + dr - al(i,j) = p(i,j) - dl - a6(i,j) = D3_0*(dl-dr) - enddo - - enddo - - elseif( lmt == 2 ) then - -! Positive definite constraint - -!dir$ concurrent - do jj = 1, jan - j = ja(jj) - - do i=1,im - if(abs(ar(i,j)-al(i,j)) .lt. -a6(i,j)) then - fmin = p(i,j) + D0_25*(ar(i,j)-al(i,j))**2/a6(i,j) + a6(i,j)*r12 - if(fmin.lt.D0_0) then - if(p(i,j).lt.ar(i,j) .and. p(i,j).lt.al(i,j)) then - ar(i,j) = p(i,j) - al(i,j) = p(i,j) - a6(i,j) = D0_0 - elseif(ar(i,j) .gt. al(i,j)) then - a6(i,j) = D3_0*(al(i,j)-p(i,j)) - ar(i,j) = al(i,j) - a6(i,j) - else - a6(i,j) = D3_0*(ar(i,j)-p(i,j)) - al(i,j) = ar(i,j) - a6(i,j) - endif - endif - endif - enddo - - enddo - - elseif(lmt .eq. 3) then - -! Quasi-monotone constraint - -!dir$ concurrent - do jj = 1, jan - j = ja(jj) - - do i=1,im - da1 = D4_0*dm(i,j) - dl = sign(min(abs(da1),abs(al(i,j)-p(i,j))), da1) - dr = sign(min(abs(da1),abs(ar(i,j)-p(i,j))), da1) - ar(i,j) = p(i,j) + dr - al(i,j) = p(i,j) - dl - a6(i,j) = D3_0*(dl-dr) - enddo - - enddo - - endif - return -!EOC - end subroutine lmppmv -!----------------------------------------------------------------------- -#endif - -end module tp_core diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/trac2d.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/trac2d.F90 deleted file mode 100644 index 01e23a645..000000000 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/FVdycore_GridComp/trac2d.F90 +++ /dev/null @@ -1,455 +0,0 @@ -!----------------------------------------------------------------------- -!BOP -! !ROUTINE: trac2d --- Remap Lagrangian to fixed coordinates -! -! !INTERFACE: - subroutine trac2d( grid, dp1, tracer, cx, cy, & - mfx, mfy, iord, jord, fill, & - va, flx ) - -! !USES: - - use shr_kind_mod, only : r8 => shr_kind_r8, r4 => shr_kind_r4 - use tp_core, only : tp2c - use fill_module, only : fillxy - use dynamics_vars, only : T_FVDYCORE_GRID, T_TRACERS - use FVperf_module, only : FVstartclock, FVstopclock, FVbarrierclock - -#if defined( SPMD ) - use parutilitiesmodule, only: maxop, parcollective - use mod_comm, only : commglobal, mp_send4d_ns, mp_recv4d_ns, & - mp_send3d_2, mp_recv3d_2 -#endif - - implicit none - -! !INPUT PARAMETERS: - - type (T_FVDYCORE_GRID), intent(inout) :: grid - integer, intent(in):: iord, jord - - logical, intent(in):: fill - -! !INPUT/OUTPUT PARAMETERS: - real(r8), intent(inout):: dp1(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - real(r8), intent(inout):: cx(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) - real(r8), intent(inout):: cy(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) - real(r8), intent(inout):: mfx(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - real(r8), intent(inout):: mfy(grid%im,grid%jfirst:grid%jlast+1,grid%kfirst:grid%klast) - type(T_TRACERS), intent(inout):: tracer(grid%ntotq) - -! !OUTPUT PARAMETERS: - real(r8), intent(out):: va(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - real(r8), intent(out):: flx(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - -! !DESCRIPTION: -! -! Perform large-time-step tracer transport using accumulated Courant -! numbers (cx, cy) and the mass fluxes (mfx, mfy) within the Lagrangian -! layers. This routine is 100\% parallel in the vertical direction -! (with SMP). Merdional Courant number will be further split, if -! necessary, to ensure stability. Cy <= 1 away from poles; Cy $\le$ -! 1/2 at the latitudes closest to the poles. -! -! !REVISION HISTORY: -! -! SJL 99.04.13: Delivery -! WS 99.05.26: Added jfirst:jlast concept; im, jm, km as parameters -! replaced IMR, JMR, JNP, NL with IM, JM-1, JM and KM -! WS 99.09.27: Documentation; indentation; jfirst:jlast -! WS 99.09.30: Ghosting; loop limits; full parallelization; tested -! SJL 99.10.15: nsplt migrated to outermost loop to remove bug -! SJL 99.12.19: Local 2D arrays trimmed! -! WS 00.05.14: Renamed ghost indices as per Kevin's definitions -! WS 00.07.13: Changed PILGRIM API -! AAM 00.08.29: Added kfirst, klast -! AAM 01.06.27: Added y communicators -! SJL 30.07.01: MPI optimization/simplification -! WS 02.04.24: New mod_comm interfaces -! WS 02.07.04: Fixed 2D decomposition bug dest/src for mp_send3d -! WS 03.11.19: Merged in CAM changes by Mirin -! WS 03.12.03: Added GRID as argument, dynamics_vars removed -! WS 04.08.25: Simplification of interface with GRID -! WS 04.10.07: Removed dependency on spmd_dyn; info now in GRID -! WS 05.04.04: Transitioned to type T_TRACERS (supports r4 and r8) -! WS 05.04.09: Each tracer now ghosted individually (save buffers) -! WS 05.04.12: Full support for either r4 or r8 tracers -! WS 05.05.25: Merged CAM and GEOS5, e.g. nsplt(k) opt. in CAM -! PW 05.10.12: Changes for Cray X1(E), alternative implementation -! of double buffering logic -! WS 06.09.08: Magic numbers are now F90 parameters -! WP 07.04.19: Modified interface to tp2c to support new filtering options -! WS 09.04.01: Upgraded to PILGRIM from cam3_6_33 -! -!EOP -!--------------------------------------------------------------------- -!BOC - - real(r8), parameter :: D1EM10 = 1.0e-10_r8 - real(r8), parameter :: D1_0 = 1.0_r8 - real(r8), parameter :: D0_0 = 0.0_r8 - -! Local variables: -! 2d arrays - real(r8) a2(grid%im,grid%jfirst:grid%jlast) - real(r8) fx(grid%im,grid%jfirst:grid%jlast) - real(r8) fy(grid%im,grid%jfirst:grid%jlast+1) - real(r8) cymax(grid%kfirst:grid%klast) -! Temporary r8 array for Q - real(r8) :: & - q_r8(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast,1:2) - - real(r8) dp2(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) - logical ffsl(grid%jm,grid%kfirst:grid%klast) - integer :: nsplt(grid%kfirst:grid%klast) - - integer :: im, jm, km ! Dimensions - integer :: nq ! # of advected tracers - integer :: ng ! Max number of ghost latitudes - integer :: jfirst, jlast, kfirst, klast ! YZ decomposition limits - integer :: cur, nxt ! current and next q_r8 buffer indices - - integer i, j, k - integer it, iq, kq, max_nsplt - integer :: k_courant, kend - integer ktot - integer js1gd, js2g0, js2gd, jn2g0,jn2gd,jn1g1,jn1gd -#if defined( SPMD ) - integer :: dest, src -#endif - - real(r8) cy_global - real(r8) frac - real(r8) cmax - real(r8) sum1, sum2 - - cur = 1 - nxt = 2 - - im = grid%im - jm = grid%jm - km = grid%km - nq = grid%nq - ng = grid%ng_d - - jfirst = grid%jfirst - jlast = grid%jlast - kfirst = grid%kfirst - klast = grid%klast - - ktot = klast - kfirst + 1 - js2g0 = max(2,jfirst) - jn2g0 = min(jm-1,jlast) - jn1g1 = min(jm,jlast+1) - js1gd = max(1,jfirst-ng) ! NG latitudes on S (starting at 1) - js2gd = max(2,jfirst-ng) ! NG latitudes on S (starting at 2) - jn2gd = min(jm-1,jlast+ng) ! NG latitudes on S (ending at jm-1) - jn1gd = min(jm,jlast+ng) ! NG latitudes on N (ending at jm) - -#if defined( SPMD ) - call FVstartclock(grid,'---TRAC2D_COMM') - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng, ng, cx ) -! Send one latitude of both cy and mfy to the south - dest = grid%iam-1 - src = grid%iam+1 - if ( mod(grid%iam,grid%npr_y) == 0 ) dest = -1 - if ( mod(grid%iam+1,grid%npr_y) == 0 ) src = -1 - call mp_send3d_2( commglobal, dest, src, im, jm, km, & - 1, im, jfirst, jlast+1, kfirst, klast, & - 1, im, jfirst, jfirst, kfirst, klast, cy, mfy) - call FVstopclock(grid,'---TRAC2D_COMM') -#endif - -!$omp parallel do default(shared) private(i,j,k,cmax) - do k=kfirst,klast - cymax(k) = D0_0 - do j=js2g0,jlast - cmax = D0_0 - do i=1,im - cmax = max( abs(cy(i,j,k)), cmax) - enddo - cymax(k) = max(cymax(k), cmax*(D1_0 + grid%sine(j)**16) ) - enddo - enddo - -#if defined( SPMD ) - call FVstartclock(grid,'---TRAC2D_COMM') - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, klast, ng, ng, cx ) - call mp_recv3d_2( commglobal, src, im, jm, km, & - 1, im, jfirst, jlast+1, kfirst, klast, & - 1, im, jlast+1, jlast+1, kfirst, klast, cy, mfy) - - call parcollective( grid%comm_y, MAXOP, ktot, cymax ) - call FVstopclock(grid,'---TRAC2D_COMM') -#endif - -!--------------------------------------------------------------------- -! Determine the required value of nsplt for each level -!--------------------------------------------------------------------- - nsplt(:) = int( D1_0 + cymax(:) ) - max_nsplt = maxval( nsplt(:) ) -#if defined( SPMD ) - call FVstartclock(grid,'---TRAC2D_COMM') - call parcollective( grid%comm_z, MAXOP, max_nsplt ) ! Find global max - call FVstopclock(grid,'---TRAC2D_COMM') -#endif -#ifndef WACCM_MOZART - nsplt(:) = max_nsplt -#endif - do k_courant = klast,kfirst,-1 - if( nsplt(k_courant) > 1 ) then - exit - end if - end do - k_courant = max( kfirst,k_courant ) -!!! if (max_nsplt /= 1) write(*,*) 'trac2d: max_nsplt,k_courant = ', max_nsplt,k_courant -!!! print *, "max_nsplt", max_nsplt, "k_cour", k_courant, "nsplt", nsplt(:) - -!$omp parallel do default(shared) private(i,j,k,frac) schedule(dynamic,1) - -#if !defined(USE_OMP) -!CSD$ PARALLEL DO PRIVATE (I, J, K, FRAC) -#endif - do 4000 k=kfirst,klast - - if( nsplt(k) .ne. 1 ) then - frac = D1_0 / nsplt(k) - do j=js2gd,jn2gd - do i=1,im - cx(i,j,k) = cx(i,j,k) * frac ! cx ghosted on N*ng S*ng - enddo - enddo - - do j=js2g0,jn2g0 - do i=1,im - mfx(i,j,k) = mfx(i,j,k) * frac - enddo - enddo - - do j=js2g0,jn1g1 - do i=1,im - cy(i,j,k) = cy(i,j,k) * frac ! cy ghosted on N - mfy(i,j,k) = mfy(i,j,k) * frac ! mfy ghosted on N - enddo - enddo - endif - - do j=js2g0,jn2g0 - do i=1,im - if(cy(i,j,k)*cy(i,j+1,k) > D0_0) then - if( cy(i,j,k) > D0_0) then - va(i,j,k) = cy(i,j,k) - else - va(i,j,k) = cy(i,j+1,k) ! cy ghosted on N - endif - else - va(i,j,k) = D0_0 - endif - enddo - enddo - -! Check if FFSL extension is needed. - - do j=js2gd,jn2gd ! flux needed on N*ng S*ng - ffsl(j,k) = .false. - do i=1,im - if( abs(cx(i,j,k)) > D1_0 ) then ! cx ghosted on N*ng S*ng - ffsl(j,k) = .true. - exit - endif - enddo - enddo - -! Scale E-W mass fluxes by CX if FFSL - do j=js2g0,jn2g0 - if( ffsl(j,k) ) then - do i=1,im - flx(i,j,k) = mfx(i,j,k) / sign( max(abs(cx(i,j,k)), D1EM10), & - cx(i,j,k) ) - enddo - else - do i=1,im - flx(i,j,k) = mfx(i,j,k) - enddo - endif - enddo -4000 continue -#if !defined(USE_OMP) -!CSD$ END PARALLEL DO -#endif - - call FVbarrierclock(grid,'sync_trac2d_tracer') - call FVstartclock(grid,'---TRAC2D_TRACER') - - do 6000 it=1, max_nsplt - if ( it == 1 ) then - kend = klast ! The entire vertical slab needs to be considered - else - kend = k_courant ! Only the subset including courant # > 1 considered - endif -! WS 05.04.06: send only the first tracer the rest at end of do iq loop -! NOTE: there is per definition at least one tracer - if ( tracer(1)%is_r4 ) then - q_r8(1:im,jfirst:jlast,kfirst:kend,1) = & - tracer(1)%content_r4(1:im,jfirst:jlast,kfirst:kend) - else - q_r8(1:im,jfirst:jlast,kfirst:kend,1) = & - tracer(1)%content(1:im,jfirst:jlast,kfirst:kend) - endif -#if defined( SPMD ) - call FVstartclock(grid,'----TRAC2D_TRACER_COMM') - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, kend, ng, ng, q_r8(1,jfirst-ng,kfirst,1) ) - call FVstopclock(grid,'----TRAC2D_TRACER_COMM') -#endif - -!$omp parallel do default(shared) private(i,j,k,sum1,sum2) - - do 3000 k=kfirst,kend - if (it <= nsplt(k)) then - do j=js2g0,jn2g0 - do i=1,im-1 - dp2(i,j,k) = dp1(i,j,k) + mfx(i,j,k) - mfx(i+1,j,k) + & - (mfy(i,j,k) - mfy(i,j+1,k)) * grid%acosp(j) - enddo - dp2(im,j,k) = dp1(im,j,k) + mfx(im,j,k) - mfx(1,j,k) + & - (mfy(im,j,k) - mfy(im,j+1,k)) * grid%acosp(j) - enddo - - if ( jfirst == 1 ) then - sum1 = D0_0 - do i=1,im - sum1 = sum1 + mfy(i,2,k) - end do - - sum1 = - sum1 * grid%rcap - do i=1,im - dp2(i,1,k) = dp1(i,1,k) + sum1 - enddo - endif - - if ( jlast == jm ) then - sum2 = D0_0 - do i=1,im - sum2 = sum2 + mfy(i,jm,k) - end do - - sum2 = sum2 * grid%rcap - do i=1,im - dp2(i,jm,k) = dp1(i,jm,k) + sum2 - enddo - endif - endif -3000 continue - - do iq = 1, nq -#if defined( SPMD ) - call FVstartclock(grid,'----TRAC2D_TRACER_COMM') -! -! The buffer indices are exchanged, so that cur points to the current buffer, -! while nxt points to the one which will be used next. -! - if ( mod(iq,2) == 0 ) then - cur = 2 - nxt = 1 - else - cur = 1 - nxt = 2 - endif - call mp_recv4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, & - kfirst, kend, ng, ng, q_r8(1,jfirst-ng,kfirst,cur) ) - -! -! Pre-send the next tracer -! - if ( iq < nq ) then - if ( tracer(iq+1)%is_r4 ) then - q_r8(1:im,jfirst:jlast,kfirst:kend,nxt) = & - tracer(iq+1)%content_r4(1:im,jfirst:jlast,kfirst:kend) - else - q_r8(1:im,jfirst:jlast,kfirst:kend,nxt) = & - tracer(iq+1)%content(1:im,jfirst:jlast,kfirst:kend) - endif - call mp_send4d_ns( commglobal, im, jm, km, 1, jfirst, jlast, kfirst, & - kend, ng, ng, q_r8(1,jfirst-ng,kfirst,nxt) ) - endif - call FVstopclock(grid,'----TRAC2D_TRACER_COMM') -#else -! -! No message passing -- simply copy the tracer into q_r8 -! - if ( tracer(iq)%is_r4 ) then - q_r8(1:im,jfirst:jlast,kfirst:kend,cur) = & - tracer(iq)%content_r4(1:im,jfirst:jlast,kfirst:kend) - else - q_r8(1:im,jfirst:jlast,kfirst:kend,cur) = & - tracer(iq)%content(1:im,jfirst:jlast,kfirst:kend) - endif -#endif - -!$omp parallel do default(shared) & -!$omp private(i, j, k, kq, fx, fy, a2) -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ PARALLEL DO PRIVATE (I, J, K, KQ, FX, FY, A2) -#endif - do 5000 k=kfirst,kend - if ( it <= nsplt(k) ) then - call tp2c(a2, va(1,jfirst,k), q_r8(1:,jfirst-ng:,k,cur), & - cx(1,jfirst-ng,k) , cy(1,jfirst,k), & - im, jm, iord, jord, ng, & - fx, fy, ffsl(1,k), grid%rcap, grid%acosp, & - flx(1,jfirst,k), mfy(1,jfirst,k), & - grid%cosp, 1, jfirst, jlast) - - do j=jfirst,jlast - do i=1,im - q_r8(i,j,k,cur) = q_r8(i,j,k,cur)*dp1(i,j,k) + a2(i,j) - enddo - enddo - - if (fill) call fillxy (q_r8(1:,jfirst:,k,cur), im, jm, jfirst, & - jlast, grid%acap, grid%cosp, grid%acosp) - - if ( tracer(iq)%is_r4 ) then - do j=jfirst,jlast - do i=1,im - tracer(iq)%content_r4(i,j,k) = q_r8(i,j,k,cur) / dp2(i,j,k) - enddo - enddo - else - do j=jfirst,jlast - do i=1,im - tracer(iq)%content(i,j,k) = q_r8(i,j,k,cur) / dp2(i,j,k) - enddo - enddo - endif - endif -5000 continue -#if (!defined USE_OMP) && (!defined COUP_CSM) -!CSD$ END PARALLEL DO -#endif - - enddo ! End of do iq=1, nq - -!$omp parallel do private(i, j, k) schedule( dynamic,1 ) - do k=kfirst,kend - if ( it <= nsplt(k) ) then - do j=jfirst,jlast - do i=1,im - dp1(i,j,k) = dp2(i,j,k) - enddo - enddo - endif - enddo - -6000 continue - call FVstopclock(grid,'---TRAC2D_TRACER') - - return -!EOC - end subroutine trac2d -!----------------------------------------------------------------------- - -