From 6cc3fa696737bd0f630d2e487003aa755a7e5e7d Mon Sep 17 00:00:00 2001 From: "Xuesong (Steve)" Date: Tue, 28 Aug 2018 00:47:55 -0400 Subject: [PATCH] Add files via upload --- code/XSEC1D.f | 16 + code/XSECO2.f | 16 + code/XSECO3.f | 16 + code/tcorr.f | 44 + code/toms_mod.f | 372 +++ code/tpcore_bc_mod.f | 2068 ++++++++++++ code/tpcore_bc_mod.f~ | 2068 ++++++++++++ code/tpcore_fvdas_mod.f90 | 6595 +++++++++++++++++++++++++++++++++++++ code/tpcore_mod.f | 4237 ++++++++++++++++++++++++ code/tpcore_window_mod.f | 4838 +++++++++++++++++++++++++++ code/tracerid_mod.f | 1719 ++++++++++ code/transfer_mod.f | 1674 ++++++++++ code/tropopause.f | 90 + code/tropopause_mod.f | 692 ++++ code/unix_cmds_mod.f | 49 + code/update.f | 105 + code/uvalbedo_mod.f | 175 + code/vistas_anthro_mod.f | 582 ++++ code/xltmmp.f | 49 + code/xtra_read_mod.f | 664 ++++ 20 files changed, 26069 insertions(+) create mode 100644 code/XSEC1D.f create mode 100644 code/XSECO2.f create mode 100644 code/XSECO3.f create mode 100644 code/tcorr.f create mode 100644 code/toms_mod.f create mode 100644 code/tpcore_bc_mod.f create mode 100644 code/tpcore_bc_mod.f~ create mode 100644 code/tpcore_fvdas_mod.f90 create mode 100644 code/tpcore_mod.f create mode 100644 code/tpcore_window_mod.f create mode 100644 code/tracerid_mod.f create mode 100644 code/transfer_mod.f create mode 100644 code/tropopause.f create mode 100644 code/tropopause_mod.f create mode 100644 code/unix_cmds_mod.f create mode 100644 code/update.f create mode 100644 code/uvalbedo_mod.f create mode 100644 code/vistas_anthro_mod.f create mode 100644 code/xltmmp.f create mode 100644 code/xtra_read_mod.f diff --git a/code/XSEC1D.f b/code/XSEC1D.f new file mode 100644 index 0000000..b38fe4a --- /dev/null +++ b/code/XSEC1D.f @@ -0,0 +1,16 @@ +C $Id: XSEC1D.f,v 1.1 2009/06/09 21:51:54 daven Exp $ + FUNCTION XSEC1D(K,TTT) +C----------------------------------------------------------------------- +c Quantum yields for O3 --> O2 + O(1D) interpolated across 3 temps +C----------------------------------------------------------------------- + IMPLICIT NONE + +# include "cmn_fj.h" +# include "jv_cmn.h" + + integer k + real*8 ttt, flint, xsec1d + XSEC1D = + F FLINT(TTT,TQQ(1,3),TQQ(2,3),TQQ(3,3),Q1D(K,1),Q1D(K,2),Q1D(K,3)) + return + end diff --git a/code/XSECO2.f b/code/XSECO2.f new file mode 100644 index 0000000..1fb2f5c --- /dev/null +++ b/code/XSECO2.f @@ -0,0 +1,16 @@ +C $Id: XSECO2.f,v 1.1 2009/06/09 21:51:52 daven Exp $ + FUNCTION XSECO2(K,TTT) +C----------------------------------------------------------------------- +c Cross-sections for O2 interpolated across 3 temps; No S_R Bands yet! +C----------------------------------------------------------------------- + IMPLICIT NONE + +# include "cmn_fj.h" +# include "jv_cmn.h" + + integer k + real*8 ttt, flint, xseco2 + XSECO2 = + F FLINT(TTT,TQQ(1,1),TQQ(2,1),TQQ(3,1),QO2(K,1),QO2(K,2),QO2(K,3)) + return + end diff --git a/code/XSECO3.f b/code/XSECO3.f new file mode 100644 index 0000000..2f5f0df --- /dev/null +++ b/code/XSECO3.f @@ -0,0 +1,16 @@ +C $Id: XSECO3.f,v 1.1 2009/06/09 21:51:52 daven Exp $ + FUNCTION XSECO3(K,TTT) +C----------------------------------------------------------------------- +c Cross-sections for O3 for all processes interpolated across 3 temps +C----------------------------------------------------------------------- + IMPLICIT NONE + +# include "cmn_fj.h" +# include "jv_cmn.h" + + integer k + real*8 ttt, flint, xseco3 + XSECO3 = + F FLINT(TTT,TQQ(1,2),TQQ(2,2),TQQ(3,2),QO3(K,1),QO3(K,2),QO3(K,3)) + return + end diff --git a/code/tcorr.f b/code/tcorr.f new file mode 100644 index 0000000..6f68331 --- /dev/null +++ b/code/tcorr.f @@ -0,0 +1,44 @@ +! $Id: tcorr.f,v 1.1 2009/06/09 21:51:52 daven Exp $ + FUNCTION TCORR( TEMP ) +! +!****************************************************************************** +! Function TCORR applies the temperature correction for isoprene emissions, +! according to Guenther et al.(92) (yhw, 11/15/93; bmy, 4/4/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) TEMP (REAL*8) : Temperature [K] +! +! References: +! ============================================================================ +! Guenther et al, 1992, ... +! +! NOTES: +! (1 ) Removed DATA statements, replaced w/ F90 syntax. Updated comments +! and made cosmetic changes (bmy, 4/4/03) +!****************************************************************************** +! + IMPLICIT NONE + + ! Arguments + REAL*8, INTENT(IN) :: TEMP + + ! Local variables + REAL*8, PARAMETER :: R = 8.314 + REAL*8, PARAMETER :: CT1 = 95000. + REAL*8, PARAMETER :: CT2 = 230000. + REAL*8, PARAMETER :: T1 = 303. + REAL*8, PARAMETER :: T3 = 314. + + ! Function value + REAL*8 :: TCORR + + !================================================================= + ! TCORR begins here! + !================================================================= + TCORR = + & EXP( CT1/(R*T1*TEMP) * (TEMP-T1) ) / + & ( 1 + EXP( CT2/(R*T1*TEMP) * (TEMP-T3) ) ) + + ! Return to calling program + END FUNCTION TCORR diff --git a/code/toms_mod.f b/code/toms_mod.f new file mode 100644 index 0000000..844abfb --- /dev/null +++ b/code/toms_mod.f @@ -0,0 +1,372 @@ +!$Id: toms_mod.f,v 1.2 2012/03/01 22:00:26 daven Exp $ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: toms_mod +! +! !DESCRIPTION: Module TOMS\_MOD contains variables and routines for reading +! the TOMS/SBUV O3 column data from disk (for use w/ the FAST-J photolysis +! routines). +!\\ +!\\ +! !INTERFACE: +! + MODULE TOMS_MOD +! +! !USES: +! + IMPLICIT NONE +# include "define.h" + PRIVATE +! +! !PUBLIC DATA MEMBERS: +! + REAL*8, PUBLIC, ALLOCATABLE :: TOMS(:,:) + REAL*8, PUBLIC, ALLOCATABLE :: DTOMS1(:,:) + REAL*8, PUBLIC, ALLOCATABLE :: DTOMS2(:,:) +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: CLEANUP_TOMS + PUBLIC :: READ_TOMS + ! First & last years for which TOMS/SBUV data is is available + ! (update these as new data is added to the archive) + INTEGER, PUBLIC, PARAMETER :: FIRST_TOMS_YEAR = 1979 +#if defined( GRID4x5 ) || defined( GRID2x25 ) || defined( GRID025x03125 ) + INTEGER, PUBLIC, PARAMETER :: LAST_TOMS_YEAR = 2010 +#else + INTEGER, PUBLIC, PARAMETER :: LAST_TOMS_YEAR = 2008 +#endif + + + +! +! !PRIVATE MEMBER FUNCTIONS: +! + PRIVATE :: INIT_TOMS +! +! !REMARKS: +! References: +! ============================================================================ +! TOMS/SBUV MERGED TOTAL OZONE DATA, Version 8, Revision 3. +! Resolution: 5 x 10 deg. +! +! Source: http://code916.gsfc.nasa.gov/Data_services/merged/index.html +! +! Contact person for the merged data product: +! Stacey Hollandsworth Frith (smh@hyperion.gsfc.nasa.gov) +! +! !REVISION HISTORY: +! 14 Jul 2003 - R. Yantosca - Initial version +! (1 ) Now references "directory_mod.f" (bmy, 7/20/04) +! (2 ) Now can read files for GEOS or GCAP grids (bmy, 8/16/05) +! (3 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (4 ) Now always use 2002 TOMS O3 data for GCAP (swu, bmy, 10/3/06) +! (5 ) Now reads from TOMS_200701 directory, w/ updated data (bmy, 2/1/07) +! (6 ) Now don't replace any tokens in the DATA_DIR variable (bmy, 12/5/07) +! (7 ) Latest year of TOMS data is now 2007 (bmy, 1/14/09) +! 01 Dec 2010 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC + CONTAINS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: read_toms +! +! !DESCRIPTION: Subroutine READ\_TOMS reads in TOMS O3 column data from a +! binary punch file for the given grid, month and year. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE READ_TOMS( THISMONTH, THISYEAR ) +! +! !USES: +! + USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D + USE BPCH2_MOD, ONLY : GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0 + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRANSFER_MOD, ONLY : TRANSFER_2D + + !USE CMN_SIZE_MOD ! Size parameters +# include "CMN_SIZE" +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: THISMONTH ! Current month + INTEGER, INTENT(IN) :: THISYEAR ! Current year +! +! !REMARKS: +! TOMS/SBUV MERGED TOTAL OZONE DATA, Version 8, Revision 3. +! Resolution: 5 x 10 deg. +! . +! Methodology (bmy, 2/12/07) +! ---------------------------------------------------------------- +! FAST-J comes with its own default O3 column climatology (from +! McPeters 1992 & Nagatani 1991), which is stored in the input +! file "jv_atms.dat". These "FAST-J default" O3 columns are used +! in the computation of the actinic flux and other optical +! quantities for the FAST-J photolysis. +! . +! The TOMS/SBUV O3 columns and 1/2-monthly O3 trends (contained +! in the TOMS_200701 directory) are read into GEOS-Chem by routine +! READ_TOMS in "toms_mod.f". Missing values (i.e. locations where +! there are no data) in the TOMS/SBUV O3 columns are defined by +! the flag -999. +! . +! After being read from disk in routine READ_TOMS, the TOMS/SBUV +! O3 data are then passed to the FAST-J routine "set_prof.f". In +! "set_prof.f", a test is done to make sure that the TOMS/SBUV O3 +! columns and 1/2-monthly trends do not have any missing values +! for (lat,lon) location for the given month. If so, then the +! TOMS/SBUV O3 column data is interpolated to the current day and +! is used to weight the "FAST-J default" O3 column. This +! essentially "forces" the "FAST-J default" O3 column values to +! better match the observations, as defined by TOMS/SBUV. +! . +! If there are no TOMS/SBUV O3 columns (and 1/2-monthly trends) +! at a (lat,lon) location for given month, then FAST-J will revert +! to its own "default" climatology for that location and month. +! Therefore, the TOMS O3 can be thought of as an "overlay" data +! -- it is only used if it exists. +! . +! Note that there are no TOMS/SBUV O3 columns at the higher +! latitudes. At these latitudes, the code will revert to using +! the "FAST-J default" O3 columns. +! . +! As of February 2007, we have TOMS/SBUV data for 1979 thru 2005. +! 2006 TOMS/SBUV data is incomplete as of this writing. For years +! 2006 and onward, we use 2005 TOMS O3 columns. +! . +! This methodology was originally adopted by Mat Evans. Symeon +! Koumoutsaris was responsible for creating the downloading and +! processing the TOMS O3 data files from 1979 thru 2005 in the +! TOMS_200701 directory. +! +! !REVISION HISTORY: +! 10 Dec 2002 - M. Evans - Initial version +! (1 ) Bundled into "toms_mod.f" (bmy, 7/14/03) +! (2 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +! (3 ) Now can read files for GEOS or GCAP grids (bmy, 8/16/05) +! (4 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (5 ) Now always use 2002 TOMS O3 data for GCAP (swu, bmy, 10/3/06) +! (6 ) Now reads from TOMS_200701 directory, w/ updated data. Also always +! use 1979 data prior to 1979 or 2005 data after 2005. (bmy, 2/12/07) +! (7 ) Bug fix: don't include DATA_DIR in filename, just in case someone's +! file path has replaceable tokens (e.g. hh, mm, MM etc.) (bmy, 12/5/07) +! (8 ) Latest year of TOMS data is now 2007 (bmy, 1/14/09) +! (9 ) Updated TOMS data in TOMS_200906. Latest year is 2008. (ccc, 6/15/09) +! 08 Dec 2009 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL :: FIRST = .TRUE. + INTEGER :: YYYYMMDD, YEAR + REAL*4 :: ARRAY(IIPAR,JJPAR,1) + REAL*8 :: XTAU + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! Initialization + !================================================================= + + ! Allocate arrays on the first call only + IF ( FIRST ) THEN + CALL INIT_TOMS + FIRST = .FALSE. + ENDIF + + ! Always use 2002 data for GCAP +#if defined ( GCAP ) + YEAR = 2002 +#else + YEAR = THISYEAR +#endif + + ! Use 1979 data prior to 1979 + IF ( YEAR < FIRST_TOMS_YEAR ) THEN + WRITE( 6, 100 ) YEAR + YEAR = FIRST_TOMS_YEAR + ENDIF + + ! Use 2010 data after 2010 + IF ( YEAR > LAST_TOMS_YEAR ) THEN + WRITE( 6, 105 ) YEAR + YEAR = LAST_TOMS_YEAR + ENDIF + + + ! FORMAT statemetns + 100 FORMAT( ' - READ_TOMS: No data for ',i4,', using 1979!' ) + 105 FORMAT( ' - READ_TOMS: No data for ',i4,', using 2010!' ) + + !================================================================= + ! Read TOMS data from disk + !================================================================= + + ! Get TAU0 value for first day of the MONTH + XTAU = GET_TAU0( THISMONTH, 1, YEAR ) + + ! Create YYYYMMDD value + YYYYMMDD = ( YEAR * 10000 ) + ( THISMONTH * 100 ) + 01 + + ! Define filename (with replaceable tokens) +#if !defined( GCAP ) + +#if defined( GRID4x5 ) || defined( GRID2x25 ) || defined( GRID025x03125 ) + FILENAME = 'TOMS_201203/TOMS_O3col_YYYY.' // GET_NAME_EXT_2D() // + & '.' // GET_RES_EXT() +#else + FILENAME = 'TOMS_200906/TOMS_O3col_YYYY.' // GET_NAME_EXT_2D() // + & '.' // GET_RES_EXT() +#endif + +#else + FILENAME = 'TOMS_200701/TOMS_O3col_YYYY.' // GET_NAME_EXT_2D() // + & '.' // GET_RES_EXT() +#endif + + ! Replace YYYY token with current year + CALL EXPAND_DATE( FILENAME, YYYYMMDD, 000000 ) + + ! Now prefix the data directory + FILENAME = TRIM( DATA_DIR ) // TRIM( FILENAME ) + + ! Echo filename + WRITE( 6, 110 ) TRIM( FILENAME ) + 110 FORMAT( ' - READ_TOMS: Reading ', a ) + + !----------------------------- + ! TOMS O3 columns + !----------------------------- + + ! Read data + CALL READ_BPCH2( FILENAME, 'TOMS-O3', 1, + & XTAU, IIPAR, JJPAR, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 and resize if necessary + CALL TRANSFER_2D( ARRAY(:,:,1), TOMS ) + + !-------------------------------- + ! d(TOMS)/dT (1st half of month) + !-------------------------------- + + ! Read data + CALL READ_BPCH2( FILENAME, 'TOMS-O3', 2, + & XTAU, IIPAR, JJPAR, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 and resize if necessary + CALL TRANSFER_2D( ARRAY(:,:,1), DTOMS1 ) + + !-------------------------------- + ! d(TOMS)/dT (2nd half of month) + !-------------------------------- + + ! Read data: + CALL READ_BPCH2( FILENAME, 'TOMS-O3', 3, + & XTAU, IIPAR, JJPAR, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 and resize if necessary + CALL TRANSFER_2D( ARRAY(:,:,1), DTOMS2 ) + + END SUBROUTINE READ_TOMS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: init_toms +! +! !DESCRIPTION: Subroutine INIT\_TOMS allocates and zeroes all module arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE INIT_TOMS +! +! !USES: +! + USE ERROR_MOD, ONLY : ALLOC_ERR + + !USE CMN_SIZE_MOD ! Size parameters +# include "CMN_SIZE" +! +! !REVISION HISTORY: +! 14 Jul 2003 - R. Yantosca - Initial version +! 01 Dec 2010 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: AS + + !================================================================= + ! INIT_TOMS begins here! + !================================================================= + + ! Allocate TOMS + ALLOCATE( TOMS( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TOMS' ) + TOMS = 0d0 + + ! Allocate DTOMS + ALLOCATE( DTOMS1( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DTOMS1' ) + DTOMS1 = 0d0 + + ! Allocate DTOMS2 + ALLOCATE( DTOMS2( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DTOMS2' ) + DTOMS2 = 0d0 + + END SUBROUTINE INIT_TOMS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: cleanup_toms +! +! !DESCRIPTION: Subroutine CLEANUP\_TOMS deallocates all module arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE CLEANUP_TOMS +! +! !REVISION HISTORY: +! 14 Jul 2003 - R. Yantosca - Initial version +! 01 Dec 2010 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC + !================================================================= + ! CLEANUP_TOMS begins here! + !================================================================= + IF ( ALLOCATED( TOMS ) ) DEALLOCATE( TOMS ) + IF ( ALLOCATED( DTOMS1 ) ) DEALLOCATE( DTOMS1 ) + IF ( ALLOCATED( DTOMS2 ) ) DEALLOCATE( DTOMS2 ) + + END SUBROUTINE CLEANUP_TOMS +!EOC + END MODULE TOMS_MOD diff --git a/code/tpcore_bc_mod.f b/code/tpcore_bc_mod.f new file mode 100644 index 0000000..bd3aef6 --- /dev/null +++ b/code/tpcore_bc_mod.f @@ -0,0 +1,2068 @@ +! $Id: tpcore_bc_mod.f,v 1.2 2012/03/01 22:00:26 daven Exp $ + MODULE TPCORE_BC_MOD +! +!****************************************************************************** +! Module TPCORE_BC_MOD contains modules and variables which are needed to +! save and read TPCORE nested-grid boundary conditions to/from disk. +! (yxw, bmy, 3/4/03, 3/15/06) +! +! Module Variables: +! ============================================================================ +! (1 ) CLEAN_BC (LOGICAL ) : Flag which denotes if we will zero BC's +! (2 ) I0_W (INTEGER ) : Lon offset of 1x1 TPCORE REGION [# boxes] +! (3 ) J0_W (INTEGER ) : Lat offset of 1x1 TPCORE REGION [# boxes] +! (4 ) IM_W (INTEGER ) : Lon extent of 1x1 TPCORE REGION [# boxes] +! (5 ) JM_W (INTEGER ) : Lat extent of 1x1 TPCORE REGION [# boxes] +! (6 ) I1_W (INTEGER ) : Lower left-hand lon index of 1x1 WINDOW +! (7 ) J1_W (INTEGER ) : Lower left-hand lat index of 1x1 WINDOW +! (8 ) I2_W (INTEGER ) : Upper right-hand lon index of 1x1 WINDOW +! (9 ) J2_W (INTEGER ) : Upper right-hand lat index of 1x1 WINDOW +! (10) IGZD (INTEGER ) : ??? +! (110 TS_BC (INTEGER ) : Timestep for reading in BC's from disk [min] +! (11) I0_BC (INTEGER ) : Lon offset of 4x5 WINDOW REGION [# boxes] +! (12) J0_BC (INTEGER ) : Lat offset of 4x5 WINDOW REGION [# boxes] +! (13) IM_BC (INTEGER ) : Lon extent of 4x5 WINDOW REGION [# boxes] +! (14) JM_BC (INTEGER ) : Lat extent of 4x5 WINDOW REGION [# boxes] +! (15) I1_BC (INTEGER ) : Lower left-hand lon index of 4x5 WINDOW +! (16) J1_BC (INTEGER ) : Lower left-hand lat index of 4x5 WINDOW +! (17) I2_BC (INTEGER ) : Upper right-hand lon index of 4x5 WINDOW +! (18) J2_BC (INTEGER ) : Upper right-hand lat index of 4x5 WINDOW +! (19) BC (REAL*4 ) : Array containing tracers on coarse grid +! (19b) BC_NA (REAL*4 ) : Array containing NA tracers on coarse grid +! (19c) BC_EU (REAL*4 ) : Array containing EU tracers on coarse grid +! (19d) BC_CH (REAL*4 ) : Array containing CH tracers on coarse grid +! (20) MAP1x1 (INTEGER ) : Mapping array from 1x1 -> 4x5 grid +! +! Module Routines: +! ============================================================================ +! (1 ) SET_CLEAN_BC : Initializes the CLEAN_BC module variable +! (2 ) OPEN_BC_FILE : Opens a new boundary conditions file (R or W) +! (3 ) SAVE_GLOBAL_TPCORE_BC : Saves boundary conditions from GLOBAL run +! (4 ) DO_WINDOW_TPCORE_BC : Calls routine to clean or read window BC's +! (5 ) CLEAN_WINDOW_TPCORE_BC : Zeroes the nested-grid TPCORE boundary cond's +! (6 ) READ_WINDOW_TPCORE_BC : Reads nested-grid TPCORE BC's from disk +! (7 ) GET_4x5_BC : Returns the 4x5 BC at a given 1x1 location +! (7b) GET_2x25_BC : Returns the 2x2.5 BC at a given 1x1 location +! (8 ) ITS_TIME_FOR_BC : Returns T if it is time to read BC's +! (9 ) INIT_TPCORE_BC : Initalizes and allocates module variables +! (10) CLEANUP_TPCORE_BC : Deallocates module vaf +! +! GEOS-CHEM modules referenced by tpcore_call_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module containing routines for bpch file I/O +! (2 ) directory_mod.f : Module containing GEOS-CHEM data & metfld dirs +! (3 ) error_mod.f : Module containing I/O error/NaN check routines +! (4 ) file_mod.f : Contains file unit numbers and error checks +! (5 ) grid_mod.f : Module containing horizontal grid information +! (6 ) logical_mod.f : Module containing GEOS-CHEM logical switches +! (7 ) time_mod.f : Module containing routines for date & time +! (8 ) tracer_mod.f : Module containing GEOS-CHEM tracer array STT +! +! Reference Diagram: +! ============================================================================ +! +! <-------------------------------------- IGLOB ----------------------> +! +! +-------------------------------------------------------------------+ ^ +! | GLOBAL REGION | | +! | | | +! | <-------------- IIPAR -------------> | | +! | | | +! | +=================================[Y] ^ | | +! | | WINDOW REGION (met field size) | | | | +! | | | | | | +! | | <------- IM_W -------> | | | | +! | | +--------------------+ ^ | | | | +! | | | TPCORE REGION | | | | | | +! | | | (transport is | | | | | | +! |<------- I0 ---------->|<---->| done in this | JM_W | JJPAR | JGLOB +! | | I0_W | window!!!) | | | | | | +! | | | | | | | | | +! | | +--------------------+ V | | | | +! | | ^ | | | | +! | | | J0_W | | | | +! | | V | | | | +! | [X]=================================+ V | | +! | ^ | | +! | | J0 | | +! | V | | +! [1]------------------------------------------------------------------+ V +! +! DIAGRAM NOTES: +! (a) The outermost box ("Global Region") is the global grid size. This +! region has IGLOB boxes in longitude and JGLOB boxes in latitude. +! The origin of the "Global Region" is at the south pole, at the +! lower left-hand corner (point [1]). +! +! (b) The next innermost box ("Window Region") is the nested-grid window. +! This region has IIPAR boxes in longitude and JJPAR boxes in latitude. +! This is the size of the trimmed met fields that will be used for +! a 1 x 1 "nested-grid" simulation. +! +! (c) The innermost region ("TPCORE Region") is the actual area in which +! TPCORE transport will be performed. Note that this region is smaller +! than the "Window Region". It is set up this way since a cushion of +! grid boxes is needed TPCORE Region for boundary conditions. +! +! (d) I0 is the longitude offset (# of boxes) and J0 is the latitude offset +! (# of boxes) which translate between the "Global Region" and the +! "Window Region". +! +! (e) I0_W is the longitude offset (# of boxes), and J0_W is the latitude +! offset (# of boxes) which translate between the "Window Region" +! and the "TPCORE Region". +! +! (f) The lower left-hand corner of the "Window Region" (point [X]) has +! longitude and latitude indices (I1_W, J1_W). Similarly, the upper +! right-hand corner (point [Y]) has longitude and latitude indices +! (I2_W, J2_W). +! +! (g) Note that if I0=0, J0=0, I0_W=0, J0_W=0, IIPAR=IGLOB, JJPAR=JGLOB +! specifies a global simulation. In this case the "Window Region" +! totally coincides with the "Global Region". +! +! (h) In order for the nested-grid to work we must save out concentrations +! over the WINDOW REGION from a coarse model (e.g. 4x5) corresponding to +! the same WINDOW REGION at 1x1. These concentrations are copied along +! the edges of the 1x1 WINDOW REGION and are thus used as boundary +! conditions for TPCORE. We assume that we will save out concentrations +! from the 4x5 model since presently it takes too long to run at 2x25. +! +! NOTES: +! (1 ) Bug fix for LINUX w/ TIMESTAMP_STRING (bmy, 9/29/03) +! (2 ) Now references "tracer_mod.f", "directory_mod.f", and +! "logical_mod.f" (bmy, 7/20/04) +! (3 ) Now get HALFPOLAR for GEOS or GCAP grids (bmy, 6/28/05) +! (4 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (5 ) Rename arguments in GET_4x5_BC to avoid name conflict (bmy, 10/24/05) +! (6 ) Now use EXPAND_DATE instead of obsolete DATE_STRING (bmy, 3/15/06) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "tpcore_bc_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these variables ... + PUBLIC :: I0_W, J0_W + PUBLIC :: I1_W, J1_W + PUBLIC :: I2_W, J2_W + PUBLIC :: IM_W, JM_W + PUBLIC :: IGZD + + ! ... and these routines + PUBLIC :: INIT_TPCORE_BC + PUBLIC :: INIT_TPCORE_BC_05x0666 + PUBLIC :: DO_WINDOW_TPCORE_BC + PUBLIC :: DO_WINDOW_TPCORE_BC_05x0666 + PUBLIC :: DO_WINDOW_TPCORE_BC_ADJ + PUBLIC :: SET_CLEAN_BC + PUBLIC :: SAVE_GLOBAL_TPCORE_BC + PUBLIC :: SAVE_GLOBAL_TPCORE_BC_05x0666 + + !================================================================= + ! MODULE VARIABLES + !================================================================= + LOGICAL :: CLEAN_BC + INTEGER :: I0_W, J0_W, IM_W, JM_W + INTEGER :: I1_W, J1_W, I2_W, J2_W + INTEGER :: I0_BC, J0_BC, I1_BC, J1_BC + INTEGER :: I2_BC, J2_BC, IM_BC, JM_BC + INTEGER :: I0_BC_NA, J0_BC_NA, I1_BC_NA, J1_BC_NA !!(lzh,02/01/2015) + INTEGER :: I2_BC_NA, J2_BC_NA, IM_BC_NA, JM_BC_NA + INTEGER :: I0_BC_EU, J0_BC_EU, I1_BC_EU, J1_BC_EU + INTEGER :: I2_BC_EU, J2_BC_EU, IM_BC_EU, JM_BC_EU + INTEGER :: I0_BC_CH, J0_BC_CH, I1_BC_CH, J1_BC_CH + INTEGER :: I2_BC_CH, J2_BC_CH, IM_BC_CH, JM_BC_CH + INTEGER :: IGZD, TS_BC + INTEGER, ALLOCATABLE :: MAP1x1(:,:,:) + REAL*4, ALLOCATABLE :: BC(:,:,:,:) + REAL*4, ALLOCATABLE :: BC_NA(:,:,:,:) ! (lzh,02/01/2015) + REAL*4, ALLOCATABLE :: BC_EU(:,:,:,:) + REAL*4, ALLOCATABLE :: BC_CH(:,:,:,:) + + !================================================================= + ! MODULE VARIABLES FOR 05x0666 BC (Zhe, Jan 2012) + !================================================================= + INTEGER :: I1_BC_05x06, J1_BC_05x06 + INTEGER :: I1_BC_GLOBAL, J1_BC_GLOBAL + INTEGER :: I2_BC_05x06, J2_BC_05x06 + INTEGER :: IM_BC_05x06, JM_BC_05x06 + INTEGER :: TS_BC_05x06, IJ_BC_05x06 + REAL*4, ALLOCATABLE :: BC_05x06(:,:,:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE SET_CLEAN_BC( THIS_CLEAN_BC ) +! +!****************************************************************************** +! Subroutine SET_CLEAN_BC initializes the CLEAN_BC logical flag. CLEAN_BC +! decides whether or not we will zero the nested-grid tpcore boundary. +! (bmy, 3/4/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) THIS_CLEAN_BC (LOGICAL) : Logical value (T/F) to assign to CLEAN_BC +! +! NOTES: +!****************************************************************************** +! + ! Arguments + LOGICAL, INTENT(IN) :: THIS_CLEAN_BC + + !================================================================= + ! SET_CLEAN_BC begins here! + !================================================================= + CLEAN_BC = THIS_CLEAN_BC + + ! Return to calling program + END SUBROUTINE SET_CLEAN_BC + +!------------------------------------------------------------------------------ + +! update nested runs based on standard GC (lzh,02/01/2015) + SUBROUTINE OPEN_BC_FILE( FOR_READ, FOR_WRITE, WINDOW ) +! +!****************************************************************************** +! Subroutine OPEN_BC_FILE opens the file which contains boundary conditions +! saved from the coarse-grid WINDOW REGION for either reading or writing. +! (bmy, 3/7/03, 3/15/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FOR_READ (LOGICAL) : If passed, opens binary punch file for reading +! (2 ) FOR_WRITE (LOGICAL) : If passed, opens binary punch file for writing +! +! NOTES: +! (1 ) Now use ITS_A_NEW_DAY from "time_mod.f". Now references TPBC_DIR +! from "directory_mod.f" (bmy, 7/20/04) +! (2 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (3 ) DATE_STRING is now obsolete; use EXPAND_DATE instead (bmy, 3/15/06) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_WRITE + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_MOD, ONLY : TPBC_DIR + USE FILE_MOD, ONLY : IU_BC + USE DIRECTORY_MOD, ONLY : TPBC_DIR_CH, TPBC_DIR_EU, TPBC_DIR_NA + USE FILE_MOD, ONLY : IU_BC_NA, IU_BC_EU, IU_BC_CH !(lzh,02/01/2015) + USE TIME_MOD, ONLY : EXPAND_DATE, GET_NYMD, ITS_A_NEW_DAY + + IMPLICIT NONE + +# include "define.h" ! Size parameters + + ! Arguments + LOGICAL, INTENT(IN), OPTIONAL :: FOR_READ, FOR_WRITE + INTEGER, INTENT(IN) :: WINDOW !(lzh,02/01/2015) + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! OPEN_BC_FILE begins here! + !================================================================= + + ! Only open file if it's a new day + IF ( ITS_A_NEW_DAY() ) THEN + + ! File name for BC's +! (lzh, 02/01/2015) + IF ( WINDOW .eq. 5 ) THEN +#if defined( NESTED_NA ) + FILENAME = TRIM( TPBC_DIR_NA ) // 'BC.YYYYMMDD' +#elif defined( NESTED_EU ) + FILENAME = TRIM( TPBC_DIR_EU ) // 'BC.YYYYMMDD' +#elif defined( NESTED_CH ) + FILENAME = TRIM( TPBC_DIR_CH ) // 'BC.YYYYMMDD' +#endif + ELSEIF ( WINDOW .eq. 1 ) THEN + FILENAME = TRIM( TPBC_DIR ) // 'BC.YYYYMMDD' + ELSEIF ( WINDOW .eq. 2 ) THEN + FILENAME = TRIM( TPBC_DIR_NA ) // 'BC.YYYYMMDD' + ELSEIF ( WINDOW .eq. 3 ) THEN + FILENAME = TRIM( TPBC_DIR_EU ) // 'BC.YYYYMMDD' + ELSEIF ( WINDOW .eq. 4 ) THEN + FILENAME = TRIM( TPBC_DIR_CH ) // 'BC.YYYYMMDD' + ENDIF + + ! Replace YYYYMMDD with the actual date + CALL EXPAND_DATE( FILENAME, GET_NYMD(), 000000 ) + + ! Echo file name to stdout + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - OPEN_BC_FILE: Opening ', a ) + + ! Open file for reading or writing +! IF ( PRESENT( FOR_WRITE ) ) THEN +! CALL OPEN_BPCH2_FOR_WRITE( IU_BC, FILENAME ) +! +! ELSE IF ( PRESENT( FOR_READ ) ) THEN +! CALL OPEN_BPCH2_FOR_READ( IU_BC, FILENAME ) +! +! ENDIF + +! (lzh, 02/01/2015) + IF ( WINDOW .eq. 5 ) THEN + IF ( PRESENT( FOR_READ ) ) + & CALL OPEN_BPCH2_FOR_READ( IU_BC, + & FILENAME ) + ELSEIF ( WINDOW .eq. 1 ) THEN + IF ( PRESENT( FOR_WRITE ) ) + & CALL OPEN_BPCH2_FOR_WRITE( IU_BC, + & FILENAME ) + ELSEIF ( WINDOW .eq. 2 ) THEN + IF ( PRESENT( FOR_WRITE ) ) + & CALL OPEN_BPCH2_FOR_WRITE( IU_BC_NA, + & FILENAME ) + ELSEIF ( WINDOW .eq. 3 ) THEN + IF ( PRESENT( FOR_WRITE ) ) + & CALL OPEN_BPCH2_FOR_WRITE( IU_BC_EU, + & FILENAME ) + ELSEIF ( WINDOW .eq. 4 ) THEN + IF ( PRESENT( FOR_WRITE ) ) + & CALL OPEN_BPCH2_FOR_WRITE( IU_BC_CH, + & FILENAME ) + ENDIF + + ENDIF + + ! Return to calling program + END SUBROUTINE OPEN_BC_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE OPEN_BC_FILE_05x0666( FOR_READ, FOR_WRITE ) +! +!****************************************************************************** +! Subroutine OPEN_BC_FILE_05x0666 opens the file which contains boundary conditions +! saved from 05x0666 nested simulation for either reading or writing. +! (Zhe, Jan 2012) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FOR_READ (LOGICAL) : If passed, opens binary punch file for reading +! (2 ) FOR_WRITE (LOGICAL) : If passed, opens binary punch file for writing +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_WRITE + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_MOD, ONLY : TPBC_DIR + USE FILE_MOD, ONLY : IU_BC_05x06 + USE TIME_MOD, ONLY : EXPAND_DATE, GET_NYMD, ITS_A_NEW_DAY + + ! Arguments + LOGICAL, INTENT(IN), OPTIONAL :: FOR_READ, FOR_WRITE + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! OPEN_BC_FILE_05x0666 begins here! + !================================================================= + + ! Only open file if it's a new day + IF ( ITS_A_NEW_DAY() ) THEN + + ! File name for BC's + FILENAME = TRIM( TPBC_DIR ) // 'BC.YYYYMMDD' // '.05x0666' + + ! Replace YYYYMMDD with the actual date + CALL EXPAND_DATE( FILENAME, GET_NYMD(), 000000 ) + + ! Echo file name to stdout + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - OPEN_BC_FILE: Opening ', a ) + + ! Open file for reading or writing + IF ( PRESENT( FOR_WRITE ) ) THEN + CALL OPEN_BPCH2_FOR_WRITE( IU_BC_05x06, FILENAME ) + + ELSE IF ( PRESENT( FOR_READ ) ) THEN + CALL OPEN_BPCH2_FOR_READ( IU_BC_05x06, FILENAME ) + + ENDIF + ENDIF + + ! Return to calling program + END SUBROUTINE OPEN_BC_FILE_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE SAVE_GLOBAL_TPCORE_BC +! +!****************************************************************************** +! Subroutine SAVE_GLOBAL_TPCORE_BC saves concentrations from the WINDOW +! REGION of a coarse-resolution model run (e.g. 4x5) to a bpch file. +! A new boundary conditions file is created for each day. +! (yxw, bmy, 3/4/03, 10/3/05) +! +! NOTES: +! (1 ) Now references N_TRACERS and STT from "tracer_mod.f". Also now +! references TIMESTAMP_STRING from "time_mod.f". (bmy, 7/20/04) +! (2 ) Now call GET_HALFPOLAR from "bpch2_mod.f" to get the HALFPOLAR flag +! value for GEOS or GCAP grids (bmy, 6/28/05) +! (3 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : BPCH2, GET_HALFPOLAR, GET_MODELNAME + USE FILE_MOD, ONLY : IU_BC + USE FILE_MOD, ONLY : IU_BC_NA, IU_BC_EU, IU_BC_CH !(lzh,02/01/2015) + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, + & GET_TAU, TIMESTAMP_STRING + USE TRACER_MOD, ONLY : N_TRACERS, STT + USE LOGICAL_MOD, ONLY : LWINDO_CU, LWINDO_NA !(lzh,02/01/2015) + USE LOGICAL_MOD, ONLY : LWINDO_CH, LWINDO_EU + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: HALFPOLAR + INTEGER, PARAMETER :: CENTER180 = 1 + INTEGER :: I, IOS, J, L, N + REAL*4 :: LONRES, LATRES + REAL*4 :: ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: TAU + CHARACTER(LEN=16) :: STAMP + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY = 'IJ-AVG-$' + CHARACTER(LEN=40) :: UNIT = 'v/v' + CHARACTER(LEN=40) :: RESERVED = '' + INTEGER :: IC ! (lzh,02/01/2015) + + !================================================================= + ! SAVE_GLOBAL_TPCORE_BC begins here! + !================================================================= + + ! Return if it's not time to write data to disk + IF ( .not. ITS_TIME_FOR_BC() ) RETURN + +! (lzh,02/01/2015) open below +! ! Open file for writing, if necessary +! CALL OPEN_BC_FILE( FOR_WRITE=.TRUE. ) + + !================================================================= + ! Save boundary conditions from coarse grid to a BPCH file + !================================================================= + + ! Define variables for BPCH output + LONRES = DISIZE + LATRES = DJSIZE + HALFPOLAR = GET_HALFPOLAR() + MODELNAME = GET_MODELNAME() + TAU = GET_TAU() + +! (lzh,02/01/2015) add all nested domains as in standard GC + DO IC = 1, 4 + IF ((IC .eq. 1) .and. LWINDO_CU )THEN + + ! Open file for writing, if necessary + CALL OPEN_BC_FILE( FOR_WRITE=.TRUE., WINDOW=IC) + + ! Loop over each tracer + DO N = 1, N_TRACERS + + ! Save concentrations in WINDOW REGION to disk + DO L = 1, LLPAR + BC(1:IM_BC,1:JM_BC,L,N) = + & STT(I1_BC:I2_BC,J1_BC:J2_BC,L,N) + ENDDO + + ! Write boundary conditions to binary punch file + CALL BPCH2( IU_BC, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IM_BC, JM_BC, LLPAR, I1_BC, + & J1_BC, 1, BC(1:IM_BC, 1:JM_BC, 1:LLPAR, N) ) + + ENDDO + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 110 ) STAMP + 110 FORMAT( ' - SAVE_GLOBAL_TPCORE_BC: Wrote BC''s at ', a ) + + ELSEIF ((IC .eq. 2) .and. LWINDO_NA )THEN + + ! Open file for writing, if necessary + CALL OPEN_BC_FILE( FOR_WRITE=.TRUE., WINDOW=IC) + + ! Loop over each tracer + DO N = 1, N_TRACERS + + ! Save concentrations in WINDOW REGION to disk + DO L = 1, LLPAR + BC_NA(1:IM_BC_NA,1:JM_BC_NA,L,N) = + & STT(I1_BC_NA:I2_BC_NA,J1_BC_NA:J2_BC_NA,L,N) + ENDDO + + ! Write boundary conditions to binary punch file + CALL BPCH2( IU_BC_NA, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IM_BC_NA, JM_BC_NA, LLPAR, I1_BC_NA, + & J1_BC_NA, 1, BC_NA(1:IM_BC_NA, 1:JM_BC_NA, + & 1:LLPAR, N) ) + + ENDDO + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 111 ) STAMP + 111 FORMAT( ' - SAVE_GLOBAL_TPCORE_BC: Wrote NA BC''s at ', a ) + + ELSEIF ((IC .eq. 3) .and. LWINDO_EU )THEN + + ! Open file for writing, if necessary + CALL OPEN_BC_FILE( FOR_WRITE=.TRUE., WINDOW=IC) + + ! Loop over each tracer + DO N = 1, N_TRACERS + + ! Save concentrations in WINDOW REGION to disk + DO L = 1, LLPAR + BC_EU(1:IM_BC_EU,1:JM_BC_EU,L,N) = + & STT(I1_BC_EU:I2_BC_EU,J1_BC_EU:J2_BC_EU,L,N) + ENDDO + + ! Write boundary conditions to binary punch file + CALL BPCH2( IU_BC_EU, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IM_BC_EU, JM_BC_EU, LLPAR, I1_BC_EU, + & J1_BC_EU, 1, BC_EU(1:IM_BC_EU, 1:JM_BC_EU, + & 1:LLPAR, N) ) + + ENDDO + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 112 ) STAMP + 112 FORMAT( ' - SAVE_GLOBAL_TPCORE_BC: Wrote EU BC''s at ', a ) + + ELSEIF ((IC .eq. 4) .and. LWINDO_CH )THEN + + ! Open file for writing, if necessary + CALL OPEN_BC_FILE( FOR_WRITE=.TRUE., WINDOW=IC) + + ! Loop over each tracer + DO N = 1, N_TRACERS + + ! Save concentrations in WINDOW REGION to disk + DO L = 1, LLPAR + BC_CH(1:IM_BC_CH,1:JM_BC_CH,L,N) = + & STT(I1_BC_CH:I2_BC_CH,J1_BC_CH:J2_BC_CH,L,N) + ENDDO + + ! Write boundary conditions to binary punch file + CALL BPCH2( IU_BC_CH, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IM_BC_CH, JM_BC_CH, LLPAR, I1_BC_CH, + & J1_BC_CH, 1, BC_CH(1:IM_BC_CH, 1:JM_BC_CH, + & 1:LLPAR, N) ) + + ENDDO + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 113 ) STAMP + 113 FORMAT( ' - SAVE_GLOBAL_TPCORE_BC: Wrote CH BC''s at ', a ) + + ENDIF + ENDDO + + ! Return to calling program + END SUBROUTINE SAVE_GLOBAL_TPCORE_BC + +!------------------------------------------------------------------------ + + SUBROUTINE SAVE_GLOBAL_TPCORE_BC_05x0666 +! +!****************************************************************************** +! Subroutine SAVE_GLOBAL_TPCORE_BC_05x0666 saves concentrations from the 05x0666 +! simulation to a smaller nested region. +! A new boundary conditions file is created for each day. +! (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : BPCH2, GET_HALFPOLAR, GET_MODELNAME + USE FILE_MOD, ONLY : IU_BC_05x06 + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, + & GET_TAU, TIMESTAMP_STRING + USE TRACER_MOD, ONLY : N_TRACERS, STT + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: HALFPOLAR + INTEGER, PARAMETER :: CENTER180 = 1 + INTEGER :: I, IOS, J, L, N + REAL*4 :: LONRES, LATRES + REAL*4 :: ARRAY(IIPAR,JJPAR,LLPAR) + REAL*4 :: STT_BC(I0_W,JM_BC_05x06) + REAL*8 :: TAU + CHARACTER(LEN=16) :: STAMP + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY = 'IJ-AVG-$' + CHARACTER(LEN=40) :: UNIT = 'v/v' + CHARACTER(LEN=40) :: RESERVED = '' + + !================================================================= + ! SAVE_GLOBAL_TPCORE_BC_05x0666 begins here! + !================================================================= + + ! Return if it's not time to write data to disk + IF ( .not. ITS_TIME_FOR_BC_05x0666() ) RETURN + + ! Open file for writing, if necessary + CALL OPEN_BC_FILE_05x0666( FOR_WRITE=.TRUE. ) + + !================================================================= + ! Save boundary conditions from coarse grid to a BPCH file + !================================================================= + + ! Define variables for BPCH output + LONRES = DISIZE + LATRES = DJSIZE + HALFPOLAR = GET_HALFPOLAR() + MODELNAME = GET_MODELNAME() + TAU = GET_TAU() + + ! Loop over each tracer + DO N = 1, N_TRACERS + + ! We only save concentrations in CUSHION to save disk space + DO L = 1, LLPAR + + !Southern boundary, 1:J0_W + BC_05x06(1:IM_BC_05x06, 1:J0_W, L, N) + & = STT(I1_BC_05x06:I2_BC_05x06, + & J1_BC_05x06:(J1_BC_05x06 + J0_W - 1), L, N) + + !Northern boundary, (J0_W + 1):(J0_W * 2) + BC_05x06(1:IM_BC_05x06, (J0_W + 1):(J0_W * 2), L, N) + & = STT(I1_BC_05x06:I2_BC_05x06, + & (J2_BC_05x06 - J0_W + 1):J2_BC_05x06, L, N) + + !Western boundary, (J0_W * 2 + 1):(J0_W * 2 + I0_W) + STT_BC(1:I0_W, 1:JM_BC_05x06) + & = STT(I1_BC_05x06:(I1_BC_05x06 + I0_W - 1), + & J1_BC_05x06:J2_BC_05x06, L, N) + + BC_05x06(1:JM_BC_05x06, + & (J0_W * 2 + 1):(J0_W * 2 + I0_W), L, N) + & = TRANSPOSE(STT_BC) + + !Eestern boundary, (J0_W * 2 + I0_W + 1):((J0_W + I0_W)* 2) + STT_BC(1:I0_W, 1:JM_BC_05x06) + & = STT((I2_BC_05x06 - I0_W + 1):I2_BC_05x06, + & J1_BC_05x06:J2_BC_05x06, L, N) + + BC_05x06(1:JM_BC_05x06, + & (J0_W * 2 + I0_W + 1):((J0_W + I0_W)* 2), L, N) + & = TRANSPOSE(STT_BC) + + ENDDO + + ! Write boundary conditions to binary punch file + CALL BPCH2( IU_BC_05x06, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IJ_BC_05x06, (I0_W + J0_W)*2, LLPAR, I1_BC_GLOBAL, + & J1_BC_GLOBAL, 1, BC_05x06(:, :, :, N) ) + + ENDDO + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 110 ) STAMP + 110 FORMAT( ' - SAVE_GLOBAL_TPCORE_BC: Wrote BC''s at ', a ) + + ! Return to calling program + END SUBROUTINE SAVE_GLOBAL_TPCORE_BC_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_WINDOW_TPCORE_BC +! +!****************************************************************************** +! Subroutine DO_WINDOW_TPCORE_BC is a driver routine for assigning TPCORE +! boundary conditions to the tracer array STT. (bmy, 3/7/03, 7/20/04) +! +! At present, assume that we have saved +! +! NOTES: +! (1 ) Now references N_TRACERS and STT from "tracer_mod.f" (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : N_TRACERS, STT + USE LOGICAL_MOD, ONLY : LWINDO2x25 !add 2x25 BC (lzh,02/01/2015) + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, L, N + + !================================================================= + ! DO_WINDOW_TPCORE_BC begins here! + !================================================================= + + ! Either zero BC's or read them from disk + IF ( CLEAN_BC ) THEN + CALL CLEAN_WINDOW_TPCORE_BC + ELSE + CALL READ_WINDOW_TPCORE_BC + ENDIF + + !================================================================= + ! Copy the BC data into the proper elements of STT + ! + ! NOTE: We assume that we have saved 4x5 BC's from a global + ! GEOS-CHEM run. It takes too long to save the 2x25 BC's. + ! One may always another subroutine for 2x25 BC's later. + !================================================================= + IF ( .not. LWINDO2x25 ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + + ! First loop over all latitudes (WINDOW REGION) + DO J = 1, JJPAR + + ! West BC + DO I = 1, I0_W + STT(I,J,L,N) = GET_4x5_BC(I,J,L,N) + ENDDO + + ! East BC + DO I = IIPAR-I0_W+1, IIPAR + STT(I,J,L,N) = GET_4x5_BC(I,J,L,N) + ENDDO + ENDDO + + ! Now loop over the longitudes of the TPCORE REGION + DO I = 1+I0_W, IM_W+I0_W + + ! South BC + DO J = 1, J0_W + STT(I,J,L,N) = GET_4x5_BC(I,J,L,N) + ENDDO + + ! North BC + DO J = JJPAR-J0_W+1, JJPAR + STT(I,J,L,N) = GET_4x5_BC(I,J,L,N) + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ELSE + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + + ! First loop over all latitudes (WINDOW REGION) + DO J = 1, JJPAR + + ! West BC + DO I = 1, I0_W + STT(I,J,L,N) = GET_2x25_BC(I,J,L,N) + ENDDO + + ! East BC + DO I = IIPAR-I0_W+1, IIPAR + STT(I,J,L,N) = GET_2x25_BC(I,J,L,N) + ENDDO + ENDDO + + ! Now loop over the longitudes of the TPCORE REGION + DO I = 1+I0_W, IM_W+I0_W + + ! South BC + DO J = 1, J0_W + STT(I,J,L,N) = GET_2x25_BC(I,J,L,N) + ENDDO + + ! North BC + DO J = JJPAR-J0_W+1, JJPAR + STT(I,J,L,N) = GET_2x25_BC(I,J,L,N) + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! Return to calling program + END SUBROUTINE DO_WINDOW_TPCORE_BC + +!------------------------------------------------------------------------------ + SUBROUTINE DO_WINDOW_TPCORE_BC_ADJ +! +!****************************************************************************** +! Subroutine DO_WINDOW_TPCORE_BC_ADJ is the adjoint for assigning TPCORE +! boundary conditions to the tracer array STT. The impact is to set the +! adjoint values with the cushion region to zero. +! (zhej, dkh, 02/09/12, adj32_020) +! +! Based on DO_WINDOW_TPCORE_BC by (bmy, 3/7/03, 7/20/04) +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : N_TRACERS + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! Set the adjoint concentration of cushion grids to ZERO because + ! the current nested transport module allows transport crossing + ! west/east boundary. (Zhe Jan 2012) + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + + ! First loop over all latitudes (WINDOW REGION) + DO J = 1, JJPAR + + ! West BC + DO I = 1, I0_W + STT_ADJ(I,J,L,N) = 0.0 + ENDDO + + ! East BC + DO I = IIPAR-I0_W+1, IIPAR + STT_ADJ(I,J,L,N) = 0.0 + ENDDO + ENDDO + + ! Now loop over the longitudes of the TPCORE REGION + DO I = 1, IIPAR + + ! South BC + DO J = 1, J0_W + STT_ADJ(I,J,L,N) = 0.0 + ENDDO + + ! North BC + DO J = JJPAR-J0_W+1, JJPAR + STT_ADJ(I,J,L,N) = 0.0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE DO_WINDOW_TPCORE_BC_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_WINDOW_TPCORE_BC_05x0666 +! +!****************************************************************************** +! Subroutine DO_WINDOW_TPCORE_BC_05x0666 is a driver routine for assigning TPCORE +! boundary conditions to the tracer array STT. (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : N_TRACERS, STT + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, L, N + REAL*4 :: STT_BC(JM_BC_05x06, I0_W) + + !================================================================= + ! DO_WINDOW_TPCORE_BC begins here! + !================================================================= + + ! Either zero BC's or read them from disk + IF ( CLEAN_BC ) THEN + CALL CLEAN_WINDOW_TPCORE_BC_05x0666 + ELSE + CALL READ_WINDOW_TPCORE_BC_05x0666 + ENDIF + + !================================================================= + ! Copy the BC data into the proper elements of STT + !================================================================= + +! Do this sequentially for now (zhej, dkh, 02/09/12, adj32_021) +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + + !Southern boundary, 1:J0_W + STT(1:IIPAR, 1:J0_W, L, N) + & = BC_05x06(1:IIPAR, 1:J0_W, L, N) + + !Northern boundary, (J0_W + 1):(J0_W * 2) + STT(1:IIPAR, (JJPAR - J0_W + 1):JJPAR, L, N) + & = BC_05x06(1:IIPAR, (J0_W + 1):(J0_W * 2), L, N) + + !Western boundary, (J0_W * 2 + 1):(J0_W * 2 + I0_W) + STT_BC(1:JJPAR, 1:I0_W) + & = BC_05x06(1:JJPAR, (J0_W * 2 + 1):(J0_W * 2 + I0_W), L, N) + + STT(1:I0_W, 1:JJPAR, L, N) + & = TRANSPOSE(STT_BC) + + !Eestern boundary, (J0_W * 2 + I0_W + 1):((J0_W + I0_W)* 2) + STT_BC(1:JJPAR, 1:I0_W) + & = BC_05x06(1:JJPAR, (J0_W*2+I0_W +1):((J0_W+I0_W)*2), L, N) + + STT((IIPAR - I0_W + 1):IIPAR, 1:JJPAR, L, N) + & = TRANSPOSE(STT_BC) + + ENDDO + ENDDO +!!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE DO_WINDOW_TPCORE_BC_05x0666 + +!------------------------------------------------------------------------ + + SUBROUTINE CLEAN_WINDOW_TPCORE_BC +! +!****************************************************************************** +! Subroutine CLEAN_WINDOW_TPCORE_BC zeroes the boundary conditions array +! BC at each timestep. (bmy, 3/7/03, 7/20/04) +! +! NOTES: +! (1 ) Now references N_TRACERS from "tracer_mod.f" (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : N_TRACERS + USE LOGICAL_MOD, ONLY : LWINDO_NA, LWINDO_EU !(lzh,02/01/2015) + USE LOGICAL_MOD, ONLY : LWINDO_CH, LWINDO_CU + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! CLEAN_WINDOW_TPCORE_BC begins here! + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JM_BC + DO I = 1, IM_BC + BC(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !===== (lzh,02/01/2015)===== + IF ( LWINDO_NA ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JM_BC_NA + DO I = 1, IM_BC_NA + BC_NA(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + IF ( LWINDO_EU ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JM_BC_EU + DO I = 1, IM_BC_EU + BC_EU(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + IF ( LWINDO_CH ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JM_BC_CH + DO I = 1, IM_BC_CH + BC_CH(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ! Return to calling program + END SUBROUTINE CLEAN_WINDOW_TPCORE_BC + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEAN_WINDOW_TPCORE_BC_05x0666 +! +!****************************************************************************** +! Subroutine CLEAN_WINDOW_TPCORE_BC_05x0666 zeroes the boundary conditions array +! BC_05x06 at each timestep. (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! CLEAN_WINDOW_TPCORE_BC begins here! + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JM_BC_05x06 + DO I = 1, IM_BC_05x06 + BC_05x06(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE CLEAN_WINDOW_TPCORE_BC_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_WINDOW_TPCORE_BC +! +!****************************************************************************** +! Subroutine READ_WINDOW_TPCORE_BC reads tracer concentrations saved on the +! WINDOW REGION of a coarse-grid simulation (e.g. 4x5). These concentrations +! will be used as boundary conditions for TPCORE transport. (bmy, 3/7/03) +! +! NOTES: +! (1 ) LINUX has a problem putting a function call w/in a WRITE statement. +! Now save output from TIMESTAMP_STRING to STAMP and print that. +! (bmy, 9/29/03) +! (2 ) Now references N_TRACERS from "tracer_mod.f" (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE FILE_MOD, ONLY : IOERROR, IU_BC + USE TIME_MOD, ONLY : GET_TAU, TIMESTAMP_STRING + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, IOS, J, L + INTEGER :: NI, NJ, NL, NT + INTEGER :: NFOUND, IFIRST, JFIRST, LFIRST + INTEGER :: NSKIP, NTRACER, HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*4 :: ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: S = 'read_window_boundary' + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + ! For LINUX fix + CHARACTER(LEN=16) :: STAMP + + !================================================================= + ! READ_WINDOW_TPCORE_BC begins here! + !================================================================= + IF ( ITS_TIME_FOR_BC() ) THEN + + ! Open boundary conditions file (if necessary) + ! (lzh,02/01/2015) add multiple nested domains + CALL OPEN_BC_FILE( FOR_READ=.TRUE., WINDOW=5 ) + + ! Initialize # of tracers found + NFOUND = 0 + + ! Loop + DO + + !=========================================================== + ! Read each data block one at a time + !=========================================================== + + ! Read first header line + READ( IU_BC, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_BC, S//':1' ) + + ! Read second header line + READ( IU_BC, IOSTAT=IOS ) + & CATEGORY, NT, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_BC, S//':2' ) + + ! Read data array + READ( IU_BC, IOSTAT=IOS ) ARRAY(1:NI,1:NJ,1:NL) + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_BC, S//':3' ) + + !=========================================================== + ! If this is the right time, then save into BC array + !=========================================================== + IF ( GET_TAU() == ZTAU0 ) THEN + + ! Copy into the BC array + DO L = 1, NL + BC( 1:IM_BC, 1:JM_BC, L, NT ) = ARRAY(1:NI, 1:NJ, L) + ENDDO + + ! Increment count of tracers found + NFOUND = NFOUND + 1 + ENDIF + + !=========================================================== + ! Exit if we've found all tracers for this TAU value + !=========================================================== + IF ( NFOUND == N_TRACERS ) THEN + + ! Echo output + STAMP = TIMESTAMP_STRING() + WRITE( 6, 100 ) N_TRACERS, STAMP + 100 FORMAT( ' - READ_WINDOW_TPCORE_BC: Found all ', + & i3, ' BC''s at ', a ) + EXIT + ENDIF + ENDDO + ENDIF + + ! Return to calling program + END SUBROUTINE READ_WINDOW_TPCORE_BC + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_WINDOW_TPCORE_BC_05x0666 +! +!****************************************************************************** +! Subroutine READ_WINDOW_TPCORE_BC_05x0666 reads tracer concentrations saved on the +! WINDOW REGION. These concentrations will be used as boundary conditions for TPCORE transport. (bmy, 3/7/03) +! (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE FILE_MOD, ONLY : IOERROR, IU_BC_05x06 + USE TIME_MOD, ONLY : GET_TAU, TIMESTAMP_STRING + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, IOS, J, L + INTEGER :: NI, NJ, NL, NT + INTEGER :: NFOUND, IFIRST, JFIRST, LFIRST + INTEGER :: NSKIP, NTRACER, HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*4 :: ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: S = 'read_window_boundary' + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + ! For LINUX fix + CHARACTER(LEN=16) :: STAMP + + !================================================================= + ! READ_WINDOW_TPCORE_BC begins here! + !================================================================= + IF ( ITS_TIME_FOR_BC_05x0666() ) THEN + + ! Open boundary conditions file (if necessary) + CALL OPEN_BC_FILE_05x0666( FOR_READ=.TRUE. ) + + ! Initialize # of tracers found + NFOUND = 0 + + ! Loop + DO + + !=========================================================== + ! Read each data block one at a time + !=========================================================== + + ! Read first header line + READ( IU_BC_05x06, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_BC_05x06, S//':1' ) + + ! Read second header line + READ( IU_BC_05x06, IOSTAT=IOS ) + & CATEGORY, NT, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_BC_05x06, S//':2' ) + + ! Read data array + READ( IU_BC_05x06, IOSTAT=IOS ) ARRAY(1:NI,1:NJ,1:NL) + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_BC_05x06, S//':3' ) + + !=========================================================== + ! If this is the right time, then save into BC array + !=========================================================== + IF ( GET_TAU() == ZTAU0 ) THEN + + ! Copy into the BC array + DO L = 1, NL + BC_05x06( 1:IJ_BC_05x06, 1:((I0_W + J0_W)*2), L, NT ) + & = ARRAY(1:NI, 1:NJ, L) + ENDDO + + ! Increment count of tracers found + NFOUND = NFOUND + 1 + ENDIF + + !=========================================================== + ! Exit if we've found all tracers for this TAU value + !=========================================================== + IF ( NFOUND == N_TRACERS ) THEN + + ! Echo output + STAMP = TIMESTAMP_STRING() + WRITE( 6, 100 ) N_TRACERS, STAMP + 100 FORMAT( ' - READ_WINDOW_TPCORE_BC: Found all ', + & i3, ' BC''s at ', a ) + EXIT + ENDIF + ENDDO + ENDIF + + ! Return to calling program + END SUBROUTINE READ_WINDOW_TPCORE_BC_05x0666 + +!------------------------------------------------------------------------------ + + FUNCTION GET_4x5_BC( I_1x1, J_1x1, L_1x1, N_1x1 ) RESULT( VALUE ) +! +!****************************************************************************** +! Function GET_4x5_BC returns a value from the 4x5 BC boundary conditions +! array at the location of a 1x1 grid box. (yxw, bmy, 3/7/03) +! +! For now we will assume that we have saved tracer concentrations from a +! 4x5 window whioh overlays the corresponding 1x1 WINDOW REGION. These 4x5 +! tracer concentrations are used as boundary conditions for TPCORE. +! +! We assume that we won't be saving 2x2.5 boundary conditions anytime in the +! near future since it currently takes too long to run a 2x2.5 full-chemistry +! simulation for a whole year. However, if we ever do save 2x25 boundary +! conditions, one may always write a corresponding subroutine GET_2x25_BC to +! do the mapping from 1x1 -> 2x25. (yxw, bmy, 3/7/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I_1x1 (INTEGER) : Longitude index of 1x1 grid box +! (2 ) J_1x1 (INTEGER) : Latitude index of 1x1 grid box +! (3 ) L_1x1 (INTEGER) : Altitude index of 1x1 grid box +! (4 ) N_1x1 (INTEGER) : Tracer index of 1x1 grid box +! +! NOTES: +! (1 ) Rename arguments to avoid conflict w/ I1x1, J1x1 parameters in +! CMN_SIZE. (bmy, 10/24/05) +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! NTRACE + + ! Arguments + INTEGER, INTENT(IN) :: I_1x1, J_1x1, L_1x1, N_1x1 + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, II, J, JJ, JJ1 + REAL*8 :: X, Y + REAL*8, SAVE :: XE4x5(73), YE4x5(47) + + ! Function value + REAL*8 :: VALUE + + !================================================================= + ! GET_4x5_BC begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + + !============================================================== + ! Define lon & lat edges of the 4x5 grid -- we need to + ! use these to do the mapping from 1x1 --> 4x5 + !============================================================== + + ! Lon edges + DO I = 1, 73 + XE4x5(I) = -182.5d0 + 5 * ( I - 1 ) + ENDDO + + ! Lat edges + DO J = 2, 46 + YE4x5(J) = -92d0 + 4 * ( J - 1 ) + ENDDO + + ! Polar lats + YE4x5(1) = -90d0 + YE4x5(47) = +90d0 + + !============================================================== + ! Locate the 4x5 box(es) to which each 1x1 box belongs + ! X, Y are lon & lat centers of the 1x1 boxes in degrees + ! Save in the MAP1x1 array for future reference + !============================================================== + DO J = 1, JJPAR + Y = GET_YMID( J ) + + DO I = 1, IIPAR + X = GET_XMID( I ) + + ! Loop over 4x5 longitudes + DO II = 1, 72 + + ! If the 1x1 center lon lies w/in the 4x5 lon edges + ! then we have found the proper 4x5 box! + IF ( X > XE4x5(II) .and. X < XE4x5(II+1) ) THEN + MAP1x1(I,J,1) = II + EXIT + ENDIF + ENDDO + + ! Loop over 4x5 latitudes + DO JJ = 1, 46 + + ! If the 1x1 lat center lies between the 4x5 lat + ! edges, we have found the proper 4x5 box! + IF ( Y > YE4x5(JJ) .and. Y < YE4x5(JJ+1) ) THEN + MAP1x1(I,J,2) = JJ + MAP1x1(I,J,3) = 0 + EXIT + + ! If the 1x1 lat center equals the 4x5 lower lat + ! edge, then we need to average this 4x5 box and + ! the box just south of it + ELSE IF ( Y == YE4x5(JJ) ) THEN + MAP1x1(I,J,2) = JJ-1 + MAP1x1(I,J,3) = JJ + EXIT + + ! If the 1x1 lat center equals the 4x5 lower lat + ! edge, then we need to average this 4x5 box and + ! the box just north of it + ELSE IF ( Y == YE4x5(JJ+1) ) THEN + MAP1x1(I,J,2) = JJ + MAP1x1(I,J,3) = JJ+1 + EXIT + + ENDIF + ENDDO + ENDDO + ENDDO + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + !============================================================= + ! Locate the tracer concentration at the 4x5 box which + ! corresponds to the 1x1 box (I_1x1, J_1x1, L_1x1, N_1x1) + !============================================================= + + ! Get lon indices + II = MAP1x1( I_1x1, J_1x1, 1 ) - I0_BC + + ! Get lat indices + JJ = MAP1x1( I_1x1, J_1x1, 2 ) - J0_BC + JJ1 = MAP1x1( I_1x1, J_1x1, 3 ) - J0_BC + + ! Locate the 4x5 box(es) corresponding to the 1x1 box + ! If our 1x1 box straddles 2 4x5 boxes, average the 4x5 values + IF ( MAP1x1( I_1x1, J_1x1, 3 ) > 0 ) THEN + VALUE = 0.5 * ( BC(II,JJ,L_1x1,N_1x1) + BC(II,JJ1,L_1x1,N_1x1)) + ELSE + VALUE = BC(II,JJ,L_1x1,N_1x1) + ENDIF + + ! Return to calling program + END FUNCTION GET_4x5_BC + +!------------------------------------------------------------------------------ +! (lzh,02/01/2015) add 2x2.5 BC + + FUNCTION GET_2x25_BC( I_1x1, J_1x1, L_1x1, N_1x1 ) RESULT( VALUE ) +! +!****************************************************************************** +! Function GET_2x25_BC returns a value from the 2x2.5 BC boundary conditions +! array at the location of a 1x1 grid box. (yxw, bmy, 3/7/03) +! +! For now we will assume that we have saved tracer concentrations from a +! 2x25 window which overlays the corresponding 1x1 WINDOW REGION. These 2x2.5 +! tracer concentrations are used as boundary conditions for TPCORE. +! +! Arguments as Input: +! ============================================================================ +! (1 ) I_1x1 (INTEGER) : Longitude index of 1x1 grid box +! (2 ) J_1x1 (INTEGER) : Latitude index of 1x1 grid box +! (3 ) L_1x1 (INTEGER) : Altitude index of 1x1 grid box +! (4 ) N_1x1 (INTEGER) : Tracer index of 1x1 grid box +! +! NOTES: +! (1 ) Rename arguments to avoid conflict w/ I1x1, J1x1 parameters in +! CMN_SIZE. (bmy, 10/24/05) +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! NTRACE + + ! Arguments + INTEGER, INTENT(IN) :: I_1x1, J_1x1, L_1x1, N_1x1 + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, II, J, JJ, JJ1 + REAL*8 :: X, Y + REAL*8, SAVE :: XE2x25(145), YE2x25(92) + + ! Function value + REAL*8 :: VALUE + + !================================================================= + ! GET_2x25_BC begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + + !============================================================== + ! Define lon & lat edges of the 2x25 grid -- we need to + ! use these to do the mapping from 1x1 --> 2x25 + !============================================================== + + ! Lon edges + DO I = 1, 145 + XE2x25(I) = -181.25d0 + 2.5 * ( I - 1 ) + ENDDO + + ! Lat edges + DO J = 2, 91 + YE2x25(J) = -91d0 + 2 * ( J - 1 ) + ENDDO + + ! Polar lats + YE2x25(1) = -90d0 + YE2x25(92) = +90d0 + + !============================================================== + ! Locate the 2x25 box(es) to which each 1x1 box belongs + ! X, Y are lon & lat centers of the 1x1 boxes in degrees + ! Save in the MAP1x1 array for future reference + !============================================================== + DO J = 1, JJPAR + Y = GET_YMID( J ) + + DO I = 1, IIPAR + X = GET_XMID( I ) + + ! Loop over 2x25 longitudes + DO II = 1, 144 + + ! If the 1x1 center lon lies w/in the 2x25 lon edges + ! then we have found the proper 2x25 box! +!! IF ( X > XE2x25(II) .and. X < XE2x25(II+1) ) THEN +!! (lzh, 02/01/2014) + IF ( X >= XE2x25(II) .and. X < XE2x25(II+1) ) THEN + MAP1x1(I,J,1) = II + EXIT + ENDIF + ENDDO + + ! Loop over 2x25 latitudes + DO JJ = 1, 91 + + ! If the 1x1 lat center lies between the 2x25 lat + ! edges, we have found the proper 2x25 box! + IF ( Y > YE2x25(JJ) .and. Y < YE2x25(JJ+1) ) THEN + MAP1x1(I,J,2) = JJ + MAP1x1(I,J,3) = 0 + EXIT + + ! If the 1x1 lat center equals the 2x25 lower lat + ! edge, then we need to average this 2x25 box and + ! the box just south of it + ELSE IF ( Y == YE2x25(JJ) ) THEN + MAP1x1(I,J,2) = JJ-1 + MAP1x1(I,J,3) = JJ + EXIT + + ! If the 1x1 lat center equals the 2x25 lower lat + ! edge, then we need to average this 2x25 box and + ! the box just north of it + ELSE IF ( Y == YE2x25(JJ+1) ) THEN + MAP1x1(I,J,2) = JJ + MAP1x1(I,J,3) = JJ+1 + EXIT + + ENDIF + ENDDO + ENDDO + ENDDO + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + !============================================================= + ! Locate the tracer concentration at the 4x5 box which + ! corresponds to the 1x1 box (I_1x1, J_1x1, L_1x1, N_1x1) + !============================================================= + + ! Get lon indices + II = MAP1x1( I_1x1, J_1x1, 1 ) - I0_BC + + ! Get lat indices + JJ = MAP1x1( I_1x1, J_1x1, 2 ) - J0_BC + JJ1 = MAP1x1( I_1x1, J_1x1, 3 ) - J0_BC + + ! Locate the 2x25 box(es) corresponding to the 1x1 box + ! If our 1x1 box straddles 2 2x25 boxes, average the 2x25 values + IF ( MAP1x1( I_1x1, J_1x1, 3 ) > 0 ) THEN + VALUE = 0.5 * ( BC(II,JJ,L_1x1,N_1x1) + BC(II,JJ1,L_1x1,N_1x1)) + ELSE + VALUE = BC(II,JJ,L_1x1,N_1x1) + ENDIF + + ! Return to calling program + END FUNCTION GET_2x25_BC + +!------------------------------------------------------------------------------ + + FUNCTION ITS_TIME_FOR_BC() RESULT( FLAG ) +! +!****************************************************************************** +! Subroutine ITS_TIME_FOR_BC returns TRUE if it is time to read in the next +! set of boundary conditions for TPCORE, or FALSE otherwise. (bmy, 3/5/03) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE TIME_MOD, ONLY : GET_ELAPSED_MIN + + ! Function value + LOGICAL :: FLAG + + !================================================================= + ! ITS_TIME_FOR_BC begins here! + !================================================================= + FLAG = ( MOD( GET_ELAPSED_MIN(), TS_BC ) == 0 ) + + ! Return to calling program + END FUNCTION ITS_TIME_FOR_BC + +!------------------------------------------------------------------------------ + + FUNCTION ITS_TIME_FOR_BC_05x0666() RESULT( FLAG ) +! +!****************************************************************************** +! Subroutine ITS_TIME_FOR_BC_0666 returns TRUE if it is time to read in the next +! set of boundary conditions for TPCORE, or FALSE otherwise. (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE TIME_MOD, ONLY : GET_ELAPSED_MIN + + ! Function value + LOGICAL :: FLAG + + !================================================================= + ! ITS_TIME_FOR_BC begins here! + !================================================================= + FLAG = ( MOD( GET_ELAPSED_MIN(), TS_BC_05x06 ) == 0 ) + + ! Return to calling program + END FUNCTION ITS_TIME_FOR_BC_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_TPCORE_BC( TS, I0W, J0W, I1, J1, I2, J2 ) +! +!****************************************************************************** +! Subroutine INIT_TPCORE_BC initializes module variables and arrays +! (bmy, 2/10/03, 7/20/04) +! +! NOTES: +! (1 ) Now references N_TRACERS from "tracer_mod.f". Now references LWINDO +! from "logical_mod.f". Now references TPBC_DIR from "directory_mod.f". +! Now references ITS_A_NESTED_GRID from "grid_mod.f". Also added +! arguments to take values from "input_mod.f". (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE DIRECTORY_MOD, ONLY : TPBC_DIR + USE ERROR_MOD, ONLY : ALLOC_ERR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE GRID_MOD, ONLY : ITS_A_NESTED_GRID +! USE LOGICAL_MOD, ONLY : LWINDO + USE LOGICAL_MOD, ONLY : LWINDO, LWINDO_NA, LWINDO_CU !(lzh) + USE LOGICAL_MOD, ONLY : LWINDO_EU, LWINDO_CH + USE LOGICAL_MOD, ONLY : LWINDO2x25 + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: TS, I0W, J0W, I1, J1, I2, J2 + + ! Local variables + INTEGER :: AS, I, J + + !================================================================= + ! INIT_TPCORE_BC begins here! + !================================================================= + + ! Timestep for BC's [min] + TS_BC = TS + + !--------------------- + ! *** NESTED GRID *** + !--------------------- + + ! TPCORE transport region offsets + I0_W = I0W + J0_W = J0W + + ! Extent of TPCORE transport region + IM_W = IIPAR - ( 2 * I0_W ) + JM_W = JJPAR - ( 2 * J0_W ) + + ! I and J at lower-left corner of TPCORE transport region + I1_W = GET_XOFFSET( GLOBAL=.TRUE. ) + I0_W + 1 + J1_W = GET_YOFFSET( GLOBAL=.TRUE. ) + J0_W + 1 + + ! I and J at upper-right corner of TPCORE transport region + I2_W = GET_XOFFSET( GLOBAL=.TRUE. ) + IIPAR - I0_W + J2_W = GET_YOFFSET( GLOBAL=.TRUE. ) + JJPAR - J0_W + + ! IGZD = ? + IGZD = I0_W - 1 + + !--------------------- + ! *** GLOBAL GRID *** + !--------------------- + + ! Lower-left corner of coarse-grid BC WINDOW region + I1_BC = I1 + J1_BC = J1 + + ! Upper-right corner of coarse-grid BC WINDOW region + I2_BC = I2 + J2_BC = J2 + + ! Extent of coarse-grid BC REGION + IM_BC = I2_BC - I1_BC + 1 + JM_BC = J2_BC - J1_BC + 1 + + ! TPCORE internal transport window offset + I0_BC = I1_BC - 1 + J0_BC = J1_BC - 1 + + + IF (.not. LWINDO2x25) THEN +#if defined(GRID4x5) || defined(NESTED_NA) + +#if defined( GEOS_FP ) + !%%%%% 4x5 BC REGION FOR NORTH AMERICA NESTED GRID (GEOS_FP) + I1_BC_NA = 11 ! 4x5 lon index, LL corner + J1_BC_NA = 26 ! 4x5 lat index, LL corner + I2_BC_NA = 25 ! 4x5 lon index, UR corner + J2_BC_NA = 39 ! 4x5 lat index, UR corner +#else + !%%%%% 4x5 BC REGION FOR NORTH AMERICA NESTED GRID %%%%% + I1_BC_NA = 9 ! 4x5 lon index, LL corner + J1_BC_NA = 26 ! 4x5 lat index, LL corner + I2_BC_NA = 29 ! 4x5 lon index, UR corner + J2_BC_NA = 41 ! 4x5 lat index, UR corner +#endif + +#endif + ELSE +#if defined(GRID2x25) || defined(NESTED_NA) + +#if defined( GEOS_FP ) + !%%%%% 2x25 BC REGION FOR NORTH AMERICA NESTED GRID (GEOS_FP) + I1_BC_NA = 21 ! 2x25 lon index, LL corner + J1_BC_NA = 51 ! 2x25 lat index, LL corner + I2_BC_NA = 49 ! 2x25 lon index, UR corner + J2_BC_NA = 76 ! 2x25 lat index, UR corner +#else + !%%%%% 2x25 BC REGION FOR NORTH AMERICA NESTED GRID %%%%% + I1_BC_NA = 17 ! 2x25 lon index, LL corner + J1_BC_NA = 51 ! 2x25 lat index, LL corner + I2_BC_NA = 57 ! 2x25 lon index, UR corner + J2_BC_NA = 81 ! 2x25 lat index, UR corner +#endif + +#endif + ENDIF + + ! Extent of coarse-grid NA BC REGION + IM_BC_NA = I2_BC_NA - I1_BC_NA + 1 + JM_BC_NA = J2_BC_NA - J1_BC_NA + 1 + + ! TPCORE NA internal transport window offset + I0_BC_NA = I1_BC_NA - 1 + J0_BC_NA = J1_BC_NA - 1 + + IF (.not. LWINDO2x25) THEN +#if defined(GRID4x5) || defined(NESTED_EU) + ! Lower-left corner of coarse-grid EU BC WINDOW region + I1_BC_EU = 31 + J1_BC_EU = 31 + + ! Upper-right corner of coarse-grid EU BC WINDOW region + I2_BC_EU = 47 + J2_BC_EU = 41 +#endif + ELSE +#if defined(GRID2x25) || defined(NESTED_EU) + ! Lower-left corner of coarse-grid EU BC WINDOW region + I1_BC_EU = 61 + J1_BC_EU = 61 + + ! Upper-right corner of coarse-grid EU BC WINDOW region + I2_BC_EU = 93 + J2_BC_EU = 81 +#endif + ENDIF + + ! Extent of coarse-grid EU BC REGION + IM_BC_EU = I2_BC_EU - I1_BC_EU + 1 + JM_BC_EU = J2_BC_EU - J1_BC_EU + 1 + + ! TPCORE NA internal transport window offset + I0_BC_EU = I1_BC_EU - 1 + J0_BC_EU = J1_BC_EU - 1 + + IF (.not. LWINDO2x25) THEN +#if defined(GRID4x5) || defined(NESTED_CH) + +#if defined(GEOS_FP) + !!! (lzh,04/20/2014) + ! Lower-left corner of coarse-grid CH BC WINDOW region + I1_BC_CH = 51 + J1_BC_CH = 27 + + ! Upper-right corner of coarse-grid CH BC WINDOW region + I2_BC_CH = 65 + J2_BC_CH = 37 +#else + ! Lower-left corner of coarse-grid CH BC WINDOW region + I1_BC_CH = 51 + J1_BC_CH = 21 + + ! Upper-right corner of coarse-grid CH BC WINDOW region + I2_BC_CH = 67 + J2_BC_CH = 37 +#endif + +#endif + + ELSE + +#if defined(GRID2x25) || defined(NESTED_CH) + +#if defined( GEOS_FP ) + !!! (lzh,04/20/2014) + ! Lower-left corner of coarse-grid CH BC WINDOW region + I1_BC_CH = 101 + J1_BC_CH = 53 + + ! Upper-right corner of coarse-grid CH BC WINDOW region + I2_BC_CH = 129 + J2_BC_CH = 74 +#else + ! Lower-left corner of coarse-grid CH BC WINDOW region + I1_BC_CH = 101 + J1_BC_CH = 40 + + ! Upper-right corner of coarse-grid CH BC WINDOW region + I2_BC_CH = 133 + J2_BC_CH = 74 +#endif + +#endif + + ENDIF + + ! Extent of coarse-grid EU BC REGION + IM_BC_CH = I2_BC_CH - I1_BC_CH + 1 + JM_BC_CH = J2_BC_CH - J1_BC_CH + 1 + + ! TPCORE NA internal transport window offset + I0_BC_CH = I1_BC_CH - 1 + J0_BC_CH = J1_BC_CH - 1 + + ! Return if we are not saving 4x5 BC's + ! or if it's not a nested grid simulation + IF ( .not. ITS_A_NESTED_GRID() ) THEN + IF ( .not. LWINDO ) RETURN + ENDIF + + !================================================================= + ! Allocate and initialize arrays + !================================================================= +! ALLOCATE( BC( IM_BC, JM_BC, LLPAR, N_TRACERS ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) +! BC = 0e0 + + IF ( LWINDO_CU ) THEN + + ALLOCATE( BC( IM_BC, JM_BC, LLPAR, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) + BC = 0e0 + + ENDIF + + IF ( LWINDO_CH ) THEN + + ALLOCATE( BC_CH( IM_BC_CH, JM_BC_CH, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC_CH' ) + BC_CH = 0e0 + + ENDIF + + IF ( LWINDO_NA ) THEN + + ALLOCATE( BC_NA( IM_BC_NA, JM_BC_NA, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC_NA' ) + BC_NA = 0e0 + + ENDIF + + IF ( LWINDO_EU ) THEN + + ALLOCATE( BC_EU( IM_BC_EU, JM_BC_EU, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC_EU' ) + BC_EU = 0e0 + + ENDIF + + ! If running a nested simulation, just allocate the custom BC + ! array with nested dimensions +#if defined( NESTED_CH ) + I1_BC = I1_BC_CH + J1_BC = J1_BC_CH + I2_BC = I2_BC_CH + J2_BC = J2_BC_CH + IM_BC = IM_BC_CH + JM_BC = JM_BC_CH + I0_BC = I0_BC_CH + J0_BC = J0_BC_CH + + ALLOCATE( BC( IM_BC, JM_BC, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) + BC = 0e0 +#elif defined( NESTED_NA ) + I1_BC = I1_BC_NA + J1_BC = J1_BC_NA + I2_BC = I2_BC_NA + J2_BC = J2_BC_NA + IM_BC = IM_BC_NA + JM_BC = JM_BC_NA + I0_BC = I0_BC_NA + J0_BC = J0_BC_NA + + ALLOCATE( BC( IM_BC, JM_BC, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) + BC = 0e0 +#elif defined( NESTED_EU ) + I1_BC = I1_BC_EU + J1_BC = J1_BC_EU + I2_BC = I2_BC_EU + J2_BC = J2_BC_EU + IM_BC = IM_BC_EU + JM_BC = JM_BC_EU + I0_BC = I0_BC_EU + J0_BC = J0_BC_EU + + ALLOCATE( BC( IM_BC, JM_BC, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) + BC = 0e0 +#endif + + ALLOCATE( MAP1x1( IIPAR, JJPAR, 3 ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAP1x1' ) + MAP1x1 = 0 + + ! Return to calling program + END SUBROUTINE INIT_TPCORE_BC + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_TPCORE_BC_05x0666 +! +!****************************************************************************** +! Subroutine INIT_TPCORE_BC_05x0666 initializes module variables and arrays +! (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + INTEGER :: AS + + !================================================================= + ! INIT_TPCORE_BC_05x0666 begins here! + !================================================================= + + ! Parameters for smaller domain + ! Timestep for BC's [min] + TS_BC_05x06 = 60 + + ! Lower-left corner of coarse-grid BC WINDOW region + I1_BC_05x06 = 22 + J1_BC_05x06 = 7 + I1_BC_GLOBAL = 82 + J1_BC_GLOBAL = 207 + + ! Upper-right corner of coarse-grid BC WINDOW region + I2_BC_05x06 = 112 + J2_BC_05x06 = 95 + + ! Extent of coarse-grid BC REGION + IM_BC_05x06 = I2_BC_05x06 - I1_BC_05x06 + 1 + JM_BC_05x06 = J2_BC_05x06 - J1_BC_05x06 + 1 + + IF ( IM_BC_05x06 > JM_BC_05x06 ) THEN + IJ_BC_05x06 = IM_BC_05x06 + ELSE + IJ_BC_05x06 = JM_BC_05x06 + ENDIF + + !================================================================= + ! Allocate and initialize arrays + !================================================================= + ALLOCATE( BC_05x06( IJ_BC_05x06, (I0_W + J0_W)*2, + & LLPAR, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC_05x06' ) + BC_05x06 = 0e0 + + ! Return to calling program + END SUBROUTINE INIT_TPCORE_BC_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_TPCORE_BC +! +!****************************************************************************** +! Subroutine CLEANUP_TPCORE_BC deallocates all module arrays. (3/4/03) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_TPCORE_BC begins here! + !================================================================= + IF ( ALLOCATED( BC ) ) DEALLOCATE( BC ) + IF ( ALLOCATED( BC_NA ) ) DEALLOCATE( BC_NA ) + IF ( ALLOCATED( BC_EU ) ) DEALLOCATE( BC_EU ) + IF ( ALLOCATED( BC_CH ) ) DEALLOCATE( BC_CH ) + IF ( ALLOCATED( MAP1x1 ) ) DEALLOCATE( MAP1x1 ) + IF ( ALLOCATED( BC_05x06 ) ) DEALLOCATE( BC_05x06 ) + + ! Return to calling program + END SUBROUTINE CLEANUP_TPCORE_BC + +!------------------------------------------------------------------------------ + + END MODULE TPCORE_BC_MOD diff --git a/code/tpcore_bc_mod.f~ b/code/tpcore_bc_mod.f~ new file mode 100644 index 0000000..bd3aef6 --- /dev/null +++ b/code/tpcore_bc_mod.f~ @@ -0,0 +1,2068 @@ +! $Id: tpcore_bc_mod.f,v 1.2 2012/03/01 22:00:26 daven Exp $ + MODULE TPCORE_BC_MOD +! +!****************************************************************************** +! Module TPCORE_BC_MOD contains modules and variables which are needed to +! save and read TPCORE nested-grid boundary conditions to/from disk. +! (yxw, bmy, 3/4/03, 3/15/06) +! +! Module Variables: +! ============================================================================ +! (1 ) CLEAN_BC (LOGICAL ) : Flag which denotes if we will zero BC's +! (2 ) I0_W (INTEGER ) : Lon offset of 1x1 TPCORE REGION [# boxes] +! (3 ) J0_W (INTEGER ) : Lat offset of 1x1 TPCORE REGION [# boxes] +! (4 ) IM_W (INTEGER ) : Lon extent of 1x1 TPCORE REGION [# boxes] +! (5 ) JM_W (INTEGER ) : Lat extent of 1x1 TPCORE REGION [# boxes] +! (6 ) I1_W (INTEGER ) : Lower left-hand lon index of 1x1 WINDOW +! (7 ) J1_W (INTEGER ) : Lower left-hand lat index of 1x1 WINDOW +! (8 ) I2_W (INTEGER ) : Upper right-hand lon index of 1x1 WINDOW +! (9 ) J2_W (INTEGER ) : Upper right-hand lat index of 1x1 WINDOW +! (10) IGZD (INTEGER ) : ??? +! (110 TS_BC (INTEGER ) : Timestep for reading in BC's from disk [min] +! (11) I0_BC (INTEGER ) : Lon offset of 4x5 WINDOW REGION [# boxes] +! (12) J0_BC (INTEGER ) : Lat offset of 4x5 WINDOW REGION [# boxes] +! (13) IM_BC (INTEGER ) : Lon extent of 4x5 WINDOW REGION [# boxes] +! (14) JM_BC (INTEGER ) : Lat extent of 4x5 WINDOW REGION [# boxes] +! (15) I1_BC (INTEGER ) : Lower left-hand lon index of 4x5 WINDOW +! (16) J1_BC (INTEGER ) : Lower left-hand lat index of 4x5 WINDOW +! (17) I2_BC (INTEGER ) : Upper right-hand lon index of 4x5 WINDOW +! (18) J2_BC (INTEGER ) : Upper right-hand lat index of 4x5 WINDOW +! (19) BC (REAL*4 ) : Array containing tracers on coarse grid +! (19b) BC_NA (REAL*4 ) : Array containing NA tracers on coarse grid +! (19c) BC_EU (REAL*4 ) : Array containing EU tracers on coarse grid +! (19d) BC_CH (REAL*4 ) : Array containing CH tracers on coarse grid +! (20) MAP1x1 (INTEGER ) : Mapping array from 1x1 -> 4x5 grid +! +! Module Routines: +! ============================================================================ +! (1 ) SET_CLEAN_BC : Initializes the CLEAN_BC module variable +! (2 ) OPEN_BC_FILE : Opens a new boundary conditions file (R or W) +! (3 ) SAVE_GLOBAL_TPCORE_BC : Saves boundary conditions from GLOBAL run +! (4 ) DO_WINDOW_TPCORE_BC : Calls routine to clean or read window BC's +! (5 ) CLEAN_WINDOW_TPCORE_BC : Zeroes the nested-grid TPCORE boundary cond's +! (6 ) READ_WINDOW_TPCORE_BC : Reads nested-grid TPCORE BC's from disk +! (7 ) GET_4x5_BC : Returns the 4x5 BC at a given 1x1 location +! (7b) GET_2x25_BC : Returns the 2x2.5 BC at a given 1x1 location +! (8 ) ITS_TIME_FOR_BC : Returns T if it is time to read BC's +! (9 ) INIT_TPCORE_BC : Initalizes and allocates module variables +! (10) CLEANUP_TPCORE_BC : Deallocates module vaf +! +! GEOS-CHEM modules referenced by tpcore_call_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module containing routines for bpch file I/O +! (2 ) directory_mod.f : Module containing GEOS-CHEM data & metfld dirs +! (3 ) error_mod.f : Module containing I/O error/NaN check routines +! (4 ) file_mod.f : Contains file unit numbers and error checks +! (5 ) grid_mod.f : Module containing horizontal grid information +! (6 ) logical_mod.f : Module containing GEOS-CHEM logical switches +! (7 ) time_mod.f : Module containing routines for date & time +! (8 ) tracer_mod.f : Module containing GEOS-CHEM tracer array STT +! +! Reference Diagram: +! ============================================================================ +! +! <-------------------------------------- IGLOB ----------------------> +! +! +-------------------------------------------------------------------+ ^ +! | GLOBAL REGION | | +! | | | +! | <-------------- IIPAR -------------> | | +! | | | +! | +=================================[Y] ^ | | +! | | WINDOW REGION (met field size) | | | | +! | | | | | | +! | | <------- IM_W -------> | | | | +! | | +--------------------+ ^ | | | | +! | | | TPCORE REGION | | | | | | +! | | | (transport is | | | | | | +! |<------- I0 ---------->|<---->| done in this | JM_W | JJPAR | JGLOB +! | | I0_W | window!!!) | | | | | | +! | | | | | | | | | +! | | +--------------------+ V | | | | +! | | ^ | | | | +! | | | J0_W | | | | +! | | V | | | | +! | [X]=================================+ V | | +! | ^ | | +! | | J0 | | +! | V | | +! [1]------------------------------------------------------------------+ V +! +! DIAGRAM NOTES: +! (a) The outermost box ("Global Region") is the global grid size. This +! region has IGLOB boxes in longitude and JGLOB boxes in latitude. +! The origin of the "Global Region" is at the south pole, at the +! lower left-hand corner (point [1]). +! +! (b) The next innermost box ("Window Region") is the nested-grid window. +! This region has IIPAR boxes in longitude and JJPAR boxes in latitude. +! This is the size of the trimmed met fields that will be used for +! a 1 x 1 "nested-grid" simulation. +! +! (c) The innermost region ("TPCORE Region") is the actual area in which +! TPCORE transport will be performed. Note that this region is smaller +! than the "Window Region". It is set up this way since a cushion of +! grid boxes is needed TPCORE Region for boundary conditions. +! +! (d) I0 is the longitude offset (# of boxes) and J0 is the latitude offset +! (# of boxes) which translate between the "Global Region" and the +! "Window Region". +! +! (e) I0_W is the longitude offset (# of boxes), and J0_W is the latitude +! offset (# of boxes) which translate between the "Window Region" +! and the "TPCORE Region". +! +! (f) The lower left-hand corner of the "Window Region" (point [X]) has +! longitude and latitude indices (I1_W, J1_W). Similarly, the upper +! right-hand corner (point [Y]) has longitude and latitude indices +! (I2_W, J2_W). +! +! (g) Note that if I0=0, J0=0, I0_W=0, J0_W=0, IIPAR=IGLOB, JJPAR=JGLOB +! specifies a global simulation. In this case the "Window Region" +! totally coincides with the "Global Region". +! +! (h) In order for the nested-grid to work we must save out concentrations +! over the WINDOW REGION from a coarse model (e.g. 4x5) corresponding to +! the same WINDOW REGION at 1x1. These concentrations are copied along +! the edges of the 1x1 WINDOW REGION and are thus used as boundary +! conditions for TPCORE. We assume that we will save out concentrations +! from the 4x5 model since presently it takes too long to run at 2x25. +! +! NOTES: +! (1 ) Bug fix for LINUX w/ TIMESTAMP_STRING (bmy, 9/29/03) +! (2 ) Now references "tracer_mod.f", "directory_mod.f", and +! "logical_mod.f" (bmy, 7/20/04) +! (3 ) Now get HALFPOLAR for GEOS or GCAP grids (bmy, 6/28/05) +! (4 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (5 ) Rename arguments in GET_4x5_BC to avoid name conflict (bmy, 10/24/05) +! (6 ) Now use EXPAND_DATE instead of obsolete DATE_STRING (bmy, 3/15/06) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "tpcore_bc_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these variables ... + PUBLIC :: I0_W, J0_W + PUBLIC :: I1_W, J1_W + PUBLIC :: I2_W, J2_W + PUBLIC :: IM_W, JM_W + PUBLIC :: IGZD + + ! ... and these routines + PUBLIC :: INIT_TPCORE_BC + PUBLIC :: INIT_TPCORE_BC_05x0666 + PUBLIC :: DO_WINDOW_TPCORE_BC + PUBLIC :: DO_WINDOW_TPCORE_BC_05x0666 + PUBLIC :: DO_WINDOW_TPCORE_BC_ADJ + PUBLIC :: SET_CLEAN_BC + PUBLIC :: SAVE_GLOBAL_TPCORE_BC + PUBLIC :: SAVE_GLOBAL_TPCORE_BC_05x0666 + + !================================================================= + ! MODULE VARIABLES + !================================================================= + LOGICAL :: CLEAN_BC + INTEGER :: I0_W, J0_W, IM_W, JM_W + INTEGER :: I1_W, J1_W, I2_W, J2_W + INTEGER :: I0_BC, J0_BC, I1_BC, J1_BC + INTEGER :: I2_BC, J2_BC, IM_BC, JM_BC + INTEGER :: I0_BC_NA, J0_BC_NA, I1_BC_NA, J1_BC_NA !!(lzh,02/01/2015) + INTEGER :: I2_BC_NA, J2_BC_NA, IM_BC_NA, JM_BC_NA + INTEGER :: I0_BC_EU, J0_BC_EU, I1_BC_EU, J1_BC_EU + INTEGER :: I2_BC_EU, J2_BC_EU, IM_BC_EU, JM_BC_EU + INTEGER :: I0_BC_CH, J0_BC_CH, I1_BC_CH, J1_BC_CH + INTEGER :: I2_BC_CH, J2_BC_CH, IM_BC_CH, JM_BC_CH + INTEGER :: IGZD, TS_BC + INTEGER, ALLOCATABLE :: MAP1x1(:,:,:) + REAL*4, ALLOCATABLE :: BC(:,:,:,:) + REAL*4, ALLOCATABLE :: BC_NA(:,:,:,:) ! (lzh,02/01/2015) + REAL*4, ALLOCATABLE :: BC_EU(:,:,:,:) + REAL*4, ALLOCATABLE :: BC_CH(:,:,:,:) + + !================================================================= + ! MODULE VARIABLES FOR 05x0666 BC (Zhe, Jan 2012) + !================================================================= + INTEGER :: I1_BC_05x06, J1_BC_05x06 + INTEGER :: I1_BC_GLOBAL, J1_BC_GLOBAL + INTEGER :: I2_BC_05x06, J2_BC_05x06 + INTEGER :: IM_BC_05x06, JM_BC_05x06 + INTEGER :: TS_BC_05x06, IJ_BC_05x06 + REAL*4, ALLOCATABLE :: BC_05x06(:,:,:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE SET_CLEAN_BC( THIS_CLEAN_BC ) +! +!****************************************************************************** +! Subroutine SET_CLEAN_BC initializes the CLEAN_BC logical flag. CLEAN_BC +! decides whether or not we will zero the nested-grid tpcore boundary. +! (bmy, 3/4/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) THIS_CLEAN_BC (LOGICAL) : Logical value (T/F) to assign to CLEAN_BC +! +! NOTES: +!****************************************************************************** +! + ! Arguments + LOGICAL, INTENT(IN) :: THIS_CLEAN_BC + + !================================================================= + ! SET_CLEAN_BC begins here! + !================================================================= + CLEAN_BC = THIS_CLEAN_BC + + ! Return to calling program + END SUBROUTINE SET_CLEAN_BC + +!------------------------------------------------------------------------------ + +! update nested runs based on standard GC (lzh,02/01/2015) + SUBROUTINE OPEN_BC_FILE( FOR_READ, FOR_WRITE, WINDOW ) +! +!****************************************************************************** +! Subroutine OPEN_BC_FILE opens the file which contains boundary conditions +! saved from the coarse-grid WINDOW REGION for either reading or writing. +! (bmy, 3/7/03, 3/15/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FOR_READ (LOGICAL) : If passed, opens binary punch file for reading +! (2 ) FOR_WRITE (LOGICAL) : If passed, opens binary punch file for writing +! +! NOTES: +! (1 ) Now use ITS_A_NEW_DAY from "time_mod.f". Now references TPBC_DIR +! from "directory_mod.f" (bmy, 7/20/04) +! (2 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (3 ) DATE_STRING is now obsolete; use EXPAND_DATE instead (bmy, 3/15/06) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_WRITE + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_MOD, ONLY : TPBC_DIR + USE FILE_MOD, ONLY : IU_BC + USE DIRECTORY_MOD, ONLY : TPBC_DIR_CH, TPBC_DIR_EU, TPBC_DIR_NA + USE FILE_MOD, ONLY : IU_BC_NA, IU_BC_EU, IU_BC_CH !(lzh,02/01/2015) + USE TIME_MOD, ONLY : EXPAND_DATE, GET_NYMD, ITS_A_NEW_DAY + + IMPLICIT NONE + +# include "define.h" ! Size parameters + + ! Arguments + LOGICAL, INTENT(IN), OPTIONAL :: FOR_READ, FOR_WRITE + INTEGER, INTENT(IN) :: WINDOW !(lzh,02/01/2015) + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! OPEN_BC_FILE begins here! + !================================================================= + + ! Only open file if it's a new day + IF ( ITS_A_NEW_DAY() ) THEN + + ! File name for BC's +! (lzh, 02/01/2015) + IF ( WINDOW .eq. 5 ) THEN +#if defined( NESTED_NA ) + FILENAME = TRIM( TPBC_DIR_NA ) // 'BC.YYYYMMDD' +#elif defined( NESTED_EU ) + FILENAME = TRIM( TPBC_DIR_EU ) // 'BC.YYYYMMDD' +#elif defined( NESTED_CH ) + FILENAME = TRIM( TPBC_DIR_CH ) // 'BC.YYYYMMDD' +#endif + ELSEIF ( WINDOW .eq. 1 ) THEN + FILENAME = TRIM( TPBC_DIR ) // 'BC.YYYYMMDD' + ELSEIF ( WINDOW .eq. 2 ) THEN + FILENAME = TRIM( TPBC_DIR_NA ) // 'BC.YYYYMMDD' + ELSEIF ( WINDOW .eq. 3 ) THEN + FILENAME = TRIM( TPBC_DIR_EU ) // 'BC.YYYYMMDD' + ELSEIF ( WINDOW .eq. 4 ) THEN + FILENAME = TRIM( TPBC_DIR_CH ) // 'BC.YYYYMMDD' + ENDIF + + ! Replace YYYYMMDD with the actual date + CALL EXPAND_DATE( FILENAME, GET_NYMD(), 000000 ) + + ! Echo file name to stdout + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - OPEN_BC_FILE: Opening ', a ) + + ! Open file for reading or writing +! IF ( PRESENT( FOR_WRITE ) ) THEN +! CALL OPEN_BPCH2_FOR_WRITE( IU_BC, FILENAME ) +! +! ELSE IF ( PRESENT( FOR_READ ) ) THEN +! CALL OPEN_BPCH2_FOR_READ( IU_BC, FILENAME ) +! +! ENDIF + +! (lzh, 02/01/2015) + IF ( WINDOW .eq. 5 ) THEN + IF ( PRESENT( FOR_READ ) ) + & CALL OPEN_BPCH2_FOR_READ( IU_BC, + & FILENAME ) + ELSEIF ( WINDOW .eq. 1 ) THEN + IF ( PRESENT( FOR_WRITE ) ) + & CALL OPEN_BPCH2_FOR_WRITE( IU_BC, + & FILENAME ) + ELSEIF ( WINDOW .eq. 2 ) THEN + IF ( PRESENT( FOR_WRITE ) ) + & CALL OPEN_BPCH2_FOR_WRITE( IU_BC_NA, + & FILENAME ) + ELSEIF ( WINDOW .eq. 3 ) THEN + IF ( PRESENT( FOR_WRITE ) ) + & CALL OPEN_BPCH2_FOR_WRITE( IU_BC_EU, + & FILENAME ) + ELSEIF ( WINDOW .eq. 4 ) THEN + IF ( PRESENT( FOR_WRITE ) ) + & CALL OPEN_BPCH2_FOR_WRITE( IU_BC_CH, + & FILENAME ) + ENDIF + + ENDIF + + ! Return to calling program + END SUBROUTINE OPEN_BC_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE OPEN_BC_FILE_05x0666( FOR_READ, FOR_WRITE ) +! +!****************************************************************************** +! Subroutine OPEN_BC_FILE_05x0666 opens the file which contains boundary conditions +! saved from 05x0666 nested simulation for either reading or writing. +! (Zhe, Jan 2012) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FOR_READ (LOGICAL) : If passed, opens binary punch file for reading +! (2 ) FOR_WRITE (LOGICAL) : If passed, opens binary punch file for writing +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_WRITE + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE DIRECTORY_MOD, ONLY : TPBC_DIR + USE FILE_MOD, ONLY : IU_BC_05x06 + USE TIME_MOD, ONLY : EXPAND_DATE, GET_NYMD, ITS_A_NEW_DAY + + ! Arguments + LOGICAL, INTENT(IN), OPTIONAL :: FOR_READ, FOR_WRITE + + ! Local variables + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! OPEN_BC_FILE_05x0666 begins here! + !================================================================= + + ! Only open file if it's a new day + IF ( ITS_A_NEW_DAY() ) THEN + + ! File name for BC's + FILENAME = TRIM( TPBC_DIR ) // 'BC.YYYYMMDD' // '.05x0666' + + ! Replace YYYYMMDD with the actual date + CALL EXPAND_DATE( FILENAME, GET_NYMD(), 000000 ) + + ! Echo file name to stdout + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - OPEN_BC_FILE: Opening ', a ) + + ! Open file for reading or writing + IF ( PRESENT( FOR_WRITE ) ) THEN + CALL OPEN_BPCH2_FOR_WRITE( IU_BC_05x06, FILENAME ) + + ELSE IF ( PRESENT( FOR_READ ) ) THEN + CALL OPEN_BPCH2_FOR_READ( IU_BC_05x06, FILENAME ) + + ENDIF + ENDIF + + ! Return to calling program + END SUBROUTINE OPEN_BC_FILE_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE SAVE_GLOBAL_TPCORE_BC +! +!****************************************************************************** +! Subroutine SAVE_GLOBAL_TPCORE_BC saves concentrations from the WINDOW +! REGION of a coarse-resolution model run (e.g. 4x5) to a bpch file. +! A new boundary conditions file is created for each day. +! (yxw, bmy, 3/4/03, 10/3/05) +! +! NOTES: +! (1 ) Now references N_TRACERS and STT from "tracer_mod.f". Also now +! references TIMESTAMP_STRING from "time_mod.f". (bmy, 7/20/04) +! (2 ) Now call GET_HALFPOLAR from "bpch2_mod.f" to get the HALFPOLAR flag +! value for GEOS or GCAP grids (bmy, 6/28/05) +! (3 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : BPCH2, GET_HALFPOLAR, GET_MODELNAME + USE FILE_MOD, ONLY : IU_BC + USE FILE_MOD, ONLY : IU_BC_NA, IU_BC_EU, IU_BC_CH !(lzh,02/01/2015) + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, + & GET_TAU, TIMESTAMP_STRING + USE TRACER_MOD, ONLY : N_TRACERS, STT + USE LOGICAL_MOD, ONLY : LWINDO_CU, LWINDO_NA !(lzh,02/01/2015) + USE LOGICAL_MOD, ONLY : LWINDO_CH, LWINDO_EU + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: HALFPOLAR + INTEGER, PARAMETER :: CENTER180 = 1 + INTEGER :: I, IOS, J, L, N + REAL*4 :: LONRES, LATRES + REAL*4 :: ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: TAU + CHARACTER(LEN=16) :: STAMP + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY = 'IJ-AVG-$' + CHARACTER(LEN=40) :: UNIT = 'v/v' + CHARACTER(LEN=40) :: RESERVED = '' + INTEGER :: IC ! (lzh,02/01/2015) + + !================================================================= + ! SAVE_GLOBAL_TPCORE_BC begins here! + !================================================================= + + ! Return if it's not time to write data to disk + IF ( .not. ITS_TIME_FOR_BC() ) RETURN + +! (lzh,02/01/2015) open below +! ! Open file for writing, if necessary +! CALL OPEN_BC_FILE( FOR_WRITE=.TRUE. ) + + !================================================================= + ! Save boundary conditions from coarse grid to a BPCH file + !================================================================= + + ! Define variables for BPCH output + LONRES = DISIZE + LATRES = DJSIZE + HALFPOLAR = GET_HALFPOLAR() + MODELNAME = GET_MODELNAME() + TAU = GET_TAU() + +! (lzh,02/01/2015) add all nested domains as in standard GC + DO IC = 1, 4 + IF ((IC .eq. 1) .and. LWINDO_CU )THEN + + ! Open file for writing, if necessary + CALL OPEN_BC_FILE( FOR_WRITE=.TRUE., WINDOW=IC) + + ! Loop over each tracer + DO N = 1, N_TRACERS + + ! Save concentrations in WINDOW REGION to disk + DO L = 1, LLPAR + BC(1:IM_BC,1:JM_BC,L,N) = + & STT(I1_BC:I2_BC,J1_BC:J2_BC,L,N) + ENDDO + + ! Write boundary conditions to binary punch file + CALL BPCH2( IU_BC, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IM_BC, JM_BC, LLPAR, I1_BC, + & J1_BC, 1, BC(1:IM_BC, 1:JM_BC, 1:LLPAR, N) ) + + ENDDO + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 110 ) STAMP + 110 FORMAT( ' - SAVE_GLOBAL_TPCORE_BC: Wrote BC''s at ', a ) + + ELSEIF ((IC .eq. 2) .and. LWINDO_NA )THEN + + ! Open file for writing, if necessary + CALL OPEN_BC_FILE( FOR_WRITE=.TRUE., WINDOW=IC) + + ! Loop over each tracer + DO N = 1, N_TRACERS + + ! Save concentrations in WINDOW REGION to disk + DO L = 1, LLPAR + BC_NA(1:IM_BC_NA,1:JM_BC_NA,L,N) = + & STT(I1_BC_NA:I2_BC_NA,J1_BC_NA:J2_BC_NA,L,N) + ENDDO + + ! Write boundary conditions to binary punch file + CALL BPCH2( IU_BC_NA, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IM_BC_NA, JM_BC_NA, LLPAR, I1_BC_NA, + & J1_BC_NA, 1, BC_NA(1:IM_BC_NA, 1:JM_BC_NA, + & 1:LLPAR, N) ) + + ENDDO + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 111 ) STAMP + 111 FORMAT( ' - SAVE_GLOBAL_TPCORE_BC: Wrote NA BC''s at ', a ) + + ELSEIF ((IC .eq. 3) .and. LWINDO_EU )THEN + + ! Open file for writing, if necessary + CALL OPEN_BC_FILE( FOR_WRITE=.TRUE., WINDOW=IC) + + ! Loop over each tracer + DO N = 1, N_TRACERS + + ! Save concentrations in WINDOW REGION to disk + DO L = 1, LLPAR + BC_EU(1:IM_BC_EU,1:JM_BC_EU,L,N) = + & STT(I1_BC_EU:I2_BC_EU,J1_BC_EU:J2_BC_EU,L,N) + ENDDO + + ! Write boundary conditions to binary punch file + CALL BPCH2( IU_BC_EU, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IM_BC_EU, JM_BC_EU, LLPAR, I1_BC_EU, + & J1_BC_EU, 1, BC_EU(1:IM_BC_EU, 1:JM_BC_EU, + & 1:LLPAR, N) ) + + ENDDO + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 112 ) STAMP + 112 FORMAT( ' - SAVE_GLOBAL_TPCORE_BC: Wrote EU BC''s at ', a ) + + ELSEIF ((IC .eq. 4) .and. LWINDO_CH )THEN + + ! Open file for writing, if necessary + CALL OPEN_BC_FILE( FOR_WRITE=.TRUE., WINDOW=IC) + + ! Loop over each tracer + DO N = 1, N_TRACERS + + ! Save concentrations in WINDOW REGION to disk + DO L = 1, LLPAR + BC_CH(1:IM_BC_CH,1:JM_BC_CH,L,N) = + & STT(I1_BC_CH:I2_BC_CH,J1_BC_CH:J2_BC_CH,L,N) + ENDDO + + ! Write boundary conditions to binary punch file + CALL BPCH2( IU_BC_CH, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IM_BC_CH, JM_BC_CH, LLPAR, I1_BC_CH, + & J1_BC_CH, 1, BC_CH(1:IM_BC_CH, 1:JM_BC_CH, + & 1:LLPAR, N) ) + + ENDDO + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 113 ) STAMP + 113 FORMAT( ' - SAVE_GLOBAL_TPCORE_BC: Wrote CH BC''s at ', a ) + + ENDIF + ENDDO + + ! Return to calling program + END SUBROUTINE SAVE_GLOBAL_TPCORE_BC + +!------------------------------------------------------------------------ + + SUBROUTINE SAVE_GLOBAL_TPCORE_BC_05x0666 +! +!****************************************************************************** +! Subroutine SAVE_GLOBAL_TPCORE_BC_05x0666 saves concentrations from the 05x0666 +! simulation to a smaller nested region. +! A new boundary conditions file is created for each day. +! (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : BPCH2, GET_HALFPOLAR, GET_MODELNAME + USE FILE_MOD, ONLY : IU_BC_05x06 + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS, + & GET_TAU, TIMESTAMP_STRING + USE TRACER_MOD, ONLY : N_TRACERS, STT + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: HALFPOLAR + INTEGER, PARAMETER :: CENTER180 = 1 + INTEGER :: I, IOS, J, L, N + REAL*4 :: LONRES, LATRES + REAL*4 :: ARRAY(IIPAR,JJPAR,LLPAR) + REAL*4 :: STT_BC(I0_W,JM_BC_05x06) + REAL*8 :: TAU + CHARACTER(LEN=16) :: STAMP + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY = 'IJ-AVG-$' + CHARACTER(LEN=40) :: UNIT = 'v/v' + CHARACTER(LEN=40) :: RESERVED = '' + + !================================================================= + ! SAVE_GLOBAL_TPCORE_BC_05x0666 begins here! + !================================================================= + + ! Return if it's not time to write data to disk + IF ( .not. ITS_TIME_FOR_BC_05x0666() ) RETURN + + ! Open file for writing, if necessary + CALL OPEN_BC_FILE_05x0666( FOR_WRITE=.TRUE. ) + + !================================================================= + ! Save boundary conditions from coarse grid to a BPCH file + !================================================================= + + ! Define variables for BPCH output + LONRES = DISIZE + LATRES = DJSIZE + HALFPOLAR = GET_HALFPOLAR() + MODELNAME = GET_MODELNAME() + TAU = GET_TAU() + + ! Loop over each tracer + DO N = 1, N_TRACERS + + ! We only save concentrations in CUSHION to save disk space + DO L = 1, LLPAR + + !Southern boundary, 1:J0_W + BC_05x06(1:IM_BC_05x06, 1:J0_W, L, N) + & = STT(I1_BC_05x06:I2_BC_05x06, + & J1_BC_05x06:(J1_BC_05x06 + J0_W - 1), L, N) + + !Northern boundary, (J0_W + 1):(J0_W * 2) + BC_05x06(1:IM_BC_05x06, (J0_W + 1):(J0_W * 2), L, N) + & = STT(I1_BC_05x06:I2_BC_05x06, + & (J2_BC_05x06 - J0_W + 1):J2_BC_05x06, L, N) + + !Western boundary, (J0_W * 2 + 1):(J0_W * 2 + I0_W) + STT_BC(1:I0_W, 1:JM_BC_05x06) + & = STT(I1_BC_05x06:(I1_BC_05x06 + I0_W - 1), + & J1_BC_05x06:J2_BC_05x06, L, N) + + BC_05x06(1:JM_BC_05x06, + & (J0_W * 2 + 1):(J0_W * 2 + I0_W), L, N) + & = TRANSPOSE(STT_BC) + + !Eestern boundary, (J0_W * 2 + I0_W + 1):((J0_W + I0_W)* 2) + STT_BC(1:I0_W, 1:JM_BC_05x06) + & = STT((I2_BC_05x06 - I0_W + 1):I2_BC_05x06, + & J1_BC_05x06:J2_BC_05x06, L, N) + + BC_05x06(1:JM_BC_05x06, + & (J0_W * 2 + I0_W + 1):((J0_W + I0_W)* 2), L, N) + & = TRANSPOSE(STT_BC) + + ENDDO + + ! Write boundary conditions to binary punch file + CALL BPCH2( IU_BC_05x06, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IJ_BC_05x06, (I0_W + J0_W)*2, LLPAR, I1_BC_GLOBAL, + & J1_BC_GLOBAL, 1, BC_05x06(:, :, :, N) ) + + ENDDO + + ! Echo info + STAMP = TIMESTAMP_STRING() + WRITE( 6, 110 ) STAMP + 110 FORMAT( ' - SAVE_GLOBAL_TPCORE_BC: Wrote BC''s at ', a ) + + ! Return to calling program + END SUBROUTINE SAVE_GLOBAL_TPCORE_BC_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_WINDOW_TPCORE_BC +! +!****************************************************************************** +! Subroutine DO_WINDOW_TPCORE_BC is a driver routine for assigning TPCORE +! boundary conditions to the tracer array STT. (bmy, 3/7/03, 7/20/04) +! +! At present, assume that we have saved +! +! NOTES: +! (1 ) Now references N_TRACERS and STT from "tracer_mod.f" (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : N_TRACERS, STT + USE LOGICAL_MOD, ONLY : LWINDO2x25 !add 2x25 BC (lzh,02/01/2015) + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, L, N + + !================================================================= + ! DO_WINDOW_TPCORE_BC begins here! + !================================================================= + + ! Either zero BC's or read them from disk + IF ( CLEAN_BC ) THEN + CALL CLEAN_WINDOW_TPCORE_BC + ELSE + CALL READ_WINDOW_TPCORE_BC + ENDIF + + !================================================================= + ! Copy the BC data into the proper elements of STT + ! + ! NOTE: We assume that we have saved 4x5 BC's from a global + ! GEOS-CHEM run. It takes too long to save the 2x25 BC's. + ! One may always another subroutine for 2x25 BC's later. + !================================================================= + IF ( .not. LWINDO2x25 ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + + ! First loop over all latitudes (WINDOW REGION) + DO J = 1, JJPAR + + ! West BC + DO I = 1, I0_W + STT(I,J,L,N) = GET_4x5_BC(I,J,L,N) + ENDDO + + ! East BC + DO I = IIPAR-I0_W+1, IIPAR + STT(I,J,L,N) = GET_4x5_BC(I,J,L,N) + ENDDO + ENDDO + + ! Now loop over the longitudes of the TPCORE REGION + DO I = 1+I0_W, IM_W+I0_W + + ! South BC + DO J = 1, J0_W + STT(I,J,L,N) = GET_4x5_BC(I,J,L,N) + ENDDO + + ! North BC + DO J = JJPAR-J0_W+1, JJPAR + STT(I,J,L,N) = GET_4x5_BC(I,J,L,N) + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ELSE + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + + ! First loop over all latitudes (WINDOW REGION) + DO J = 1, JJPAR + + ! West BC + DO I = 1, I0_W + STT(I,J,L,N) = GET_2x25_BC(I,J,L,N) + ENDDO + + ! East BC + DO I = IIPAR-I0_W+1, IIPAR + STT(I,J,L,N) = GET_2x25_BC(I,J,L,N) + ENDDO + ENDDO + + ! Now loop over the longitudes of the TPCORE REGION + DO I = 1+I0_W, IM_W+I0_W + + ! South BC + DO J = 1, J0_W + STT(I,J,L,N) = GET_2x25_BC(I,J,L,N) + ENDDO + + ! North BC + DO J = JJPAR-J0_W+1, JJPAR + STT(I,J,L,N) = GET_2x25_BC(I,J,L,N) + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! Return to calling program + END SUBROUTINE DO_WINDOW_TPCORE_BC + +!------------------------------------------------------------------------------ + SUBROUTINE DO_WINDOW_TPCORE_BC_ADJ +! +!****************************************************************************** +! Subroutine DO_WINDOW_TPCORE_BC_ADJ is the adjoint for assigning TPCORE +! boundary conditions to the tracer array STT. The impact is to set the +! adjoint values with the cushion region to zero. +! (zhej, dkh, 02/09/12, adj32_020) +! +! Based on DO_WINDOW_TPCORE_BC by (bmy, 3/7/03, 7/20/04) +! +! NOTES: +! +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : N_TRACERS + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! Set the adjoint concentration of cushion grids to ZERO because + ! the current nested transport module allows transport crossing + ! west/east boundary. (Zhe Jan 2012) + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + + ! First loop over all latitudes (WINDOW REGION) + DO J = 1, JJPAR + + ! West BC + DO I = 1, I0_W + STT_ADJ(I,J,L,N) = 0.0 + ENDDO + + ! East BC + DO I = IIPAR-I0_W+1, IIPAR + STT_ADJ(I,J,L,N) = 0.0 + ENDDO + ENDDO + + ! Now loop over the longitudes of the TPCORE REGION + DO I = 1, IIPAR + + ! South BC + DO J = 1, J0_W + STT_ADJ(I,J,L,N) = 0.0 + ENDDO + + ! North BC + DO J = JJPAR-J0_W+1, JJPAR + STT_ADJ(I,J,L,N) = 0.0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE DO_WINDOW_TPCORE_BC_ADJ + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_WINDOW_TPCORE_BC_05x0666 +! +!****************************************************************************** +! Subroutine DO_WINDOW_TPCORE_BC_05x0666 is a driver routine for assigning TPCORE +! boundary conditions to the tracer array STT. (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : N_TRACERS, STT + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, L, N + REAL*4 :: STT_BC(JM_BC_05x06, I0_W) + + !================================================================= + ! DO_WINDOW_TPCORE_BC begins here! + !================================================================= + + ! Either zero BC's or read them from disk + IF ( CLEAN_BC ) THEN + CALL CLEAN_WINDOW_TPCORE_BC_05x0666 + ELSE + CALL READ_WINDOW_TPCORE_BC_05x0666 + ENDIF + + !================================================================= + ! Copy the BC data into the proper elements of STT + !================================================================= + +! Do this sequentially for now (zhej, dkh, 02/09/12, adj32_021) +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + + !Southern boundary, 1:J0_W + STT(1:IIPAR, 1:J0_W, L, N) + & = BC_05x06(1:IIPAR, 1:J0_W, L, N) + + !Northern boundary, (J0_W + 1):(J0_W * 2) + STT(1:IIPAR, (JJPAR - J0_W + 1):JJPAR, L, N) + & = BC_05x06(1:IIPAR, (J0_W + 1):(J0_W * 2), L, N) + + !Western boundary, (J0_W * 2 + 1):(J0_W * 2 + I0_W) + STT_BC(1:JJPAR, 1:I0_W) + & = BC_05x06(1:JJPAR, (J0_W * 2 + 1):(J0_W * 2 + I0_W), L, N) + + STT(1:I0_W, 1:JJPAR, L, N) + & = TRANSPOSE(STT_BC) + + !Eestern boundary, (J0_W * 2 + I0_W + 1):((J0_W + I0_W)* 2) + STT_BC(1:JJPAR, 1:I0_W) + & = BC_05x06(1:JJPAR, (J0_W*2+I0_W +1):((J0_W+I0_W)*2), L, N) + + STT((IIPAR - I0_W + 1):IIPAR, 1:JJPAR, L, N) + & = TRANSPOSE(STT_BC) + + ENDDO + ENDDO +!!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE DO_WINDOW_TPCORE_BC_05x0666 + +!------------------------------------------------------------------------ + + SUBROUTINE CLEAN_WINDOW_TPCORE_BC +! +!****************************************************************************** +! Subroutine CLEAN_WINDOW_TPCORE_BC zeroes the boundary conditions array +! BC at each timestep. (bmy, 3/7/03, 7/20/04) +! +! NOTES: +! (1 ) Now references N_TRACERS from "tracer_mod.f" (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : N_TRACERS + USE LOGICAL_MOD, ONLY : LWINDO_NA, LWINDO_EU !(lzh,02/01/2015) + USE LOGICAL_MOD, ONLY : LWINDO_CH, LWINDO_CU + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! CLEAN_WINDOW_TPCORE_BC begins here! + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JM_BC + DO I = 1, IM_BC + BC(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !===== (lzh,02/01/2015)===== + IF ( LWINDO_NA ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JM_BC_NA + DO I = 1, IM_BC_NA + BC_NA(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + IF ( LWINDO_EU ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JM_BC_EU + DO I = 1, IM_BC_EU + BC_EU(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + IF ( LWINDO_CH ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JM_BC_CH + DO I = 1, IM_BC_CH + BC_CH(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ! Return to calling program + END SUBROUTINE CLEAN_WINDOW_TPCORE_BC + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEAN_WINDOW_TPCORE_BC_05x0666 +! +!****************************************************************************** +! Subroutine CLEAN_WINDOW_TPCORE_BC_05x0666 zeroes the boundary conditions array +! BC_05x06 at each timestep. (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, N + + !================================================================= + ! CLEAN_WINDOW_TPCORE_BC begins here! + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLPAR + DO J = 1, JM_BC_05x06 + DO I = 1, IM_BC_05x06 + BC_05x06(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE CLEAN_WINDOW_TPCORE_BC_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_WINDOW_TPCORE_BC +! +!****************************************************************************** +! Subroutine READ_WINDOW_TPCORE_BC reads tracer concentrations saved on the +! WINDOW REGION of a coarse-grid simulation (e.g. 4x5). These concentrations +! will be used as boundary conditions for TPCORE transport. (bmy, 3/7/03) +! +! NOTES: +! (1 ) LINUX has a problem putting a function call w/in a WRITE statement. +! Now save output from TIMESTAMP_STRING to STAMP and print that. +! (bmy, 9/29/03) +! (2 ) Now references N_TRACERS from "tracer_mod.f" (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE FILE_MOD, ONLY : IOERROR, IU_BC + USE TIME_MOD, ONLY : GET_TAU, TIMESTAMP_STRING + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, IOS, J, L + INTEGER :: NI, NJ, NL, NT + INTEGER :: NFOUND, IFIRST, JFIRST, LFIRST + INTEGER :: NSKIP, NTRACER, HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*4 :: ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: S = 'read_window_boundary' + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + ! For LINUX fix + CHARACTER(LEN=16) :: STAMP + + !================================================================= + ! READ_WINDOW_TPCORE_BC begins here! + !================================================================= + IF ( ITS_TIME_FOR_BC() ) THEN + + ! Open boundary conditions file (if necessary) + ! (lzh,02/01/2015) add multiple nested domains + CALL OPEN_BC_FILE( FOR_READ=.TRUE., WINDOW=5 ) + + ! Initialize # of tracers found + NFOUND = 0 + + ! Loop + DO + + !=========================================================== + ! Read each data block one at a time + !=========================================================== + + ! Read first header line + READ( IU_BC, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_BC, S//':1' ) + + ! Read second header line + READ( IU_BC, IOSTAT=IOS ) + & CATEGORY, NT, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_BC, S//':2' ) + + ! Read data array + READ( IU_BC, IOSTAT=IOS ) ARRAY(1:NI,1:NJ,1:NL) + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_BC, S//':3' ) + + !=========================================================== + ! If this is the right time, then save into BC array + !=========================================================== + IF ( GET_TAU() == ZTAU0 ) THEN + + ! Copy into the BC array + DO L = 1, NL + BC( 1:IM_BC, 1:JM_BC, L, NT ) = ARRAY(1:NI, 1:NJ, L) + ENDDO + + ! Increment count of tracers found + NFOUND = NFOUND + 1 + ENDIF + + !=========================================================== + ! Exit if we've found all tracers for this TAU value + !=========================================================== + IF ( NFOUND == N_TRACERS ) THEN + + ! Echo output + STAMP = TIMESTAMP_STRING() + WRITE( 6, 100 ) N_TRACERS, STAMP + 100 FORMAT( ' - READ_WINDOW_TPCORE_BC: Found all ', + & i3, ' BC''s at ', a ) + EXIT + ENDIF + ENDDO + ENDIF + + ! Return to calling program + END SUBROUTINE READ_WINDOW_TPCORE_BC + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_WINDOW_TPCORE_BC_05x0666 +! +!****************************************************************************** +! Subroutine READ_WINDOW_TPCORE_BC_05x0666 reads tracer concentrations saved on the +! WINDOW REGION. These concentrations will be used as boundary conditions for TPCORE transport. (bmy, 3/7/03) +! (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE FILE_MOD, ONLY : IOERROR, IU_BC_05x06 + USE TIME_MOD, ONLY : GET_TAU, TIMESTAMP_STRING + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, IOS, J, L + INTEGER :: NI, NJ, NL, NT + INTEGER :: NFOUND, IFIRST, JFIRST, LFIRST + INTEGER :: NSKIP, NTRACER, HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*4 :: ARRAY(IIPAR,JJPAR,LLPAR) + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: S = 'read_window_boundary' + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + ! For LINUX fix + CHARACTER(LEN=16) :: STAMP + + !================================================================= + ! READ_WINDOW_TPCORE_BC begins here! + !================================================================= + IF ( ITS_TIME_FOR_BC_05x0666() ) THEN + + ! Open boundary conditions file (if necessary) + CALL OPEN_BC_FILE_05x0666( FOR_READ=.TRUE. ) + + ! Initialize # of tracers found + NFOUND = 0 + + ! Loop + DO + + !=========================================================== + ! Read each data block one at a time + !=========================================================== + + ! Read first header line + READ( IU_BC_05x06, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_BC_05x06, S//':1' ) + + ! Read second header line + READ( IU_BC_05x06, IOSTAT=IOS ) + & CATEGORY, NT, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_BC_05x06, S//':2' ) + + ! Read data array + READ( IU_BC_05x06, IOSTAT=IOS ) ARRAY(1:NI,1:NJ,1:NL) + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_BC_05x06, S//':3' ) + + !=========================================================== + ! If this is the right time, then save into BC array + !=========================================================== + IF ( GET_TAU() == ZTAU0 ) THEN + + ! Copy into the BC array + DO L = 1, NL + BC_05x06( 1:IJ_BC_05x06, 1:((I0_W + J0_W)*2), L, NT ) + & = ARRAY(1:NI, 1:NJ, L) + ENDDO + + ! Increment count of tracers found + NFOUND = NFOUND + 1 + ENDIF + + !=========================================================== + ! Exit if we've found all tracers for this TAU value + !=========================================================== + IF ( NFOUND == N_TRACERS ) THEN + + ! Echo output + STAMP = TIMESTAMP_STRING() + WRITE( 6, 100 ) N_TRACERS, STAMP + 100 FORMAT( ' - READ_WINDOW_TPCORE_BC: Found all ', + & i3, ' BC''s at ', a ) + EXIT + ENDIF + ENDDO + ENDIF + + ! Return to calling program + END SUBROUTINE READ_WINDOW_TPCORE_BC_05x0666 + +!------------------------------------------------------------------------------ + + FUNCTION GET_4x5_BC( I_1x1, J_1x1, L_1x1, N_1x1 ) RESULT( VALUE ) +! +!****************************************************************************** +! Function GET_4x5_BC returns a value from the 4x5 BC boundary conditions +! array at the location of a 1x1 grid box. (yxw, bmy, 3/7/03) +! +! For now we will assume that we have saved tracer concentrations from a +! 4x5 window whioh overlays the corresponding 1x1 WINDOW REGION. These 4x5 +! tracer concentrations are used as boundary conditions for TPCORE. +! +! We assume that we won't be saving 2x2.5 boundary conditions anytime in the +! near future since it currently takes too long to run a 2x2.5 full-chemistry +! simulation for a whole year. However, if we ever do save 2x25 boundary +! conditions, one may always write a corresponding subroutine GET_2x25_BC to +! do the mapping from 1x1 -> 2x25. (yxw, bmy, 3/7/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I_1x1 (INTEGER) : Longitude index of 1x1 grid box +! (2 ) J_1x1 (INTEGER) : Latitude index of 1x1 grid box +! (3 ) L_1x1 (INTEGER) : Altitude index of 1x1 grid box +! (4 ) N_1x1 (INTEGER) : Tracer index of 1x1 grid box +! +! NOTES: +! (1 ) Rename arguments to avoid conflict w/ I1x1, J1x1 parameters in +! CMN_SIZE. (bmy, 10/24/05) +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! NTRACE + + ! Arguments + INTEGER, INTENT(IN) :: I_1x1, J_1x1, L_1x1, N_1x1 + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, II, J, JJ, JJ1 + REAL*8 :: X, Y + REAL*8, SAVE :: XE4x5(73), YE4x5(47) + + ! Function value + REAL*8 :: VALUE + + !================================================================= + ! GET_4x5_BC begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + + !============================================================== + ! Define lon & lat edges of the 4x5 grid -- we need to + ! use these to do the mapping from 1x1 --> 4x5 + !============================================================== + + ! Lon edges + DO I = 1, 73 + XE4x5(I) = -182.5d0 + 5 * ( I - 1 ) + ENDDO + + ! Lat edges + DO J = 2, 46 + YE4x5(J) = -92d0 + 4 * ( J - 1 ) + ENDDO + + ! Polar lats + YE4x5(1) = -90d0 + YE4x5(47) = +90d0 + + !============================================================== + ! Locate the 4x5 box(es) to which each 1x1 box belongs + ! X, Y are lon & lat centers of the 1x1 boxes in degrees + ! Save in the MAP1x1 array for future reference + !============================================================== + DO J = 1, JJPAR + Y = GET_YMID( J ) + + DO I = 1, IIPAR + X = GET_XMID( I ) + + ! Loop over 4x5 longitudes + DO II = 1, 72 + + ! If the 1x1 center lon lies w/in the 4x5 lon edges + ! then we have found the proper 4x5 box! + IF ( X > XE4x5(II) .and. X < XE4x5(II+1) ) THEN + MAP1x1(I,J,1) = II + EXIT + ENDIF + ENDDO + + ! Loop over 4x5 latitudes + DO JJ = 1, 46 + + ! If the 1x1 lat center lies between the 4x5 lat + ! edges, we have found the proper 4x5 box! + IF ( Y > YE4x5(JJ) .and. Y < YE4x5(JJ+1) ) THEN + MAP1x1(I,J,2) = JJ + MAP1x1(I,J,3) = 0 + EXIT + + ! If the 1x1 lat center equals the 4x5 lower lat + ! edge, then we need to average this 4x5 box and + ! the box just south of it + ELSE IF ( Y == YE4x5(JJ) ) THEN + MAP1x1(I,J,2) = JJ-1 + MAP1x1(I,J,3) = JJ + EXIT + + ! If the 1x1 lat center equals the 4x5 lower lat + ! edge, then we need to average this 4x5 box and + ! the box just north of it + ELSE IF ( Y == YE4x5(JJ+1) ) THEN + MAP1x1(I,J,2) = JJ + MAP1x1(I,J,3) = JJ+1 + EXIT + + ENDIF + ENDDO + ENDDO + ENDDO + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + !============================================================= + ! Locate the tracer concentration at the 4x5 box which + ! corresponds to the 1x1 box (I_1x1, J_1x1, L_1x1, N_1x1) + !============================================================= + + ! Get lon indices + II = MAP1x1( I_1x1, J_1x1, 1 ) - I0_BC + + ! Get lat indices + JJ = MAP1x1( I_1x1, J_1x1, 2 ) - J0_BC + JJ1 = MAP1x1( I_1x1, J_1x1, 3 ) - J0_BC + + ! Locate the 4x5 box(es) corresponding to the 1x1 box + ! If our 1x1 box straddles 2 4x5 boxes, average the 4x5 values + IF ( MAP1x1( I_1x1, J_1x1, 3 ) > 0 ) THEN + VALUE = 0.5 * ( BC(II,JJ,L_1x1,N_1x1) + BC(II,JJ1,L_1x1,N_1x1)) + ELSE + VALUE = BC(II,JJ,L_1x1,N_1x1) + ENDIF + + ! Return to calling program + END FUNCTION GET_4x5_BC + +!------------------------------------------------------------------------------ +! (lzh,02/01/2015) add 2x2.5 BC + + FUNCTION GET_2x25_BC( I_1x1, J_1x1, L_1x1, N_1x1 ) RESULT( VALUE ) +! +!****************************************************************************** +! Function GET_2x25_BC returns a value from the 2x2.5 BC boundary conditions +! array at the location of a 1x1 grid box. (yxw, bmy, 3/7/03) +! +! For now we will assume that we have saved tracer concentrations from a +! 2x25 window which overlays the corresponding 1x1 WINDOW REGION. These 2x2.5 +! tracer concentrations are used as boundary conditions for TPCORE. +! +! Arguments as Input: +! ============================================================================ +! (1 ) I_1x1 (INTEGER) : Longitude index of 1x1 grid box +! (2 ) J_1x1 (INTEGER) : Latitude index of 1x1 grid box +! (3 ) L_1x1 (INTEGER) : Altitude index of 1x1 grid box +! (4 ) N_1x1 (INTEGER) : Tracer index of 1x1 grid box +! +! NOTES: +! (1 ) Rename arguments to avoid conflict w/ I1x1, J1x1 parameters in +! CMN_SIZE. (bmy, 10/24/05) +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! NTRACE + + ! Arguments + INTEGER, INTENT(IN) :: I_1x1, J_1x1, L_1x1, N_1x1 + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, II, J, JJ, JJ1 + REAL*8 :: X, Y + REAL*8, SAVE :: XE2x25(145), YE2x25(92) + + ! Function value + REAL*8 :: VALUE + + !================================================================= + ! GET_2x25_BC begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + + !============================================================== + ! Define lon & lat edges of the 2x25 grid -- we need to + ! use these to do the mapping from 1x1 --> 2x25 + !============================================================== + + ! Lon edges + DO I = 1, 145 + XE2x25(I) = -181.25d0 + 2.5 * ( I - 1 ) + ENDDO + + ! Lat edges + DO J = 2, 91 + YE2x25(J) = -91d0 + 2 * ( J - 1 ) + ENDDO + + ! Polar lats + YE2x25(1) = -90d0 + YE2x25(92) = +90d0 + + !============================================================== + ! Locate the 2x25 box(es) to which each 1x1 box belongs + ! X, Y are lon & lat centers of the 1x1 boxes in degrees + ! Save in the MAP1x1 array for future reference + !============================================================== + DO J = 1, JJPAR + Y = GET_YMID( J ) + + DO I = 1, IIPAR + X = GET_XMID( I ) + + ! Loop over 2x25 longitudes + DO II = 1, 144 + + ! If the 1x1 center lon lies w/in the 2x25 lon edges + ! then we have found the proper 2x25 box! +!! IF ( X > XE2x25(II) .and. X < XE2x25(II+1) ) THEN +!! (lzh, 02/01/2014) + IF ( X >= XE2x25(II) .and. X < XE2x25(II+1) ) THEN + MAP1x1(I,J,1) = II + EXIT + ENDIF + ENDDO + + ! Loop over 2x25 latitudes + DO JJ = 1, 91 + + ! If the 1x1 lat center lies between the 2x25 lat + ! edges, we have found the proper 2x25 box! + IF ( Y > YE2x25(JJ) .and. Y < YE2x25(JJ+1) ) THEN + MAP1x1(I,J,2) = JJ + MAP1x1(I,J,3) = 0 + EXIT + + ! If the 1x1 lat center equals the 2x25 lower lat + ! edge, then we need to average this 2x25 box and + ! the box just south of it + ELSE IF ( Y == YE2x25(JJ) ) THEN + MAP1x1(I,J,2) = JJ-1 + MAP1x1(I,J,3) = JJ + EXIT + + ! If the 1x1 lat center equals the 2x25 lower lat + ! edge, then we need to average this 2x25 box and + ! the box just north of it + ELSE IF ( Y == YE2x25(JJ+1) ) THEN + MAP1x1(I,J,2) = JJ + MAP1x1(I,J,3) = JJ+1 + EXIT + + ENDIF + ENDDO + ENDDO + ENDDO + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + !============================================================= + ! Locate the tracer concentration at the 4x5 box which + ! corresponds to the 1x1 box (I_1x1, J_1x1, L_1x1, N_1x1) + !============================================================= + + ! Get lon indices + II = MAP1x1( I_1x1, J_1x1, 1 ) - I0_BC + + ! Get lat indices + JJ = MAP1x1( I_1x1, J_1x1, 2 ) - J0_BC + JJ1 = MAP1x1( I_1x1, J_1x1, 3 ) - J0_BC + + ! Locate the 2x25 box(es) corresponding to the 1x1 box + ! If our 1x1 box straddles 2 2x25 boxes, average the 2x25 values + IF ( MAP1x1( I_1x1, J_1x1, 3 ) > 0 ) THEN + VALUE = 0.5 * ( BC(II,JJ,L_1x1,N_1x1) + BC(II,JJ1,L_1x1,N_1x1)) + ELSE + VALUE = BC(II,JJ,L_1x1,N_1x1) + ENDIF + + ! Return to calling program + END FUNCTION GET_2x25_BC + +!------------------------------------------------------------------------------ + + FUNCTION ITS_TIME_FOR_BC() RESULT( FLAG ) +! +!****************************************************************************** +! Subroutine ITS_TIME_FOR_BC returns TRUE if it is time to read in the next +! set of boundary conditions for TPCORE, or FALSE otherwise. (bmy, 3/5/03) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE TIME_MOD, ONLY : GET_ELAPSED_MIN + + ! Function value + LOGICAL :: FLAG + + !================================================================= + ! ITS_TIME_FOR_BC begins here! + !================================================================= + FLAG = ( MOD( GET_ELAPSED_MIN(), TS_BC ) == 0 ) + + ! Return to calling program + END FUNCTION ITS_TIME_FOR_BC + +!------------------------------------------------------------------------------ + + FUNCTION ITS_TIME_FOR_BC_05x0666() RESULT( FLAG ) +! +!****************************************************************************** +! Subroutine ITS_TIME_FOR_BC_0666 returns TRUE if it is time to read in the next +! set of boundary conditions for TPCORE, or FALSE otherwise. (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE TIME_MOD, ONLY : GET_ELAPSED_MIN + + ! Function value + LOGICAL :: FLAG + + !================================================================= + ! ITS_TIME_FOR_BC begins here! + !================================================================= + FLAG = ( MOD( GET_ELAPSED_MIN(), TS_BC_05x06 ) == 0 ) + + ! Return to calling program + END FUNCTION ITS_TIME_FOR_BC_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_TPCORE_BC( TS, I0W, J0W, I1, J1, I2, J2 ) +! +!****************************************************************************** +! Subroutine INIT_TPCORE_BC initializes module variables and arrays +! (bmy, 2/10/03, 7/20/04) +! +! NOTES: +! (1 ) Now references N_TRACERS from "tracer_mod.f". Now references LWINDO +! from "logical_mod.f". Now references TPBC_DIR from "directory_mod.f". +! Now references ITS_A_NESTED_GRID from "grid_mod.f". Also added +! arguments to take values from "input_mod.f". (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE DIRECTORY_MOD, ONLY : TPBC_DIR + USE ERROR_MOD, ONLY : ALLOC_ERR + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE GRID_MOD, ONLY : ITS_A_NESTED_GRID +! USE LOGICAL_MOD, ONLY : LWINDO + USE LOGICAL_MOD, ONLY : LWINDO, LWINDO_NA, LWINDO_CU !(lzh) + USE LOGICAL_MOD, ONLY : LWINDO_EU, LWINDO_CH + USE LOGICAL_MOD, ONLY : LWINDO2x25 + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: TS, I0W, J0W, I1, J1, I2, J2 + + ! Local variables + INTEGER :: AS, I, J + + !================================================================= + ! INIT_TPCORE_BC begins here! + !================================================================= + + ! Timestep for BC's [min] + TS_BC = TS + + !--------------------- + ! *** NESTED GRID *** + !--------------------- + + ! TPCORE transport region offsets + I0_W = I0W + J0_W = J0W + + ! Extent of TPCORE transport region + IM_W = IIPAR - ( 2 * I0_W ) + JM_W = JJPAR - ( 2 * J0_W ) + + ! I and J at lower-left corner of TPCORE transport region + I1_W = GET_XOFFSET( GLOBAL=.TRUE. ) + I0_W + 1 + J1_W = GET_YOFFSET( GLOBAL=.TRUE. ) + J0_W + 1 + + ! I and J at upper-right corner of TPCORE transport region + I2_W = GET_XOFFSET( GLOBAL=.TRUE. ) + IIPAR - I0_W + J2_W = GET_YOFFSET( GLOBAL=.TRUE. ) + JJPAR - J0_W + + ! IGZD = ? + IGZD = I0_W - 1 + + !--------------------- + ! *** GLOBAL GRID *** + !--------------------- + + ! Lower-left corner of coarse-grid BC WINDOW region + I1_BC = I1 + J1_BC = J1 + + ! Upper-right corner of coarse-grid BC WINDOW region + I2_BC = I2 + J2_BC = J2 + + ! Extent of coarse-grid BC REGION + IM_BC = I2_BC - I1_BC + 1 + JM_BC = J2_BC - J1_BC + 1 + + ! TPCORE internal transport window offset + I0_BC = I1_BC - 1 + J0_BC = J1_BC - 1 + + + IF (.not. LWINDO2x25) THEN +#if defined(GRID4x5) || defined(NESTED_NA) + +#if defined( GEOS_FP ) + !%%%%% 4x5 BC REGION FOR NORTH AMERICA NESTED GRID (GEOS_FP) + I1_BC_NA = 11 ! 4x5 lon index, LL corner + J1_BC_NA = 26 ! 4x5 lat index, LL corner + I2_BC_NA = 25 ! 4x5 lon index, UR corner + J2_BC_NA = 39 ! 4x5 lat index, UR corner +#else + !%%%%% 4x5 BC REGION FOR NORTH AMERICA NESTED GRID %%%%% + I1_BC_NA = 9 ! 4x5 lon index, LL corner + J1_BC_NA = 26 ! 4x5 lat index, LL corner + I2_BC_NA = 29 ! 4x5 lon index, UR corner + J2_BC_NA = 41 ! 4x5 lat index, UR corner +#endif + +#endif + ELSE +#if defined(GRID2x25) || defined(NESTED_NA) + +#if defined( GEOS_FP ) + !%%%%% 2x25 BC REGION FOR NORTH AMERICA NESTED GRID (GEOS_FP) + I1_BC_NA = 21 ! 2x25 lon index, LL corner + J1_BC_NA = 51 ! 2x25 lat index, LL corner + I2_BC_NA = 49 ! 2x25 lon index, UR corner + J2_BC_NA = 76 ! 2x25 lat index, UR corner +#else + !%%%%% 2x25 BC REGION FOR NORTH AMERICA NESTED GRID %%%%% + I1_BC_NA = 17 ! 2x25 lon index, LL corner + J1_BC_NA = 51 ! 2x25 lat index, LL corner + I2_BC_NA = 57 ! 2x25 lon index, UR corner + J2_BC_NA = 81 ! 2x25 lat index, UR corner +#endif + +#endif + ENDIF + + ! Extent of coarse-grid NA BC REGION + IM_BC_NA = I2_BC_NA - I1_BC_NA + 1 + JM_BC_NA = J2_BC_NA - J1_BC_NA + 1 + + ! TPCORE NA internal transport window offset + I0_BC_NA = I1_BC_NA - 1 + J0_BC_NA = J1_BC_NA - 1 + + IF (.not. LWINDO2x25) THEN +#if defined(GRID4x5) || defined(NESTED_EU) + ! Lower-left corner of coarse-grid EU BC WINDOW region + I1_BC_EU = 31 + J1_BC_EU = 31 + + ! Upper-right corner of coarse-grid EU BC WINDOW region + I2_BC_EU = 47 + J2_BC_EU = 41 +#endif + ELSE +#if defined(GRID2x25) || defined(NESTED_EU) + ! Lower-left corner of coarse-grid EU BC WINDOW region + I1_BC_EU = 61 + J1_BC_EU = 61 + + ! Upper-right corner of coarse-grid EU BC WINDOW region + I2_BC_EU = 93 + J2_BC_EU = 81 +#endif + ENDIF + + ! Extent of coarse-grid EU BC REGION + IM_BC_EU = I2_BC_EU - I1_BC_EU + 1 + JM_BC_EU = J2_BC_EU - J1_BC_EU + 1 + + ! TPCORE NA internal transport window offset + I0_BC_EU = I1_BC_EU - 1 + J0_BC_EU = J1_BC_EU - 1 + + IF (.not. LWINDO2x25) THEN +#if defined(GRID4x5) || defined(NESTED_CH) + +#if defined(GEOS_FP) + !!! (lzh,04/20/2014) + ! Lower-left corner of coarse-grid CH BC WINDOW region + I1_BC_CH = 51 + J1_BC_CH = 27 + + ! Upper-right corner of coarse-grid CH BC WINDOW region + I2_BC_CH = 65 + J2_BC_CH = 37 +#else + ! Lower-left corner of coarse-grid CH BC WINDOW region + I1_BC_CH = 51 + J1_BC_CH = 21 + + ! Upper-right corner of coarse-grid CH BC WINDOW region + I2_BC_CH = 67 + J2_BC_CH = 37 +#endif + +#endif + + ELSE + +#if defined(GRID2x25) || defined(NESTED_CH) + +#if defined( GEOS_FP ) + !!! (lzh,04/20/2014) + ! Lower-left corner of coarse-grid CH BC WINDOW region + I1_BC_CH = 101 + J1_BC_CH = 53 + + ! Upper-right corner of coarse-grid CH BC WINDOW region + I2_BC_CH = 129 + J2_BC_CH = 74 +#else + ! Lower-left corner of coarse-grid CH BC WINDOW region + I1_BC_CH = 101 + J1_BC_CH = 40 + + ! Upper-right corner of coarse-grid CH BC WINDOW region + I2_BC_CH = 133 + J2_BC_CH = 74 +#endif + +#endif + + ENDIF + + ! Extent of coarse-grid EU BC REGION + IM_BC_CH = I2_BC_CH - I1_BC_CH + 1 + JM_BC_CH = J2_BC_CH - J1_BC_CH + 1 + + ! TPCORE NA internal transport window offset + I0_BC_CH = I1_BC_CH - 1 + J0_BC_CH = J1_BC_CH - 1 + + ! Return if we are not saving 4x5 BC's + ! or if it's not a nested grid simulation + IF ( .not. ITS_A_NESTED_GRID() ) THEN + IF ( .not. LWINDO ) RETURN + ENDIF + + !================================================================= + ! Allocate and initialize arrays + !================================================================= +! ALLOCATE( BC( IM_BC, JM_BC, LLPAR, N_TRACERS ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) +! BC = 0e0 + + IF ( LWINDO_CU ) THEN + + ALLOCATE( BC( IM_BC, JM_BC, LLPAR, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) + BC = 0e0 + + ENDIF + + IF ( LWINDO_CH ) THEN + + ALLOCATE( BC_CH( IM_BC_CH, JM_BC_CH, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC_CH' ) + BC_CH = 0e0 + + ENDIF + + IF ( LWINDO_NA ) THEN + + ALLOCATE( BC_NA( IM_BC_NA, JM_BC_NA, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC_NA' ) + BC_NA = 0e0 + + ENDIF + + IF ( LWINDO_EU ) THEN + + ALLOCATE( BC_EU( IM_BC_EU, JM_BC_EU, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC_EU' ) + BC_EU = 0e0 + + ENDIF + + ! If running a nested simulation, just allocate the custom BC + ! array with nested dimensions +#if defined( NESTED_CH ) + I1_BC = I1_BC_CH + J1_BC = J1_BC_CH + I2_BC = I2_BC_CH + J2_BC = J2_BC_CH + IM_BC = IM_BC_CH + JM_BC = JM_BC_CH + I0_BC = I0_BC_CH + J0_BC = J0_BC_CH + + ALLOCATE( BC( IM_BC, JM_BC, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) + BC = 0e0 +#elif defined( NESTED_NA ) + I1_BC = I1_BC_NA + J1_BC = J1_BC_NA + I2_BC = I2_BC_NA + J2_BC = J2_BC_NA + IM_BC = IM_BC_NA + JM_BC = JM_BC_NA + I0_BC = I0_BC_NA + J0_BC = J0_BC_NA + + ALLOCATE( BC( IM_BC, JM_BC, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) + BC = 0e0 +#elif defined( NESTED_EU ) + I1_BC = I1_BC_EU + J1_BC = J1_BC_EU + I2_BC = I2_BC_EU + J2_BC = J2_BC_EU + IM_BC = IM_BC_EU + JM_BC = JM_BC_EU + I0_BC = I0_BC_EU + J0_BC = J0_BC_EU + + ALLOCATE( BC( IM_BC, JM_BC, LLPAR, N_TRACERS ) + & , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) + BC = 0e0 +#endif + + ALLOCATE( MAP1x1( IIPAR, JJPAR, 3 ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MAP1x1' ) + MAP1x1 = 0 + + ! Return to calling program + END SUBROUTINE INIT_TPCORE_BC + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_TPCORE_BC_05x0666 +! +!****************************************************************************** +! Subroutine INIT_TPCORE_BC_05x0666 initializes module variables and arrays +! (Zhe, Jan 2012) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters + + INTEGER :: AS + + !================================================================= + ! INIT_TPCORE_BC_05x0666 begins here! + !================================================================= + + ! Parameters for smaller domain + ! Timestep for BC's [min] + TS_BC_05x06 = 60 + + ! Lower-left corner of coarse-grid BC WINDOW region + I1_BC_05x06 = 22 + J1_BC_05x06 = 7 + I1_BC_GLOBAL = 82 + J1_BC_GLOBAL = 207 + + ! Upper-right corner of coarse-grid BC WINDOW region + I2_BC_05x06 = 112 + J2_BC_05x06 = 95 + + ! Extent of coarse-grid BC REGION + IM_BC_05x06 = I2_BC_05x06 - I1_BC_05x06 + 1 + JM_BC_05x06 = J2_BC_05x06 - J1_BC_05x06 + 1 + + IF ( IM_BC_05x06 > JM_BC_05x06 ) THEN + IJ_BC_05x06 = IM_BC_05x06 + ELSE + IJ_BC_05x06 = JM_BC_05x06 + ENDIF + + !================================================================= + ! Allocate and initialize arrays + !================================================================= + ALLOCATE( BC_05x06( IJ_BC_05x06, (I0_W + J0_W)*2, + & LLPAR, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC_05x06' ) + BC_05x06 = 0e0 + + ! Return to calling program + END SUBROUTINE INIT_TPCORE_BC_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_TPCORE_BC +! +!****************************************************************************** +! Subroutine CLEANUP_TPCORE_BC deallocates all module arrays. (3/4/03) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_TPCORE_BC begins here! + !================================================================= + IF ( ALLOCATED( BC ) ) DEALLOCATE( BC ) + IF ( ALLOCATED( BC_NA ) ) DEALLOCATE( BC_NA ) + IF ( ALLOCATED( BC_EU ) ) DEALLOCATE( BC_EU ) + IF ( ALLOCATED( BC_CH ) ) DEALLOCATE( BC_CH ) + IF ( ALLOCATED( MAP1x1 ) ) DEALLOCATE( MAP1x1 ) + IF ( ALLOCATED( BC_05x06 ) ) DEALLOCATE( BC_05x06 ) + + ! Return to calling program + END SUBROUTINE CLEANUP_TPCORE_BC + +!------------------------------------------------------------------------------ + + END MODULE TPCORE_BC_MOD diff --git a/code/tpcore_fvdas_mod.f90 b/code/tpcore_fvdas_mod.f90 new file mode 100644 index 0000000..80e0701 --- /dev/null +++ b/code/tpcore_fvdas_mod.f90 @@ -0,0 +1,6595 @@ +! $Id: tpcore_fvdas_mod.f90,v 1.5 2011/02/23 00:08:47 daven Exp $ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: Tpcore_FvDas_Mod +! +! !DESCRIPTION: \subsection*{Overview} +! Module Tpcore\_Fvdas\_Mod contains routines for the TPCORE +! transport scheme, as implemented in the GMI model (cf. John Tannahill), +! based on Lin \ Rood 1995. The Harvard Atmospheric Chemistry Modeling Group +! has added modifications to implement the Philip-Cameron Smith pressure +! fixer for mass conservation. Mass flux diagnostics have also been added. +! +!\subsection*{References} +! \begin{enumerate} +! \item Lin, S.-J., and R. B. Rood, 1996: \emph{Multidimensional flux +! form semi-Lagrangian transport schemes}, +! \underline{ Mon. Wea. Rev.}, \textbf{124}, 2046-2070. +! \item Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: +! \emph{A class of the van Leer-type transport schemes and its +! applications to the moisture transport in a General Circulation +! Model}, \underline{Mon. Wea. Rev.}, \textbf{122}, 1575-1593. +! \end{enumerate} +! +!\subsection*{Selecting E/W, N/S and vertical advection options} +! +! The flags IORD, JORD, KORD select which transport schemes are used in the +! E/W, N/S, and vertical directions, respectively. Here is a list of the +! possible values that IORD, JORD, KORD may be set to (original notes from +! S-J Lin): +! +! \begin{enumerate} +! \item 1st order upstream scheme (too diffusive, not a real option; +! it can be used for debugging purposes; this is THE only known +! "linear" monotonic advection scheme.). +! \item 2nd order van Leer (full monotonicity constraint; +! see Lin et al 1994, MWR) +! \item monotonic PPM* (Collela \& Woodward 1984) +! \item semi-monotonic PPM (same as 3, but overshoots are allowed) +! \item positive-definite PPM (constraint on the subgrid distribution is +! only strong enough to prevent generation of negative values; +! both overshoots \& undershoots are possible). +! \item un-constrained PPM (nearly diffusion free; faster but +! positivity of the subgrid distribution is not quaranteed. Use +! this option only when the fields and winds are very smooth. +! \item Huynh/Van Leer/Lin full monotonicity constraint. Only KORD can be +! set to 7 to enable the use of Huynh's 2nd monotonicity constraint +! for piece-wise parabolic distribution. +! \end {enumerate} +! +! Recommended values: +! +! \begin{itemize} +! \item IORD=JORD=3 for high horizontal resolution. +! \item KORD=3 or 7 +! \end{itemize} +! +! The implicit numerical diffusion decreases as \_ORD increases. +! DO NOT use option 4 or 5 for non-positive definite scalars +! (such as Ertel Potential Vorticity). +!\\ +!\\ +! In GEOS-Chem we have been using IORD=3, JORD=3, KORD=7. We have tested +! the OpenMP parallelization with these options. GEOS-Chem users who wish to +! use different (I,J,K)ORD options should consider doing single-procsessor +! vs. multi-processor tests to test the implementation of the parallelization. +! +!\subsection*{GEOS-4 and GEOS-5 Hybrid Grid Definition} +! +! For GEOS-4 and GEOS-5 met fields, the pressure at the bottom edge of +! grid box (I,J,L) is defined as follows: +! +! $$P_{edge}(I,J,L) = A_{k}(L) + [ B_{k}(L) * P_{surface}(I,J) ]$$ +! +! where +! +! \begin{itemize} +! \item $P_{surface}$(I,J) is the "true" surface pressure at lon,lat (I,J) +! \item $A_{k}$(L) has the same units as surface pressure [hPa] +! \item $B_{k}$(L) is a unitless constant given at level edges +! \end{itemize} +! +! $A_{k}(L)$ and $B_{k}(L)$ are supplied to us by GMAO. +!\\ +!\\ +! !REMARKS: +! Ak(L) and Bk(L) are defined at layer edges. +! +! +! ///////////////////////////////// +! / \ ------ Model top P=ak(1) --------- ak(1), bk(1) +! | +! delp(1) | ........... q(i,j,1) ............ +! | +! \ / --------------------------------- ak(2), bk(2) +! +! +! +! / \ --------------------------------- ak(k), bk(k) +! | +! delp(k) | ........... q(i,j,k) ............ +! | +! \ / --------------------------------- ak(k+1), bk(k+1) +! +! +! +! / \ --------------------------------- ak(km), bk(km) +! | +! delp(km) | ........... q(i,j,km) ......... +! | +! \ / -----Earth's surface P=Psfc ------ ak(km+1), bk(km+1) +! ////////////////////////////////// +! +! Note: surface pressure can be of any unit (e.g., pascal or mb) as +! long as it is consistent with the definition of (ak, bk) defined above. +! +! Winds (u,v), ps, and q are assumed to be defined at the same points. +! +! The latitudes are given to the initialization routine: init_tpcore. +! +! !INTERFACE: +! +MODULE Tpcore_FvDas_Mod +! +! !USES: +! + IMPLICIT NONE + PRIVATE +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: Init_Tpcore + PUBLIC :: Exit_Tpcore + PUBLIC :: Tpcore_FvDas +! +! !PRIVATE MEMBER FUNCTIONS: +! + PRIVATE :: Average_Const_Poles + PRIVATE :: Set_Cross_Terms + PRIVATE :: Calc_Vert_Mass_Flux + PRIVATE :: Set_Jn_Js + PRIVATE :: Calc_Advec_Cross_Terms + PRIVATE :: Qckxyz + PRIVATE :: Set_Lmts + PRIVATE :: Set_Press_Terms + PRIVATE :: Calc_Courant + PRIVATE :: Calc_Divergence + PRIVATE :: Do_Divergence_Pole_Sum + PRIVATE :: Do_Cross_Terms_Pole_I2d2 + PRIVATE :: Xadv_Dao2 + PRIVATE :: Yadv_Dao2 + PRIVATE :: Do_Yadv_Pole_I2d2 + PRIVATE :: Do_Yadv_Pole_Sum + PRIVATE :: Xtp + PRIVATE :: Xmist + PRIVATE :: Fxppm + PRIVATE :: Lmtppm + PRIVATE :: Ytp + PRIVATE :: Ymist + PRIVATE :: Do_Ymist_Pole1_I2d2 + PRIVATE :: Do_Ymist_Pole2_I2d2 + PRIVATE :: Fyppm + PRIVATE :: Do_Fyppm_Pole_I2d2 + PRIVATE :: Do_Ytp_Pole_Sum + PRIVATE :: Fzppm + PRIVATE :: Average_Press_Poles +! +! !PRIVATE DATA MEMBERS: +! + REAL*8, ALLOCATABLE, SAVE :: dtdx5(:) + REAL*8, ALLOCATABLE, SAVE :: dtdy5(:) + REAL*8, ALLOCATABLE, SAVE :: cosp(:) + REAL*8, ALLOCATABLE, SAVE :: cose(:) + REAL*8, ALLOCATABLE, SAVE :: gw(:) + REAL*8, ALLOCATABLE, SAVE :: DLAT(:) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, GMAO +! Modified for GMI model by John Tannahill, LLNL (jrt@llnl.gov) +! Implemented into GEOS-Chem by Claire Carouge (ccarouge@seas.harvard.edu) +! ProTeX documentation added by Bob Yantosca (yantosca@seas.harvard.edu) +! OpenMP parallelization added by Bob Yantosca (yantosca@seas.harvard.edu) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from the GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Added +! OpenMP parallel loops in various routines (and +! made some modifications to facilitate OpenMP). +! 01 Apr 2009 - C. Carouge - Modified OpenMp parallelization and move the +! loops over vertical levels outside the +! horizontal transport routines for reducing +! processing time. +!EOP +!------------------------------------------------------------------------------ + +CONTAINS + +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Init_Tpcore +! +! !DESCRIPTION: Subroutine Init\_Tpcore allocates and initializes all module +! variables, +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Init_Tpcore( IM, JM, KM, JFIRST, JLAST, NG, MG, dt, ae, clat ) +! +! !USES: +! +# include "CMN_GCTM" ! Physical constants etc. +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: IM ! Global E-W dimension + INTEGER, INTENT(IN) :: JM ! Global N-S dimension + INTEGER, INTENT(IN) :: KM ! Vertical dimension + INTEGER, INTENT(IN) :: NG ! large ghost width + INTEGER, INTENT(IN) :: MG ! small ghost width + REAL*8, INTENT(IN) :: dt ! Time step in seconds + REAL*8, INTENT(IN) :: ae ! Earth's radius (m) + REAL*8, INTENT(IN) :: clat(JM) ! latitude in radian +! +! !OUTPUT PARAMETERS: +! + INTEGER, INTENT(OUT) :: JFIRST ! Local first index for N-S direction + INTEGER, INTENT(OUT) :: JLAST ! Local last index for N-S direction +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*8 :: elat(jm+1) ! cell edge latitude in radian + REAL*8 :: sine(jm+1) + REAL*8 :: SINE_25(JM+1) ! + REAL*8 :: dlon + !---------------------------------------- + ! Prior to 12/12/08: + ! Use PI from CMN_GCTM (bmy, 12/12/08) + !REAL*8 :: pi + !---------------------------------------- + INTEGER :: I, J + + ! NOTE: since we are not using MPI parallelization, we can set JFIRST + ! and JLAST to the global grid limits in latitude. (bmy, 12/3/08) + jfirst = 1 + jlast = jm + + if ( jlast - jfirst < 2 ) then + write(*,*) 'Minimum size of subdomain is 3' + endif + + !---------------- + ! Allocate arrays + !---------------- + + ALLOCATE( cosp ( JM ) ) + ALLOCATE( cose ( JM ) ) + ALLOCATE( gw ( JM ) ) + ALLOCATE( dtdx5 ( JM ) ) + ALLOCATE( dtdy5 ( JM ) ) + ALLOCATE( DLAT ( JM ) ) ! For PJC pressure-fixer + + !---------------------------------------- + ! Prior to 12/12/08: + ! Use PI from CMN_GCTM (bmy, 12/12/08) + !PI = 4.0d0 * ATAN(1.0d0) + !---------------------------------------- + + !---------------------------------------- + ! Prior to 12/12/08: + ! Use double precision (bmy, 12/12/08) + !dlon = 2.d0 * PI / float(im) + !---------------------------------------- + dlon = 2.d0 * PI / DBLE( IM ) + + ! S. Pole + elat(1) = -0.5d0*PI + sine(1) = -1.0d0 + SINE_25(1) = -1.0d0 + cose(1) = 0.0d0 + + do j=2,jm + elat(j) = 0.5d0*(clat(j-1) + clat(j)) + sine(j) = SIN( elat(j) ) + SINE_25(J) = SIN( CLAT(J) ) + cose(j) = COS( elat(j) ) + enddo + + ! N. Pole + elat(jm+1) = 0.5d0*PI + sine(jm+1) = 1.0d0 + SINE_25(JM+1) = 1.0d0 + + ! Polar cap (S. Pole) + dlat(1) = 2.d0*(elat(2) - elat(1)) + do j=2,jm-1 + dlat(j) = elat(j+1) - elat(j) + enddo + + ! Polar cap (N. Pole) + dlat(jm) = 2.0d0*(elat(jm+1) - elat(jm)) + + do j=1,jm + gw(j) = sine(j+1) - sine(j) + cosp(j) = gw(j) / dlat(j) + + dtdx5(j) = 0.5d0 * dt / (dlon*ae*cosp(j)) + dtdy5(j) = 0.5d0 * dt / (ae*dlat(j)) + enddo + + ! Echo info to stdout + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) & + 'TPCORE_FVDAS (based on GMI) Tracer Transport Module successfully initialized' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + END SUBROUTINE Init_Tpcore +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Exit_Tpcore +! +! !DESCRIPTION: Subroutine Exit\_Tpcore deallocates all module variables. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Exit_Tpcore +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +!EOP +!------------------------------------------------------------------------------ +!BOC + + ! Deallocate arrays only if they are allocated + IF ( ALLOCATED( COSP ) ) DEALLOCATE( COSP ) + IF ( ALLOCATED( COSE ) ) DEALLOCATE( COSE ) + IF ( ALLOCATED( GW ) ) DEALLOCATE( GW ) + IF ( ALLOCATED( DTDX5 ) ) DEALLOCATE( DTDX5 ) + IF ( ALLOCATED( DTDY5 ) ) DEALLOCATE( DTDY5 ) + IF ( ALLOCATED( DLAT ) ) DEALLOCATE( DLAT ) + + END SUBROUTINE Exit_Tpcore +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Tpcore_FvDas +! +! !DESCRIPTION: Subroutine Tpcore\_FvDas takes horizontal winds on sigma +! (or hybrid sigma-p) surfaces and calculates mass fluxes, and then updates +! the 3D mixing ratio fields one time step (tdt). The basic scheme is a +! Multi-Dimensional Flux Form Semi-Lagrangian (FFSL) based on the van Leer +! or PPM (see Lin and Rood, 1995). +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Tpcore_FvDas( dt, ae, IM, JM, KM, & + JFIRST, JLAST, ng, mg, nq, & + ak, bk, u, v, ps1, & + ps2, ps, q, iord, jord, & + kord, n_adj, XMASS, YMASS, MASSFLEW, & + MASSFLNS, MASSFLUP, AREA_M2, TCVV, ND24, & + ND25, ND26, FILL ) +! +! !USES: +! + ! Include file w/ physical constants +# include "CMN_GCTM" +! +! !INPUT PARAMETERS: +! + ! Transport time step [s] + REAL*8, INTENT(IN) :: dt + + ! Earth's radius [m] + REAL*8, INTENT(IN) :: ae + + ! Global E-W, N-S, and vertical dimensions + INTEGER, INTENT(IN) :: IM + INTEGER, INTENT(IN) :: JM + INTEGER, INTENT(IN) :: KM + + ! Latitude indices for local first box and local last box + ! (NOTE: for global grids these are 1 and JM, respectively) + INTEGER, INTENT(IN) :: JFIRST + INTEGER, INTENT(IN) :: JLAST + + ! Primary ghost region + ! (NOTE: only required for MPI parallelization; use 0 otherwise) + INTEGER, INTENT(IN) :: ng + + ! Secondary ghost region + ! (NOTE: only required for MPI parallelization; use 0 otherwise) + INTEGER, INTENT(IN) :: mg + + ! Ghosted latitudes (3 required by PPM) + ! (NOTE: only required for MPI parallelization; use 0 otherwise) + INTEGER, INTENT(IN) :: nq + + ! Flags to denote E-W, N-S, and vertical transport schemes + INTEGER, INTENT(IN) :: iord + INTEGER, INTENT(IN) :: jord + INTEGER, INTENT(IN) :: kord + + ! Number of adjustments to air_mass_flux (0 = no adjustment) + INTEGER, INTENT(IN) :: n_adj + + ! Ak and Bk coordinates to specify the hybrid grid + ! (see the REMARKS section below) + REAL*8, INTENT(IN) :: ak(KM+1) + REAL*8, INTENT(IN) :: bk(KM+1) + + ! u-wind (m/s) at mid-time-level (t=t+dt/2) + REAL*8, INTENT(IN) :: u(:,:,:) + + ! E/W and N/S mass fluxes [kg/s] + ! (These are computed by the pressure fixer, and passed into TPCORE) + REAL*8, INTENT(IN) :: XMASS(:,:,:) + REAL*8, INTENT(IN) :: YMASS(:,:,:) + + ! Grid box surface area for mass flux diag [m2] + REAL*8, INTENT(IN) :: AREA_M2(JM) + + ! Tracer masses for flux diag + REAL*8, INTENT(IN) :: TCVV(NQ) + + ! Diagnostic flags + INTEGER, INTENT(IN) :: ND24 ! Turns on E/W flux diagnostic + INTEGER, INTENT(IN) :: ND25 ! Turns on N/S flux diagnostic + INTEGER, INTENT(IN) :: ND26 ! Turns on up/down flux diagnostic + + ! Negative Concentration Filling Parameter + LOGICAL, INTENT(IN) :: FILL ! Turns on up/down flux diagnostic +! +! !INPUT/OUTPUT PARAMETERS: +! + ! V-wind (m/s) at mid-time-level (t=t+dt/2) + REAL*8, INTENT(INOUT) :: v(:,:,:) + + ! surface pressure at current time + REAL*8, INTENT(INOUT) :: ps1(IM, JFIRST:JLAST) + + ! surface pressure at future time=t+dt + REAL*8, INTENT(INOUT) :: ps2(IM, JFIRST:JLAST) + + ! Tracer "mixing ratios" [v/v] + REAL*8, INTENT(INOUT), TARGET :: q(:,:,:,:) + + ! Add pointer to avoid array temporary in call to FZPPM (bmy, 6/5/13) + REAL*8, POINTER :: ptr_Q(:,:,:) + + ! E/W, N/S, and up/down diagnostic mass fluxes +!--- Previous to (ccc, 12/3/09) +! REAL*8, INTENT(INOUT) :: MASSFLEW(IM,JM,KM,NQ) ! for ND24 diagnostic +! REAL*8, INTENT(INOUT) :: MASSFLNS(IM,JM,KM,NQ) ! for ND25 diagnostic +! REAL*8, INTENT(INOUT) :: MASSFLUP(IM,JM,KM,NQ) ! for ND26 diagnostic + REAL*8, INTENT(INOUT) :: MASSFLEW(:,:,:,:) ! for ND24 diagnostic + REAL*8, INTENT(INOUT) :: MASSFLNS(:,:,:,:) ! for ND25 diagnostic + REAL*8, INTENT(INOUT) :: MASSFLUP(:,:,:,:) ! for ND26 diagnostic + +! !OUTPUT PARAMETERS: +! + ! "Predicted" surface pressure [hPa] + REAL*8, INTENT(OUT) :: ps(IM,JFIRST:JLAST) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO) +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Modified OpenMp parallelization and move the +! loops over vertical levels outside the +! horizontal transport routines for reducing +! processing time. +! +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !DEFINED PARAMETERS: +! +! LOGICAL, PARAMETER :: FILL = .true. ! Fill negatives ? + INTEGER, PARAMETER :: ADVEC_CONSRV_OPT = 2 ! 2=floating pressure + LOGICAL, PARAMETER :: CROSS = .true. +! +! !LOCAL VARIABLES: +! + INTEGER :: rj2m1 + INTEGER :: j1p, j2p + INTEGER :: jn (km) + INTEGER :: js (km) + INTEGER :: il, ij, ik, iq, k, j, i + INTEGER :: num, k2m1 + + REAL*8 :: dap (km) + REAL*8 :: dbk (km) + REAL*8 :: cx(im,jfirst-ng:jlast+ng,km) ! E-W CFL # on C-grid + REAL*8 :: cy(im,jfirst:jlast+mg,km) ! N-S CFL # on C-grid + REAL*8 :: delp1(im, jm, km) + REAL*8 :: delp2(im, jm, km) + REAL*8 :: delpm(im, jm, km) + REAL*8 :: pu (im, jm, km) + REAL*8 :: dpi(im, jm, km) + REAL*8 :: geofac (jm) ! geometrical factor for meridional + ! advection; geofac uses correct + ! spherical geometry, and replaces + ! RGW_25. (ccc, 4/1/09) + REAL*8 :: geofac_pc ! geometrical gactor for poles. + REAL*8 :: dp + REAL*8 :: dps_ctm(im,jm) + REAL*8 :: ua (im, jm, km) + REAL*8 :: va (im, jm, km) + REAL*8 :: wz(im, jm, km) + REAL*8 :: dq1(im,jfirst-ng:jlast+ng,km) + + ! qqu, qqv, adx and ady are now 2d arrays for parallelization purposes. + !(ccc, 4/1/08) + REAL*8 :: qqu(im, jm) + REAL*8 :: qqv(im, jm) + REAL*8 :: adx(im, jm) + REAL*8 :: ady(im, jm) + + ! fx, fy, fz and qtemp are now 4D arrays for parallelization purposes. + ! (ccc, 4/1/09) + REAL*8 :: fx (im, jm, km, nq) + REAL*8 :: fy (im, jm+1, km, nq) ! one more for edges + REAL*8 :: fz (im, jm, km, nq) + REAL*8 :: qtemp (im, jm, km, nq) + REAL*8 :: DTC(IM,JM,KM) ! up/down flux temp array + REAL*8 :: TRACE_DIFF ! up/down flux variable + + LOGICAL, SAVE :: first = .true. + + ! ---------------------------------------------------- + ! ilmt : controls various options in E-W advection + ! jlmt : controls various options in N-S advection + ! klmt : controls various options in vertcal advection + ! ---------------------------------------------------- + + INTEGER, SAVE :: ilmt, jlmt, klmt + INTEGER :: js2g0, jn2g0 + + ! ---------------- + ! Begin execution. + ! ---------------- + + ! adj_group: BUG FIX During the adjoint call to GEOS-5 transport, the array "va" sometimes + ! ends up with random values, say in locations like va(71,2), which are never + ! inititialized or explicitly defined. Shouldn't they be defined somewhere? + ! That could be a bug in fwd model... but initializing va to 0d0 at the + ! start of TPCORE fixes the problem. Note that the symptom is: + ! forrtl: severe (408): fort: (3): Subscript #2 of the array QQUWK has + ! value -2 which is less than the lower bound of -1 + ! So initialize va to 0d0 for now (dkh, 09/20/09). + va = 0d0 + + ! Add definition of j1p and j2p for enlarge polar cap. (ccc, 11/20/08) + j1p = 3 + j2p = jm - j1p + 1 + + ! Average surf. pressures in the polar cap. (ccc, 11/20/08) + CALL Average_Press_Poles( area_m2, ps1, 1, im, 1, jm, 1, im, 1, jm ) + CALL Average_Press_Poles( area_m2, ps2, 1, im, 1, jm, 1, im, 1, jm ) + + + ! Calculation of some geographic factors. (ccc, 11/20/08) + rj2m1 = jm - 1 + dp = PI / rj2m1 + + do ij = 1, jm + geofac(ij) = dp / (2.0d0 * area_m2(ij)/(sum(area_m2) * im) * im) + end do + + geofac_pc = & + dp / (2.0d0 * (Sum (area_m2(1:2))/(sum(area_m2) * im)) * im) + + + if (first) then + + first = .false. + + ! ============= + call Set_Lmts & + ! ============= + (ilmt, jlmt, klmt, im, jm, iord, jord, kord) + + end if + + ! Pressure calculations. (ccc, 11/20/08) + do ik=1,km + dap(ik) = ak(ik+1) - ak(ik) + dbk(ik) = bk(ik+1) - bk(ik) + enddo + + +!$OMP PARALLEL DO & +!$OMP DEFAULT( SHARED )& +!$OMP PRIVATE( IK, IQ ) + do ik=1,km + + ! ==================== + call Set_Press_Terms & + ! ==================== + (dap(ik), dbk(ik), ps1, ps2, delp1(:,:,ik), delpm(:,:,ik), & + pu(:,:,ik), & + 1, jm, 1, im, 1, jm, & + j1p, j2p, 1, im, 1, jm) + ! + !...intent(in) dap - difference in ai across layer (mb) + !...intent(in) dbk - difference in bi across layer (mb) + !...intent(in) pres1 - surface pressure at t1 (mb) + !...intent(in) pres2 - surface pressure at t1+tdt (mb) + !...intent(out) delp1 - pressure thickness at t1 (mb) + !...intent(out) delpm - pressure thickness at t1+tdt/2 (mb) + !...intent(out) pu - pressure at edges of box for "u" (mb) + ! + + if (j1p /= 1+1) then + + do iq = 1, nq + ! ======================== + call Average_Const_Poles & + ! ======================== + (dap(ik), dbk(ik), area_m2, ps1, q(:,:,ik,iq), & + 1, jm, im, & + 1, im, 1, jm, 1, im, 1, jm) + + end do + + end if + + + ! ================= + call Calc_Courant & + ! ================= + (cose, delpm(:,:,ik), pu(:,:,ik), xmass(:,:,ik), ymass(:,:,ik),& + cx(:,:,ik), cy(:,:,ik), & + j1p, j2p, & + 1, jm, 1, im, 1, jm, 1, im, 1, jm) + + ! ==================== + call Calc_Divergence & + ! ==================== + (.true., geofac_pc, geofac, dpi(:,:,ik), xmass(:,:,ik), & + ymass(:,:,ik), & + j1p, j2p, 1, im, & + 1, jm, 1, im, 1, jm, 1, im, 1, jm) + + ! ==================== + call Set_Cross_Terms & + ! ==================== + (cx(:,:,ik), cy(:,:,ik), ua(:,:,ik), va(:,:,ik), & + j1p, j2p, 1, im, 1, jm, & + 1, im, 1, jm, 1, im, 1, jm, CROSS) + + end do +!$OMP END PARALLEL DO + + dps_ctm(:,:) = Sum (dpi(:,:,:), dim=3) + + ! ======================== + call Calc_Vert_Mass_Flux & + ! ======================== + (dbk, dps_ctm, dpi, wz, & + 1, im, 1, jm, 1, km) + + !.sds2.. have all mass flux here: east-west(xmass), + ! north-south(ymass), vertical(wz) + !.sds2.. save omega (vertical flux) as diagnostic + + ! ============== + call Set_Jn_Js & + ! ============== + (jn, js, cx, & + 1, im, 1, jm, 1, jm, j1p, j2p, & + 1, im, 1, jm, 1, km) + + + if (advec_consrv_opt == 0) then + + !---------------------------------------------------------------- + ! Prior to 12/5/08: + ! Replace these with explicit DO loops to facilitate + ! OpenMP parallelization (bmy, 12/5/08) + !do ik = 1, km + ! + ! delp2(:,:,ik) = & + ! dap(ik) + & + ! (dbk(ik) * (ps1(:,:) + & + ! dps_ctm(:,:))) + ! + !end do + !---------------------------------------------------------------- + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( IK, IJ, IL ) + do ik = 1, km + do ij = 1, jm + do il = 1, im + delp2(il,ij,ik) = & + dap(ik) + & + (dbk(ik) * (ps1(il,ij) + & + dps_ctm(il,ij))) + + end do + end do + end do + !$OMP END PARALLEL DO + + else if ((advec_consrv_opt == 1) .or. & + (advec_consrv_opt == 2)) then + + !---------------------------------------------------------------- + ! Prior to 12/5/08: + ! Replace these with explicit DO loops to facilitate + ! OpenMP parallelization (bmy, 12/5/08) + !do il = 1, im + ! + ! delp2(:,:,ik) = & + ! dap(ik) + & + ! (dbk(ik) * ps2(:,:)) + ! + !end do + !---------------------------------------------------------------- + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( IK, IJ, IL ) + do ik = 1, km + do ij = 1, jm + do il = 1, im + + delp2(il,ij,ik) = & + dap(ik) + & + (dbk(ik) * ps2(il,ij)) + + end do + end do + end do + !$OMP END PARALLEL DO + + end if + + ! Calculate surf. pressure at t+dt. (ccc, 11/20/08) + ps = ak(1)+sum(delp2,dim=3) + + +!-------------------------------------------------------- +! For time optimization : we parallelize over tracers and +! we loop over the levels outside horizontal transport +! subroutines. (ccc, 4/1/09) +!-------------------------------------------------------- +!$OMP PARALLEL DO & +!$OMP DEFAULT( SHARED )& +!$OMP PRIVATE( IQ, IK, adx, ady, qqu, qqv, dq1, ptr_Q ) + do iq = 1, nq + + do ik = 1, km + + !.sds.. convert to "mass" + dq1(:,:,ik) = q(:,:,ik,iq) * delp1(:,:,ik) + + + + ! =========================== + call Calc_Advec_Cross_Terms & + ! =========================== + (jn(ik), js(ik), q(:,:,ik,iq), qqu, qqv, & + ua(:,:,ik), va(:,:,ik), & + j1p, j2p, im, 1, jm, 1, im, 1, jm, & + 1, im, 1, jm, CROSS) + + !.sds.. notes on arrays + ! q (in) - species mixing ratio + ! qqu (out) - concentration contribution from E-W + ! advection cross terms(mixing ratio) + ! qqv (out) - concentration contribution from N-S + ! advection cross terms(mixing ratio) + ! ua (in) - average of Courant numbers from il and il+1 + ! va (in) - average of Courant numbers from ij and ij+1 + + ! ---------------------------------------------------- + ! Add advective form E-W operator for E-W cross terms. + ! ---------------------------------------------------- + + ! ============== + call Xadv_Dao2 & + ! ============== + (2, jn(ik), js(ik), adx, qqv, & + ua(:,:,ik), & + 1, im, 1, jm, 1, jm, j1p, j2p, & + 1, im, 1, jm) + !.sds notes on output arrays + ! adx (out)- cross term due to E-W advection (mixing ratio) + ! qqv (in) - concentration contribution from N-S + ! advection (mixing ratio) + ! ua (in) - average of Courant numbers from il and il+1 + !.sds + + ! ---------------------------------------------------- + ! Add advective form N-S operator for N-S cross terms. + ! ---------------------------------------------------- + + ! ============== + call Yadv_Dao2 & + ! ============== + (2, ady, qqu, va(:,:,ik), & + 1, im, 1, jm, & + j1p, j2p, 1, im, 1, jm, 1, im, 1, jm) + + !.sds notes on output arrays + ! ady (out)- cross term due to N-S advection (mixing ratio) + ! qqu (in) - concentration contribution from N-S advection + ! (mixing ratio) + ! va (in) - average of Courant numbers from il and il+1 + !.sds + ! + !.bmy notes: use a polar cap of 2 boxes (i.e. the "2" as + ! the first argument to YADV_DAO2. The older TPCORE only had + ! a polar cap of 1 box (just the Pole itself). Claire figured + ! this out. (bmy, 12/11/08) + + !... update constituent array qq1 by adding in cross terms + ! - use in fzppm + q(:,:,ik,iq) = q(:,:,ik,iq) + ady + adx + + + ! ======== + call Xtp & + ! ======== + (ilmt, jn(ik), js(ik), pu(:,:,ik), cx(:,:,ik), & + dq1(:,:,ik), qqv, xmass(:,:,ik), fx(:,:,ik,iq), & + j1p, j2p, im, 1, jm, 1, im, 1, jm, & + 1, im, 1, jm, IORD) + + !.sds notes on output arrays + ! pu (in) - pressure at edges in "u" (mb) + ! crx (in) - Courant number in E-W direction + ! dq1 (inout) - species density (mb) - updated with the E-W flux + ! fx in Xtp) + ! qqv (inout) - concentration contribution from N-S advection + ! (mixing ratio) + ! xmass(in) - horizontal mass flux in E-W direction (mb) + ! fx (out) - species E-W mass flux + !.sds + + ! ======== + call Ytp & + ! ======== + (jlmt, geofac_pc, geofac, cy(:,:,ik), dq1(:,:,ik), & + qqu, qqv, ymass(:,:,ik), fy(:,:,ik,iq), & + j1p, j2p, 1, im, 1, jm, im, & + 1, im, 1, jm, 1, im, 1, jm, jord) + + !.sds notes on output arrays + ! cy (in) - Courant number in N-S direction + ! dq1 (inout) - species density (mb) - updated with the N-S flux + ! (fy in Ytp) + ! qqu (in) - concentration contribution from E-W advection + ! (mixing ratio) + ! qqv (inout) - concentration contribution from N-S advection + ! (mixing ratio) + ! ymass(in) - horizontal mass flux in E-W direction (mb) + ! fy (out) - species N-S mass flux (need to mult by geofac) + !.sds + + end do + + qtemp(:,:,:,iq) = q(:,:,:,iq) + + ! Set up temporary pointer to Q to avoid array temporary in FZPPM + ! (bmy, 6/5/13) + ptr_Q => q(:,:,:,iq) + + ! ========== + call Fzppm & + ! ========== + (klmt, delp1, wz, dq1, ptr_Q, fz(:,:,:,iq), & + j1p, 1, jm, 1, im, 1, jm, & + im, km, 1, im, 1, jm, 1, km) + + !.sds notes on output arrays + ! wz (in) : vertical mass flux + ! dq1 (inout) : species density (mb) + ! q (in) : species concentration (mixing ratio) + !.sds + + ! Free pointer memory (bmy, 6/5/13) + NULLIFY( ptr_Q ) + + if (FILL) then + ! =========== + call Qckxyz & + ! =========== + (dq1, & + j1p, j2p, 1, jm, & + 1, im, 1, jm, 1, im, 1, jm, 1, km) + end if + + q(:,:,:,iq) = & + dq1 / delp2 + + + if (j1p /= 2) then + + q(:,2,:,iq) = q(:,1,:,iq) + q(:,jm-1,:,iq) = q(:,jm,:,iq) + + end if + ENDDO +!$OMP END PARALLEL DO + + DO iq=1,nq + + ! Calculate fluxes for diag. (ccc, 11/20/08) + !-------------------------------------------------------------- + ! Prior to 12/11/08: + ! Set with J1P and J2P for extended polar cap (bmy, 12/11/08) + !js2g0 = max(2,jfirst) ! No ghosting + !jn2g0 = min(jm-1,jlast) ! No ghosting + !-------------------------------------------------------------- + JS2G0 = MAX( J1P, JFIRST ) ! No ghosting + JN2G0 = MIN( J2P, JLAST ) ! No ghosting + + !====================================================================== + ! MODIFICATION by Harvard Atmospheric Chemistry Modeling Group + ! + ! Implement ND24 diag: E/W flux of tracer [kg/s] (ccarouge 12/2/08) + ! + ! The unit conversion is: + ! + ! Mass P diff 100 1 area of kg tracer 1 + ! ------ = in grid * --- * --- * grid box * ----------- * --- + ! time box 1 g AREA_M2 kg air s + ! + ! kg hPa Pa s^2 m^2 1 1 + ! ---- = ----- * ----- * ----- * ----- * ------ * -------- + ! s 1 hPa m 1 TCVV DeltaT + !====================================================================== + IF ( ND24 > 0 ) THEN + + ! Zero temp array + DTC = 0d0 + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J, K ) + DO K = 1, KM + DO J = JS2G0, JN2G0 + DO I = 1, IM + + ! Compute mass flux + DTC(I,J,K) = ( FX(I,J,K,IQ) * AREA_M2(J) * 100.d0 ) / & + ( TCVV(IQ) * DT * 9.8d0 ) + + ! Save into MASSFLEW diagnostic array + MASSFLEW(I,J,K,IQ) = MASSFLEW(I,J,K,IQ) + DTC(I,J,K) + + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + + ENDIF + + !====================================================================== + ! MODIFICATION by Harvard Atmospheric Chemistry Modeling Group + ! + ! Implement ND25 diag: N/S flux of tracer [kg/s] + ! (bdf, bmy, 9/28/04, ccarouge 12/12/08) + ! + ! NOTE, the unit conversion is the same as desciribed above for the + ! ND24 E-W diagnostics. The geometrical factor was already applied to + ! fy in Ytp. (ccc, 4/1/09) + !====================================================================== + IF ( ND25 > 0 ) THEN + + ! Zero temp array + DTC = 0d0 + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J, K ) + DO K = 1, KM + DO J = 1, JM + DO I = 1, IM + + ! Compute mass flux + DTC(I,J,K) = ( FY(I,J,K,IQ) * AREA_M2(J) * 1d2 ) / & + ( TCVV(IQ) * DT * 9.8d0 ) + + ! Save into MASSFLNS diagnostic array + MASSFLNS(I,J,K,IQ) = MASSFLNS(I,J,K,IQ) + DTC(I,J,K) + + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + + ENDIF + + !====================================================================== + ! MODIFICATION by Harvard Atmospheric Chemistry Modeling Group + ! + ! Implement ND26 diag: Up/down flux of tracer [kg/s] + ! (bmy, bdf, 9/28/04, ccarouge 12/2/08) + ! + ! The vertical transport done in qmap. We need to find the difference + ! in order to to interpret transport. + ! + ! Break up diagnostic into up & down fluxes using the surface boundary + ! conditions. Start from top down (really surface up for flipped + ! TPCORE) + ! + ! By construction, MASSFLUP is flux into the bottom of the box. The + ! flux at the bottom of KM (the surface box) is not zero by design. + ! (phs, 3/4/08) + !====================================================================== + IF ( ND26 > 0 ) THEN + + ! Zero temp array + DTC = 0d0 + + !----------------- + ! start with top + !----------------- + K = 1 + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J ) + DO J = 1, JM + DO I = 1, IM + + ! Compute mass flux + DTC(I,J,K) = ( Q(I,J,K,IQ) * DELP1(I,J,K) - & + QTEMP(I,J,K,IQ) * DELP2(I,J,K) ) * & + (100d0) * AREA_M2(J) / ( 9.8d0 * TCVV(IQ) ) + + ! top layer should have no residual. the small residual is + ! from a non-pressure fixed flux diag. The z direction may + ! be off by a few percent. + ! + ! Uncomment now, since this is upflow into the box from its + ! bottom (phs, 3/4/08) + MASSFLUP(I,J,K,IQ) = MASSFLUP(I,J,K,IQ) + DTC(I,J,K)/DT + ENDDO + ENDDO + !$OMP END PARALLEL DO + + !---------------------------------------------------- + ! Get the other fluxes using a mass balance equation + !---------------------------------------------------- + DO K = 2, KM + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J, TRACE_DIFF ) + DO J = 1, JM + DO I = 1, IM + + ! Compute tracer difference + TRACE_DIFF = ( Q(I,J,K,IQ) * DELP1(I,J,K) - & + QTEMP(I,J,K,IQ) * DELP2(I,J,K) ) * & + (100D0) * AREA_M2(J) / & + ( 9.8D0* TCVV(IQ) ) + + ! Compute mass flux + DTC(I,J,K) = DTC(I,J,K-1) + TRACE_DIFF + + ! Save to the MASSFLUP diagnostic array + MASSFLUP(I,J,K,IQ) = MASSFLUP(I,J,K,IQ) + DTC(I,J,K)/DT + + ENDDO + ENDDO + !$OMP END PARALLEL DO + + ENDDO + ENDIF + ENDDO + END SUBROUTINE Tpcore_FvDas +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Average_Const_Poles +! +! !DESCRIPTION: Subroutine Average\_Const\_Poles averages the species +! concentrations at the Poles when the Polar cap is enlarged. It makes the +! last two latitudes equal. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Average_Const_Poles( dap , dbk, rel_area, pctm1, const1, & + JU1_GL, J2_GL, I2_GL, I1, I2, & + JU1, J2, ILO, & + IHI, JULO, JHI ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices of the South Pole and North Pole + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Global max longitude index + INTEGER, INTENT(IN) :: I2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Pressure difference across layer from (ai * pt) term [hPa] + REAL*8, INTENT(IN) :: dap + + ! Difference in bi across layer - the dSigma term + REAL*8, INTENT(IN) :: dbk + + ! Relative surface area of grid box [fraction] + REAL*8, INTENT(IN) :: rel_area(JU1:J2) + + ! CTM surface pressure at t1 [hPa] + REAL*8, INTENT(IN) :: pctm1( ILO:IHI, JULO:JHI ) +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Species concentration, known at zone center [mixing ratio] + REAL*8, INTENT(INOUT) :: const1( I1:I2, JU1:J2) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO) +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: ik, il + + REAL*8 :: meanq + REAL*8 :: sum1, sum2 + +! ----------------------------------------------------------------- +! delp1n : pressure thickness at North Pole, the psudo-density in a +! hydrostatic system at t1 (mb) +! delp1s : pressure thickness at South Pole, the psudo-density in a +! hydrostatic system at t1 (mb) +! ----------------------------------------------------------------- + + REAL*8 :: delp1n(i1:i2, j2-1:j2) + REAL*8 :: delp1s(i1:i2, ju1:ju1+1) + + +! ---------------- +! Begin execution. +! ---------------- + +! ================= + if (ju1 == ju1_gl) then +! ================= + + delp1s(i1:i2,ju1:ju1+1) = & + dap + & + (dbk * pctm1(i1:i2,ju1:ju1+1)) + + sum1=0.0d0 + sum2=0.0d0 + do il = i1, i2 + sum1 = sum1 + & + Sum (const1 (il,ju1:ju1+1) * & + delp1s (il,ju1:ju1+1) * & + rel_area(ju1:ju1+1)) & + / (sum(rel_area) * i2_gl) + + sum2 = sum2 + & + Sum (delp1s (il,ju1:ju1+1) * & + rel_area(ju1:ju1+1)) & + / (sum(rel_area) * i2_gl) + enddo + + meanq = sum1 / sum2 + + const1(:,ju1:ju1+1) = meanq + + + end if + + +! ================ + if (j2 == j2_gl) then +! ================ + + delp1n(i1:i2,j2-1:j2) = & + dap + & + (dbk * pctm1(i1:i2,j2-1:j2)) + + sum1=0.0d0 + sum2=0.0d0 + do il = i1, i2 + sum1 = sum1 + & + Sum (const1 (il,j2-1:j2) * & + delp1n (il,j2-1:j2) * & + rel_area(j2-1:j2)) & + / (sum(rel_area) * i2_gl) + + sum2 = sum2 + & + Sum (delp1n (il,j2-1:j2) * & + rel_area(j2-1:j2)) & + / (sum(rel_area) * i2_gl) + enddo + + + meanq = sum1 / sum2 + + const1(:,j2-1:j2) = meanq + + end if + + END SUBROUTINE Average_Const_Poles +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Set_Cross_Terms +! +! !DESCRIPTION: Subroutine Set\_Cross\_Terms sets the cross terms for +! E-W horizontal advection. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Set_Cross_Terms( crx, cry, ua, va, J1P, J2P, & + I1_GL, I2_GL, JU1_GL, J2_GL, ILO, & + IHI, JULO, JHI, I1, I2, & + JU1, J2, CROSS ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Courant number in E-W direction + REAL*8, INTENT(IN) :: crx(ILO:IHI, JULO:JHI) + + ! Courant number in N-S direction + REAL*8, INTENT(IN) :: cry(ILO:IHI, JULO:JHI) + + ! Logical switch. If CROSS=T then cross-terms will be computed. + LOGICAL, INTENT(IN) :: CROSS +! +! !OUTPUT PARAMETERS: +! + ! Average of Courant numbers from il and il+1 + REAL*8, INTENT(OUT) :: ua(ILO:IHI, JULO:JHI) + + ! Average of Courant numbers from ij and ij+1 + REAL*8, INTENT(OUT) :: va(ILO:IHI, JULO:JHI) + +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO) +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + + ! Grid box indices for lon & lat + INTEGER :: il, ij + + ! ---------------- + ! Begin execution. + ! ---------------- + + + if (.not. CROSS) then + + ua(:,:) = 0.0d0 + va(:,:) = 0.0d0 + + else + + ! Old + !do ij = j1p, j2p + ! do il = i1, i2-1 + ! + ! ua(il,ij) = 0.5d0 * (crx(il,ij) + crx(il+1,ij)) + ! + ! va(il,ij) = 0.5d0 * (cry(il,ij) + cry(il,ij+1)) + ! end do + ! ua(i2,ij) = 0.5d0 * (crx(i2,ij) + crx(1,ij)) + ! va(i2,ij) = 0.5d0 * (cry(i2,ij) + cry(i2,ij+1)) + ! + !end do + ! BUG FIX: + do ij = j1p, j2p + do il = i1, i2-1 + + ua(il,ij) = 0.5d0 * (crx(il,ij) + crx(il+1,ij)) + + end do + ua(i2,ij) = 0.5d0 * (crx(i2,ij) + crx(1,ij)) + end do + + do ij = ju1+1, j2-1 + do il = i1, i2 + + va(il,ij) = 0.5d0 * (cry(il,ij) + cry(il,ij+1)) + end do + end do + + +! ============================= + call Do_Cross_Terms_Pole_I2d2 & +! ============================= + (cry, va, & + i1_gl, i2_gl, ju1_gl, j2_gl, j1p, & + ilo, ihi, julo, jhi, i1, i2, ju1, j2) + + + end if + + END SUBROUTINE Set_Cross_Terms +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Calc_Vert_Mass_Flux +! +! !DESCRIPTION: Subroutine Calc\_Vert\_Mass\_Flux calculates the vertical +! mass flux. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Calc_Vert_Mass_Flux( dbk, dps_ctm, dpi, wz, I1, & + I2, JU1, J2, K1, K2 ) +! +! !INPUT PARAMETERS: +! + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + INTEGER, INTENT(IN) :: K1, K2 + + ! Difference in bi across layer - the dSigma term + REAL*8, INTENT(IN) :: dbk(K1:K2) + + ! CTM surface pressure tendency; sum over vertical of dpi + ! calculated from original mass fluxes [hPa] + REAL*8, INTENT(IN) :: dps_ctm(I1:I2, JU1:J2) + + ! Divergence at a grid point; used to calculate vertical motion [mb] + REAL*8, INTENT(IN) :: dpi(I1:I2, JU1:J2, K1:K2) +! +! !OUTPUT PARAMETERS: +! + ! Large scale mass flux (per time step tdt) in the vertical + ! direction as diagnosed from the hydrostatic relationship [hPa] + REAL*8, INTENT(OUT) :: wz(I1:I2, JU1:J2, K1:K2) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO) +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: ik, ij, il + +! ---------------- +! Begin execution. +! ---------------- + +! -------------------------------------------------- +! Compute vertical mass flux from mass conservation. +! -------------------------------------------------- + + !--------------------------------------------------------------------- + ! Prior to 12/5/08: + ! Need to add explicit IJ and IL loops for OpenMP parallelization + ! (bmy, 12/5/08) + ! + !wz(:,:,k1) = & + ! dpi(:,:,k1) - & + ! (dbk(k1) * dps_ctm(i1:i2,ju1:j2)) + ! + !wz(:,:,k2) = 0.0d0 + ! + ! + !do ik = k1 + 1, k2 - 1 + ! + ! wz(:,:,ik) = & + ! wz (:,:,ik-1) + & + ! dpi(:,:,ik) - & + ! (dbk(ik) * dps_ctm(i1:i2,ju1:j2)) + ! + !end do + !--------------------------------------------------------------------- + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( IJ, IL ) + do ij = ju1, j2 + do il = i1, i2 + wz(il,ij,k1) = & + dpi(il,ij,k1) - & + (dbk(k1) * dps_ctm(il,ij)) + + wz(il,ij,k2) = 0.0d0 + end do + end do + !$OMP END PARALLEL DO + + do ik = k1 + 1, k2 - 1 + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( IJ, IL ) + do ij = ju1, j2 + do il = i1, i2 + + wz(il,ij,ik) = & + wz (il,ij,ik-1) + & + dpi(il,ij,ik) - & + (dbk(ik) * dps_ctm(il,ij)) + end do + end do + !$OMP END PARALLEL DO + + end do + + + END SUBROUTINE Calc_Vert_Mass_Flux +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Set_Jn_Js +! +! !DESCRIPTION: Subroutine Set\_Jn\_Js determines Jn and Js, by looking +! where Courant number is > 1. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Set_Jn_Js( jn, js, crx, ILO, IHI, JULO, & + JHI, JU1_GL, J2_GL, J1P, J2P, I1, & + I2, JU1, J2, K1, K2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + INTEGER, INTENT(IN) :: K1, K2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Courant number in E-W direction + REAL*8, INTENT(IN) :: crx(ILO:IHI, JULO:JHI, K1:K2) +! +! !OUTPUT PARAMETERS: +! + ! Northward of latitude index = jn; Courant numbers could be > 1, + ! so use the flux-form semi-Lagrangian scheme + INTEGER, INTENT(OUT) :: jn(K1:K2) + + ! Southward of latitude index = js; Courant numbers could be > 1, + ! so use the flux-form semi-Lagrangian scheme + INTEGER, INTENT(OUT) :: js(K1:K2) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO) +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REMARKS: +! We cannot parallelize this subroutine because there is a CYCLE statement +! within the outer loop. +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: + + INTEGER :: il, ij, ik + INTEGER :: jn0, js0 + INTEGER :: jst, jend + + + ! ---------------- + ! Begin execution. + ! ---------------- + + js0 = (j2_gl + 1 ) / 2 + jn0 = j2_gl - js0 + 1 + + jst = Max (ju1, j1p) + jend = Min (j2, js0) + + ikloop1: do ik = k1, k2 + + js(ik) = j1p + + do ij = jend, jst, -1 + do il = i1, i2 + + if (Abs (crx(il,ij,ik)) > 1.0d0) then + + js(ik) = ij + +! ============= + cycle ikloop1 +! ============= + + end if + + end do + end do + + end do ikloop1 + + + jst = Max (ju1, jn0) + jend = Min (j2, j2p) + + ikloop2: do ik = k1, k2 + + jn(ik) = j2p + + do ij = jst, jend + do il = i1, i2 + + if (Abs (crx(il,ij,ik)) > 1.0d0) then + + jn(ik) = ij + +! ============= + cycle ikloop2 +! ============= + + end if + + end do + end do + + end do ikloop2 + + END SUBROUTINE Set_Jn_Js +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Calc_Advec_Cross_Terms +! +! !DESCRIPTION: Subroutine Calc\_Advec\_Cross\_Terms calculates the advective +! cross terms. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Calc_Advec_Cross_Terms( jn, js, qq1, qqu, qqv, & + ua, va, J1P, J2P, I2_GL, & + JU1_GL, J2_GL, ILO, IHI, JULO, & + JHI, I1, I2, JU1, J2, & + CROSS ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Northward of latitude index = jn, Courant numbers could be > 1, + ! so use the flux-form semi-Lagrangian scheme + INTEGER, INTENT(IN) :: Jn + + ! Southward of latitude index = js, Courant numbers could be > 1, + ! so use the flux-form semi-Lagrangian scheme + INTEGER, INTENT(IN) :: Js + + ! Species concentration (mixing ratio) + REAL*8, INTENT(IN) :: qq1(ILO:IHI, JULO:JHI) + + ! Average of Courant numbers from il and il+1 + REAL*8, INTENT(IN) :: ua (ILO:IHI, JULO:JHI) + + ! Average of Courant numbers from ij and ij+1 + REAL*8, INTENT(IN) :: va (ILO:IHI, JULO:JHI) + + ! Logical switch: If CROSS=T then cross-terms are being computed + LOGICAL, INTENT(IN) :: CROSS +! +! !OUTPUT PARAMETERS: +! + ! Concentration contribution from E-W advection [mixing ratio] + REAL*8, INTENT(OUT) :: qqu(ILO:IHI, JULO:JHI) + + ! concentration contribution from N-S advection [mixing ratio] + REAL*8, INTENT(OUT) :: qqv(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO) +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel do loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +! +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: i, imp, il, ij, iu + INTEGER :: jv, iuw, iue + REAL*8 :: ril, rij, riu + REAL*8 :: ru + REAL*8 :: qtmp(-i2/3:i2+i2/3, julo:jhi) + + ! ---------------- + ! Begin execution. + ! ---------------- + + !---------------------------------------------------------------- + ! Prior to 12/5/08 + ! Now add explicit IJ and IK loops for OpenMP parallelization + ! (bmy, 12/5/08) + !do i = 1, i2 + ! qtmp(i,:,:) = qq1(i,:,:) + !enddo + ! + !do il = -i2/3, 0 + ! qtmp(il,:,:) = qq1(i2+il,:,:) + !enddo + ! + !do il = i2+1,i2+i2/3 + ! qtmp(il,:,:) = qq1(il-i2,:,:) + !enddo + ! IK loop was removed. (ccc, 4/1/09) + !---------------------------------------------------------------- + + do ij = julo, jhi + do i = 1, i2 + qtmp(i,ij) = qq1(i,ij) + enddo + + do il = -i2/3, 0 + qtmp(il,ij) = qq1(i2+il,ij) + enddo + + do il = i2+1,i2+i2/3 + qtmp(il,ij) = qq1(il-i2,ij) + enddo + enddo + +! ================ + if (.not. CROSS) then +! ================ + + qqu(:,:) = qq1(:,:) + qqv(:,:) = qq1(:,:) + + +! ==== + else +! ==== + + qqu(:,:) = 0.0d0 + qqv(:,:) = 0.0d0 + + do ij = j1p, j2p + + if ((ij <= js) .or. (ij >= jn)) then + +! ---------------------------------------------------------- +! In Polar area, so need to deal with large courant numbers. +! ---------------------------------------------------------- + + do il = i1, i2 + +!c? + iu = ua(il,ij) + riu = iu + ru = ua(il,ij) - riu + iu = il - iu + + if (ua(il,ij) >= 0.0d0) then + + qqu(il,ij) = & + qtmp(iu,ij) + & + ru * (qtmp(iu-1,ij) - qtmp(iu,ij)) + + else + + qqu(il,ij) = & + qtmp(iu,ij) + & + ru * (qtmp(iu,ij) - qtmp(iu+1,ij)) + + end if + + qqu(il,ij) = qqu(il,ij) - qtmp(il,ij) + + end do + + else ! js < ij < jn + + ! --------------------------- + ! Do interior area (use PPM). + ! --------------------------- + + do il = i1, i2 + + ril = il + iu = ril - ua(il,ij) + + qqu(il,ij) = & + ua(il,ij) * & + (qtmp(iu,ij) - qtmp(iu+1,ij)) + + end do + + end if + + do il = i1, i2 + +!c? + rij = ij + jv = rij - va(il,ij) + + qqv(il,ij) = & + va(il,ij) * & + (qtmp(il,jv) - qtmp(il,jv+1)) + + end do + end do + + !---------------------------------------------------------------- + ! Prior to 12/5/08 + ! Now add explicit IJ and IK loops for OpenMP parallelization + ! (bmy, 12/5/08) + !qqu(i1:i2,ju1:j2,:) = & + ! qtmp(i1:i2,ju1:j2,:) + (0.5d0 * qqu(i1:i2,ju1:j2,:)) + ! + !qqv(i1:i2,ju1:j2,:) = & + ! qtmp(i1:i2,ju1:j2,:) + (0.5d0 * qqv(i1:i2,ju1:j2,:)) + ! IK loop was removed. (ccc, 4/1/09) + !---------------------------------------------------------------- + + do ij = ju1, j2 + do il = i1, i2 + qqu(il,ij) = & + qtmp(il,ij) + (0.5d0 * qqu(il,ij)) + + qqv(il,ij) = & + qtmp(il,ij) + (0.5d0 * qqv(il,ij)) + enddo + enddo + +! ====== + end if +! ====== + + + END SUBROUTINE Calc_Advec_Cross_Terms +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Qckxyz +! +! !DESCRIPTION: Subroutine Qckxyz routine checks for "filling". +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Qckxyz( dq1, J1P, J2P, JU1_GL, J2_GL, & + ILO, IHI, JULO, JHI, I1, & + I2, JU1, J2, K1, K2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max latitude (J) indices + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + INTEGER, INTENT(IN) :: K1, K2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Species density [hPa] + REAL*8, INTENT(INOUT) :: dq1(ILO:IHI, JULO:JHI, K1:K2) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO) +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !DEFINED PARAMETERS: +! + LOGICAL, PARAMETER :: FILL_DIAG = .false. +! +! LOCAL VARIABLES: +! + INTEGER :: il, ij, ik + INTEGER :: ip + INTEGER :: k1p1, k2m1 + REAL*8 :: dup, qup + REAL*8 :: qly + REAL*8 :: sum + + +! ---------------- +! Begin execution. +! ---------------- + + ip = 0 + + +! ---------- +! Top layer. +! ---------- + + k1p1 = k1 + 1 + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( IJ, IL, IP ) + do ij = j1p, j2p + do il = i1, i2 + + if (dq1(il,ij,k1) < 0.0d0) then + + ip = ip + 1 + + dq1(il,ij,k1p1) = dq1(il,ij,k1p1) + dq1(il,ij,k1) + dq1(il,ij,k1) = 0.0d0 + + end if + + end do + end do + !$OMP END PARALLEL DO + + + do ik = k1 + 1, k2 - 1 + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( IJ, IL, IP, QUP, QLY, DUP ) + do ij = j1p, j2p + do il = i1, i2 + + if (dq1(il,ij,ik) < 0.0d0) then + + ip = ip + 1 + +! ----------- +! From above. +! ----------- + + qup = dq1(il,ij,ik-1) + qly = -dq1(il,ij,ik) + dup = Min (qly, qup) + + dq1(il,ij,ik-1) = qup - dup + dq1(il,ij,ik) = dup - qly + +! ----------- +! From below. +! ----------- + + dq1(il,ij,ik+1) = dq1(il,ij,ik+1) + dq1(il,ij,ik) + dq1(il,ij,ik) = 0.0d0 + + end if + + end do + end do + !$OMP END PARALLEL DO + + end do + + +! ------------- +! Bottom layer. +! ------------- + + sum = 0.0d0 + + k2m1 = k2 - 1 + + ! NOTE: Sum seems to be not used in the loop below! + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( IJ, IL, IP, QUP, QLY, DUP ) & + !$OMP REDUCTION( +:SUM ) + do ij = j1p, j2p + do il = i1, i2 + + if (dq1(il,ij,k2) < 0.0d0) then + + ip = ip + 1 + +! ----------- +! From above. +! ----------- + + qup = dq1(il,ij,k2m1) + qly = -dq1(il,ij,k2) + dup = Min (qly, qup) + + dq1(il,ij,k2m1) = qup - dup + +! ------------------------- +! From "below" the surface. +! ------------------------- + + sum = sum + qly - dup + + dq1(il,ij,k2) = 0.0d0 + + end if + + end do + end do + !$OMP END PARALLEL DO + +! We don't want to replace zero values by 1e-30. (ccc, 11/20/08) +!! ======================================= +! where ((dq1(i1:i2,j1p:j2p,:) < 1.0d-30)) & +! dq1(i1:i2,j1p:j2p,:) = 1.0d-30 +!! ======================================= + + END SUBROUTINE Qckxyz +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Set_Lmts +! +! !DESCRIPTION: Subroutine Set\_Lmts sets ILMT, JLMT, KLMT. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Set_Lmts( ilmt, jlmt, klmt, I2_GL, J2_GL, iord, jord, kord ) +! +! !INPUT PARAMETERS: +! + ! Global maximum longitude (I) and longitude (J) indices + INTEGER, INTENT(IN) :: I2_GL, J2_GL + + ! Flags to denote E-W, N-S, and vertical transport schemes + ! (See REMARKS section of routine Tpcore_FvDas for more info) + INTEGER, INTENT(IN) :: iord, jord, kord +! +! !OUTPUT PARAMETERS: +! + ! Controls various options in E-W advection + INTEGER, INTENT(OUT) :: ilmt + + ! Controls various options in N-S advection + INTEGER, INTENT(OUT) :: jlmt + + ! Controls various options in vertical advection + INTEGER, INTENT(OUT) :: klmt +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO) +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: + + INTEGER :: j2_glm1 + +! ---------------- +! Begin execution. +! ---------------- + + j2_glm1 = j2_gl - 1 + +!c? + if (IORD <= 0) then + if (i2_gl >= 144) then + ilmt = 0 + else if (i2_gl >= 72) then + ilmt = 1 + else + ilmt = 2 + end if + else + ilmt = IORD - 3 + end if + + +!c? + if (JORD <= 0) then + if (j2_glm1 >= 90) then + jlmt = 0 + else if (j2_glm1 >= 45) then + jlmt = 1 + else + jlmt = 2 + end if + else + jlmt = JORD - 3 + end if + + klmt = Max ((KORD-3), 0) + + END SUBROUTINE Set_Lmts +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Set_Press_Terms +! +! !DESCRIPTION: Subroutine Set\_Press\_Terms sets the pressure terms: +! DELP1, DELPM, PU. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Set_Press_Terms( dap, dbk, pres1, pres2, delp1, & + delpm, pu, JU1_GL, J2_GL, ILO, & + IHI, JULO, JHI, J1P, J2P, & + I1, I2, JU1, J2) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max latitude (J) indices + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Pressure difference across layer from (ai * pt) term [hPa] + REAL*8, INTENT(IN) :: dap + + ! Difference in bi across layer - the dSigma term + REAL*8, INTENT(IN) :: dbk + + ! Surface pressure at t1 [hPa] + REAL*8, INTENT(IN) :: pres1(ILO:IHI, JULO:JHI) + + ! Surface pressure at t1+tdt [hPa] + REAL*8, INTENT(IN) :: pres2(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Pressure thickness, the pseudo-density in a + ! hydrostatic system at t1 [hPa] + REAL*8, INTENT(OUT) :: delp1(ILO:IHI, JULO:JHI) + + ! Pressure thickness, the pseudo-density in a + ! hydrostatic system at t1+tdt/2 (approximate) [hPa] + REAL*8, INTENT(OUT) :: delpm(ILO:IHI, JULO:JHI) + + ! Pressure at edges in "u" [hPa] + REAL*8, INTENT(OUT) :: pu(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO) +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: il, ij + +! ---------------- +! Begin execution. +! ---------------- + + delp1(:,:) = dap + (dbk * pres1(:,:)) + + delpm(:,:) = & + dap+ & + (dbk * 0.5d0 * (pres1(:,:) + pres2(:,:))) + + do ij = j1p, j2p + pu(1,ij) = 0.5d0 * (delpm(1,ij) + delpm(i2,ij)) + do il = i1+1, i2 + + pu(il,ij) = 0.5d0 * (delpm(il,ij) + delpm(il-1,ij)) + + end do + end do + + + END SUBROUTINE Set_Press_Terms +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Calc_Courant +! +! !DESCRIPTION: Subroutine Calc\_Courant calculates courant numbers from +! the horizontal mass fluxes. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Calc_Courant( cose, delpm, pu, xmass, ymass, crx, cry, & + J1P, J2P, JU1_GL, J2_GL, ILO, IHI, JULO, & + JHI, I1, I2, JU1, J2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max latitude (J) indices + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Cosine of grid box edges + REAL*8, INTENT(IN) :: cose (JU1_GL:J2_GL) + + ! Pressure thickness, the pseudo-density in a hydrostatic system + ! at t1+tdt/2 (approximate) (mb) + REAL*8, INTENT(IN) :: delpm(ILO:IHI, JULO:JHI) + + ! pressure at edges in "u" (mb) + REAL*8, INTENT(IN) :: pu (iLO:IHI, JULO:JHI) + + ! horizontal mass flux in E-W and N-S directions [hPa] + REAL*8, INTENT(IN) :: xmass(ILO:IHI, JULO:JHI) + REAL*8, INTENT(IN) :: ymass(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Courant numbers in E-W and N-S directions + REAL*8, INTENT(OUT) :: crx(ILO:IHI, JULO:JHI) + REAL*8, INTENT(OUT) :: cry(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO) +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: ij + +! ---------------- +! Begin execution. +! ---------------- + + crx(:,:) = 0.0d0 + cry(:,:) = 0.0d0 + +!----------------------------------------------------------------------------- +! Prior to 12/4/08: +! We need to add an outer IK loop for OpenMP parallelization. +! Preserve original code here! (bmy, 12/4/08) +!! ----------------------------------- +!! Calculate E-W horizontal mass flux. +!! ----------------------------------- +! +! do ij = j1p, j2p +! +! crx(:,ij,:) = & +! xmass(:,ij,:) / pu(:,ij,:) +! +! end do +! +! +!! ----------------------------------- +!! Calculate N-S horizontal mass flux. +!! ----------------------------------- +! +! do ij = j1p, j2p+1 +! +! cry(:,ij,:) = & +! ymass(:,ij,:) / & +! ((0.5d0 * cose(ij)) * & +! (delpm(:,ij,:) + delpm(:,ij-1,:))) +! +! end do +! The IK loop was moved outside the subroutine. (ccc, 4/1/09) +!----------------------------------------------------------------------------- + + +! --------------------------------------------- +! Calculate E-W and N-S horizontal mass fluxes. +! --------------------------------------------- + + do ij = j1p, j2p + + crx(:,ij) = & + xmass(:,ij) / pu(:,ij) + + cry(:,ij) = & + ymass(:,ij) / & + ((0.5d0 * cose(ij)) * & + (delpm(:,ij) + delpm(:,ij-1))) + end do + + cry(:,j2p+1) = & + ymass(:,j2p+1) / & + ((0.5d0 * cose(j2p+1)) * & + (delpm(:,j2p+1) + delpm(:,j2p))) + + + + END SUBROUTINE Calc_Courant +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Calc_Divergence + +! +! !DESCRIPTION: Subroutine Calc\_Divergence calculates the divergence. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Calc_Divergence( do_reduction, geofac_pc, geofac, dpi, & + xmass, ymass, J1P, J2P, & + I1_GL, I2_GL, JU1_GL, J2_GL, & + ILO, IHI, JULO, JHI, & + I1, I2, JU1, J2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Set to F if called on Master or T if called by Slaves + ! (NOTE: This is only for MPI parallelization, for OPENMP it should be F) + LOGICAL, INTENT(IN) :: do_reduction + + ! Special geometrical factor (geofac) for Polar cap + REAL*8 , INTENT(IN) :: geofac_pc + + ! Geometrical factor for meridional advection; geofac uses correct + ! spherical geometry, and replaces acosp as the meridional geometrical + ! factor in TPCORE + REAL*8 , INTENT(IN) :: geofac(JU1_GL:J2_GL) + + ! Horizontal mass flux in E/W and N/S directions [hPa] + REAL*8 , INTENT(IN) :: xmass(ILO:IHI, JULO:JHI) + REAL*8 , INTENT(IN) :: ymass(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Divergence at a grid point; used to calculate vertical motion [hPa] + REAL*8, INTENT(OUT) :: dpi(I1:I2, JU1:J2) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: il, ij + +! ---------------- +! Begin execution. +! ---------------- + +!------------------------------------------------------------------------------ +! Prior to 12/4/08: +! We need to add an outer IK loop for OpenMP parallelization. +! Preserve original code here! (bmy, 12/4/08) +! ------------------------- +! Calculate N-S divergence. +!! ------------------------- +! +! do ij = j1p, j2p +! +! dpi(:,ij,:) = & +! (ymass(:,ij,:) - ymass(:,ij+1,:)) * & +! geofac(ij) +! +! end do +! +! +!! ------------------------- +!! Calculate E-W divergence. +!! ------------------------- +! +! do ij = j1p, j2p +! do il = i1, i2-1 +! +! dpi(il,ij,:) = & +! dpi(il,ij,:) + & +! xmass(il,ij,:) - xmass(il+1,ij,:) +! +! end do +! dpi(i2,ij,:) = & +! dpi(i2,ij,:) + & +! xmass(i2,ij,:) - xmass(1,ij,:) +! end do +! IK loop was moved outside the subroutine (ccc, 4/1/09) +!------------------------------------------------------------------------------ + +! ------------------------- +! Calculate N-S divergence. +! ------------------------- + + do ij = j1p, j2p + + dpi(:,ij) = & + (ymass(:,ij) - ymass(:,ij+1)) * & + geofac(ij) + +! ------------------------- +! Calculate E-W divergence. +! ------------------------- + + do il = i1, i2-1 + + dpi(il,ij) = & + dpi(il,ij) + & + xmass(il,ij) - xmass(il+1,ij) + + end do + + dpi(i2,ij) = & + dpi(i2,ij) + & + xmass(i2,ij) - xmass(1,ij) + end do + + +! =========================== + call Do_Divergence_Pole_Sum & +! =========================== + (do_reduction, geofac_pc, dpi, ymass, & + i1_gl, i2_gl, j1p, j2p, & + ju1_gl, j2_gl, ilo, ihi, julo, jhi, i1, i2, ju1, j2) + + + if (j1p /= ju1_gl+1) then + +! -------------------------------------------- +! Polar cap enlarged: copy dpi to polar ring. +! -------------------------------------------- + + !-------------------------------------------------------------- + ! Prior to 12/4/08: + ! We need to add an outer IK loop for OpenMP parallelization + ! Preserve original code here! (bmy, 12/4/08) + !dpi(:,ju1+1,:) = dpi(:,ju1,:) + !dpi(:,j2-1,:) = dpi(:,j2,:) + ! IK loop was moved outside the subroutine (ccc, 4/1/09) + !-------------------------------------------------------------- + + dpi(:,ju1+1) = dpi(:,ju1) + dpi(:,j2-1) = dpi(:,j2) + end if + + + END SUBROUTINE Calc_Divergence +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Divergence_Pole_Sum +! +! !DESCRIPTION: Subroutine Do\_Divergence\_Pole\_Sum sets the divergence +! at the Poles. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Divergence_Pole_Sum( do_reduction, geofac_pc, dpi, ymass, & + I1_GL, I2_GL, J1P, J2P, & + JU1_GL, J2_GL, ILO, IHI, & + JULO, JHI, I1, I2, & + JU1, J2) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Set to T if called on Master or F if called by slaves + ! NOTE: This seems not to be used here....) + LOGICAL, INTENT(IN) :: do_reduction + + ! Special geometrical factor (geofac) for Polar cap + REAL*8, INTENT(in) :: geofac_pc + + ! Horizontal mass flux in N-S direction [hPa] + REAL*8, INTENT(IN) :: ymass(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Divergence at a grid point; used to calculate vertical motion [hPa] + REAL*8, INTENT(OUT) :: dpi(I1:I2, JU1:J2) + +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: il + REAL*8 :: ri2 + REAL*8 :: mean_np + REAL*8 :: mean_sp + REAL*8 :: sumnp + REAL*8 :: sumsp + + +! ---------------- +! Begin execution. +! ---------------- + + ri2 = i2_gl + + +! ================== + if (ju1 == ju1_gl) then +! ================== + + sumsp = 0.0d0 + + do il = i1, i2 + + sumsp = sumsp + ymass(il,j1p) + + end do + + mean_sp = -sumsp / ri2 * geofac_pc + + do il = i1, i2 + + dpi(il,ju1) = mean_sp + + end do + +! ====== + end if +! ====== + + +! ================ + if (j2 == j2_gl) then +! ================ + + sumnp = 0.0d0 + + do il = i1, i2 + + sumnp = sumnp + ymass(il,j2p+1) + + end do + + mean_np = sumnp / ri2 * geofac_pc + + do il = i1, i2 + + dpi(il,j2) = mean_np + + end do + +! ====== + end if +! ====== + + END SUBROUTINE Do_Divergence_Pole_Sum +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Cross_Terms_Pole_I2d2 +! +! !DESCRIPTION: Subroutine Do\_Cross\_Terms\_Pole\_I2d2 sets "va" at the Poles. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Cross_Terms_Pole_I2d2( cry, va, I1_GL, I2_GL, JU1_GL, & + J2_GL, J1P, ILO, IHI, JULO, & + JHI, I1, I2, JU1, J2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edge of the South polar cap + ! J1P=JU1_GL+1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Courant number in N-S direction + REAL*8, INTENT(IN) :: cry(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Average of Courant numbers from ij and ij+1 + REAL*8, INTENT(OUT) :: va(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: i2d2 + INTEGER :: il + +! ---------------- +! Begin execution. +! ---------------- + + i2d2 = i2_gl / 2 + + +! ==================== + if (j1p == ju1_gl+1) then +! ==================== + +!------------------------------------------------------------------------------ +! Prior to 12/4/08: +! We need to add outer IK loops OpenMP parallelization. +! Preserve original code here! (bmy, 12/4/08) +!! --------------------------------------------- +!! Polar Cap NOT Enlarged: +!! Get cross terms for N-S horizontal advection. +!! --------------------------------------------- +! +!! ================== +! if (ju1 == ju1_gl) then +!! ================== +! +! do il = i1, i2d2 +! +! va(il,ju1,:) = & +! 0.5d0 * (cry(il,ju1+1,:) - cry(il+i2d2,ju1+1,:)) +! +! va(il+i2d2,ju1,:) = -va(il,ju1,:) +! +! end do +! +!! ====== +! end if +!! ====== +! +! +!! ================ +! if (j2 == j2_gl) then +!! ================ +! +! do il = i1, i2d2 +! +! va(il,j2,:) = & +! 0.5d0 * (cry(il,j2,:) - cry(il+i2d2,j2-1,:)) +! +! va(il+i2d2,j2,:) = -va(il,j2,:) +! +! end do +! +!! ====== +! end if +!! ====== +! +!! ====== +! end if +!! ====== +! The IK loop was moved outside the subroutine (ccc, 4/1/09) +!------------------------------------------------------------------------------ + +! --------------------------------------------- +! Polar Cap NOT Enlarged: +! Get cross terms for N-S horizontal advection. +! --------------------------------------------- + +! ================== + if (ju1 == ju1_gl) then +! ================== + + do il = i1, i2d2 + + va(il,ju1) = & + 0.5d0 * (cry(il,ju1+1) - cry(il+i2d2,ju1+1)) + + va(il+i2d2,ju1) = -va(il,ju1) + + end do + +! ====== + end if +! ====== + + +! ================ + if (j2 == j2_gl) then +! ================ + + do il = i1, i2d2 + + va(il,j2) = & + 0.5d0 * (cry(il,j2) - cry(il+i2d2,j2-1)) + + va(il+i2d2,j2) = -va(il,j2) + + end do + +! ====== + end if +! ====== + +! ====== + end if +! ====== + + + END SUBROUTINE Do_Cross_Terms_Pole_I2d2 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Xadv_Dao2 +! +! !DESCRIPTION: Subroutine Xadv\_Dao2 is the advective form E-W operator for +! computing the adx (E-W) cross term. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Xadv_Dao2( iad, jn, js, adx, qqv, & + ua, ILO, IHI, JULO, JHI, & + JU1_GL, J2_GL, J1P, J2P, I1, & + I2, JU1, J2) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max latitude (J) indices + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! if iad = 1, use 1st order accurate scheme; + ! if iad = 2, use 2nd order accurate scheme + INTEGER, INTENT(IN) :: iad + + ! Northward of latitude index = jn, Courant numbers could be > 1, + ! so use the flux-form semi-Lagrangian scheme + INTEGER, INTENT(IN) :: jn + + ! southward of latitude index = js, Courant numbers could be > 1, + ! so use the flux-form semi-Lagrangian scheme + INTEGER, INTENT(IN) :: js + + ! Concentration contribution from N-S advection [mixing ratio] + REAL*8, INTENT(IN) :: qqv(ILO:IHI, JULO:JHI) + + ! Average of Courant numbers from il and il+1 + REAL*8, INTENT(IN) :: ua(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Cross term due to E-W advection [mixing ratio] + REAL*8, INTENT(OUT) :: adx(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: il, ij, iu + INTEGER :: imp, iue, iuw + REAL*8 :: a1, b1, c1 + REAL*8 :: rdiff + REAL*8 :: ril, riu + real*8 :: ru + + ! Arrays + REAL*8 :: qtmp(-i2/3:i2+i2/3, julo:jhi) + + ! ---------------- + ! Begin execution. + ! ---------------- + + ! Zero output array + adx = 0d0 + + !----------------------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to add outer IJ and IK loops for OpenMP parallelization. + ! Preserve original code here. (bmy, 12/5/08) + !do il=1,i2 + ! qtmp(il,:,:) = qqv(il,:,:) + !enddo + ! + !do il=-i2/3,0 + ! qtmp(il,:,:) = qqv(i2+il,:,:) + !enddo + ! + !do il=i2+1,i2+i2/3 + ! qtmp(il,:,:) = qqv(il-i2,:,:) + !enddo + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !----------------------------------------------------------------------- + + do ij = julo, jhi + + do il=1,i2 + qtmp(il,ij) = qqv(il,ij) + enddo + + do il=-i2/3,0 + qtmp(il,ij) = qqv(i2+il,ij) + enddo + + do il=i2+1,i2+i2/3 + qtmp(il,ij) = qqv(il-i2,ij) + enddo + enddo + +! ============= + if (iad == 1) then +! ============= + + ! ---------- + ! 1st order. + ! ---------- + + do ij = j1p, j2p + + + if ((ij <= js) .or. (ij >= jn)) then + + ! -------------- + ! In Polar area. + ! -------------- + + do il = i1, i2 + + iu = ua(il,ij) + riu = iu + ru = ua(il,ij) - riu + iu = il - iu + + if (ua(il,ij) >= 0.0d0) then + rdiff = qtmp(iu-1,ij) - qtmp(iu,ij) + else + rdiff = qtmp(iu,ij) - qtmp(iu+1,ij) + end if + + adx(il,ij) = (qtmp(iu,ij) - qtmp(il,ij)) + & + (ru * rdiff) + + end do + + else ! js < ij < jn + + ! ---------------- + ! Eulerian upwind. + ! ---------------- + + do il = i1, i2 + + ril = il + iu = ril - ua(il,ij) + + adx(il,ij) = ua(il,ij) * & + (qtmp(iu,ij) - qtmp(iu+1,ij)) + + end do + + end if + + end do + +! ================== + else if (iad == 2) then +! ================== + + + do ij = j1p, j2p + + + if ((ij <= js) .or. (ij >= jn)) then + + ! -------------- + ! In Polar area. + ! -------------- + + do il = i1, i2 + + iu = Nint (ua(il,ij)) + riu = iu + ru = riu - ua(il,ij) + iu = il - iu + + a1 = 0.5d0 * (qtmp(iu+1,ij) + qtmp(iu-1,ij)) - & + qtmp(iu,ij) + + b1 = 0.5d0 * (qtmp(iu+1,ij) - qtmp(iu-1,ij)) + + c1 = qtmp(iu,ij) - qtmp(il,ij) + + adx(il,ij) = (ru * ((a1 * ru) + b1)) + c1 + + end do + + else ! js < ij < jn + + ! ---------------- + ! Eulerian upwind. + ! ---------------- + + do il = i1, i2 + + iu = Nint (ua(il,ij)) + riu = iu + ru = riu - ua(il,ij) + iu = il - iu + + a1 = 0.5d0 * (qtmp(iu+1,ij) + qtmp(iu-1,ij)) - & + qtmp(iu,ij) + + b1 = 0.5d0 * (qtmp(iu+1,ij) - qtmp(iu-1,ij)) + + c1 = qtmp(iu,ij) - qtmp(il,ij) + + adx(il,ij) = (ru * ((a1 * ru) + b1)) + c1 + + end do + + end if + + end do +! ====== + end if +! ====== + + + if (ju1 == ju1_gl) then + + !--------------------------------------------------------------- + ! Prior to 12/4/08: + ! We need to rewrite the DO loop below for OpenMP. + ! Preserve original code here! (bmy, 12/4/08) + !adx(i1:i2,ju1,:) = 0.0d0 + ! + !if (j1p /= ju1_gl+1) then + ! + ! adx(i1:i2,ju1+1,:) = 0.0d0 + ! + !end if + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !--------------------------------------------------------------- + + adx(i1:i2,ju1) = 0.0d0 + + if (j1p /= ju1_gl+1) then + + adx(i1:i2,ju1+1) = 0.0d0 + + end if + + end if + + + if (j2 == j2_gl) then + + !--------------------------------------------------------------- + ! Prior to 12/4/08: + ! We need to rewrite the DO loop below for OpenMP. + ! Preserve original code here! (bmy, 12/4/08) + !adx(i1:i2,j2,:) = 0.0d0 + ! + !if (j1p /= ju1_gl+1) then + ! + ! adx(i1:i2,j2-1,:) = 0.0d0 + ! + !end if + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !--------------------------------------------------------------- + + adx(i1:i2,j2) = 0.0d0 + + if (j1p /= ju1_gl+1) then + + adx(i1:i2,j2-1) = 0.0d0 + + end if + + end if + + + END SUBROUTINE Xadv_Dao2 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Yadv_Dao2 +! +! !DESCRIPTION: Subroutine Yadv\_Dao2 is the advective form N-S operator +! for computing the ady (N-S) cross term. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Yadv_Dao2( iad, ady, qqu, va, I1_GL, & + I2_GL, JU1_GL, J2_GL, J1P, J2P, & + ILO, IHI, JULO, JHI, I1, & + I2, JU1, J2) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! If iad = 1, use 1st order accurate scheme; + ! If iad = 2, use 2nd order accurate scheme + INTEGER, INTENT(IN) :: iad + + ! Concentration contribution from E-W advection [mixing ratio] + REAL*8, INTENT(IN) :: qqu(ILO:IHI, JULO:JHI) + + ! Average of Courant numbers from ij and ij+1 + REAL*8, INTENT(IN) :: va(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Cross term due to N-S advection (mixing ratio) + REAL*8, INTENT(OUT) :: ady(ILO:IHI, JULO:JHI) + +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: il, ij + INTEGER :: jv + REAL*8 :: a1, b1, c1 + REAL*8 :: rij, rjv + REAL*8 :: rv + + ! Arrays + ! We may need a small ghost zone depending + ! on the polar cap used + REAL*8 :: qquwk(ilo:ihi, julo-2:jhi+2) + +! ---------------- +! Begin execution. +! ---------------- + + ! Zero output array + ady = 0d0 + + ! Make work array + do ij = julo, jhi + qquwk(:,ij) = qqu(:,ij) + end do + + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! This routine creates a ghost zone in latitude in case of + ! not enlarged polar cap + ! (ccc, 11/20/08) +! ====================== + call Do_Yadv_Pole_I2d2 & +! ====================== + (qqu, qquwk, & + i1_gl, i2_gl, ju1_gl, j2_gl, j1p, & + ilo, ihi, julo, jhi, i1, i2, ju1, j2) + + +! ============= + if (iad == 1) then +! ============= + + ! ---------- + ! 1st order. + ! ---------- + + do ij = j1p-1, j2p+1 + do il = i1, i2 +!c? + rij = ij + jv = rij - va(il,ij) + + ady(il,ij) = va(il,ij) * & + (qquwk(il,jv) - qquwk(il,jv+1)) + + end do + end do + + +! ================== + else if (iad == 2) then +! ================== + + do ij = j1p-1, j2p+1 + do il = i1, i2 +!c? + jv = Nint (va(il,ij)) + rjv = jv + rv = rjv - va(il,ij) + jv = ij - jv + + a1 = 0.5d0 * (qquwk(il,jv+1) + qquwk(il,jv-1)) - & + qquwk(il,jv) + + b1 = 0.5d0 * (qquwk(il,jv+1) - qquwk(il,jv-1)) + + c1 = qquwk(il,jv) - qquwk(il,ij) + + ady(il,ij) = (rv * ((a1 * rv) + b1)) + c1 + + end do + end do + + end if + + +! ===================== + call Do_Yadv_Pole_Sum & +! ===================== + ( ady, & + i1_gl, i2_gl, ju1_gl, j2_gl, j1p, & + ilo, ihi, julo, jhi, i1, i2, ju1, j2) + + + END SUBROUTINE Yadv_Dao2 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Yadv_Pole_I2d2 +! +! !DESCRIPTION: Subroutine Do\_Yadv\_Pole\_I2d2 sets "qquwk" at the Poles. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Yadv_Pole_I2d2 ( qqu, qquwk, I1_GL, I2_GL, JU1_GL, J2_GL, & + J1P, ILO, IHI, JULO, JHI, I1, & + I2, JU1, J2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the South polar cap + ! J1P=JU1_GL+1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! concentration contribution from E-W advection [mixing ratio] + REAL*8, INTENT(IN) :: qqu(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! qqu working array [mixing ratio] + REAL*8, INTENT(OUT) :: qquwk(ILO:IHI, JULO-2:JHI+2) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: i2d2 + INTEGER :: il, ij + INTEGER :: inb + + +! ---------------- +! Begin execution. +! ---------------- + + i2d2 = i2_gl / 2 + + +! ==================== + if (j1p == ju1_gl+1) then +! ==================== + +! ----------------------- +! Polar Cap NOT Enlarged. +! ----------------------- + +! ================== + if (ju1 == ju1_gl) then +! ================== + + !----------------------------------------------------------------- + ! Prior to 12/4/08: + ! We need to add an outer IK loop for OpenMP parallelization + ! Preserve original code here (bmy, 12/4/08) + !do il = i1, i2d2 + ! do inb = 1, 2 + ! + ! qquwk(il, ju1-inb,:) = qqu(il+i2d2,ju1+inb,:) + ! qquwk(il+i2d2,ju1-inb,:) = qqu(il, ju1+inb,:) + ! + ! end do + !end do + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !----------------------------------------------------------------- + + do il = i1, i2d2 + do inb = 1, 2 + + qquwk(il, ju1-inb) = qqu(il+i2d2,ju1+inb) + qquwk(il+i2d2,ju1-inb) = qqu(il, ju1+inb) + + end do + end do + + +! ====== + end if +! ====== + + +! ================ + if (j2 == j2_gl) then +! ================ + + !----------------------------------------------------------------- + ! Prior to 12/4/08: + ! We need to add an outer IK loop for OpenMP parallelization + ! Preserve original code here (bmy, 12/4/08) + !do il = i1, i2d2 + ! do inb = 1, 2 + ! + ! qquwk(il, j2+inb,:) = qqu(il+i2d2,j2-inb,:) + ! qquwk(il+i2d2,j2+inb,:) = qqu(il, j2-inb,:) + ! + ! end do + !end do + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !----------------------------------------------------------------- + + do il = i1, i2d2 + do inb = 1, 2 + + qquwk(il, j2+inb) = qqu(il+i2d2,j2-inb) + qquwk(il+i2d2,j2+inb) = qqu(il, j2-inb) + + end do + end do + + +! ====== + end if +! ====== + +! ====== + end if +! ====== + + + END SUBROUTINE Do_Yadv_Pole_I2d2 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Yadv_Pole_Sum +! +! !DESCRIPTION: Subroutine Do\_Yadv\_Pole\_Sum sets the cross term due to +! N-S advection at the Poles. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Yadv_Pole_Sum( ady, I1_GL, I2_GL, JU1_GL, J2_GL, J1P, & + ILO, IHI, JULO, JHI, I1, I2, & + JU1, J2) +! +! !INPUT PARAMETERS: +! + ! Global latitude index at the edge of the South polar cap + ! J1P=JU1_GL+1; for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI +! +! !OUTPUT PARAMETERS: +! + ! Cross term due to N-S advection (mixing ratio) + REAL*8, INTENT(INOUT) :: ady(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. Also make a logical +! to test if we are using an extended polar cap. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + + ! Scalars + INTEGER :: il + + ! Arrays + REAL*8 :: sumnp + REAL*8 :: sumsp + + ! Add + LOGICAL :: IS_EXT_POLAR_CAP + + + ! ---------------- + ! Begin execution. + ! ---------------- + + ! Test if we are using extended polar caps (i.e. the S pole and next N + ! latitude and N. Pole and next S latitude). Do this outside the loops. + ! (bmy, 12/11/08) + IS_EXT_POLAR_CAP = ( J1P == JU1_GL + 2 ) + + ! ------------ + ! South Pole + ! ------------ + + sumsp = 0.0d0 + sumnp = 0.0d0 + + !------------------------------ + ! Prior to 12/11/08: + !if (j1p /= ju1_gl+1) then + !------------------------------ + if ( IS_EXT_POLAR_CAP ) then + + ! For a 2-latitude polar cap (S. Pole + next Northward latitude) + do il = i1, i2 + + sumsp = sumsp + ady(il,ju1+1) + sumnp = sumnp + ady(il,j2-1) + + end do + + else + + ! For a 1-latitude polar cap (S. Pole only) + do il = i1, i2 + + sumsp = sumsp + ady(il,ju1) + sumnp = sumnp + ady(il,j2) + + end do + + end if + + sumsp = sumsp / i2_gl + sumnp = sumnp / i2_gl + + !------------------------------ + ! Prior to 12/11/08: + !if (j1p /= ju1_gl+1) then + !------------------------------ + if ( IS_EXT_POLAR_CAP ) then + + ! For a 2-latitude polar cap (S. Pole + next Northward latitude) + do il = i1, i2 + + ady(il,ju1+1) = sumsp + ady(il,ju1) = sumsp + ady(il,j2-1) = sumnp + ady(il,j2) = sumnp + + end do + + else + + ! For a 1-latitude polar cap (S. Pole only) + do il = i1, i2 + + ady(il,ju1) = sumsp + ady(il,j2) = sumnp + + end do + + end if + + END SUBROUTINE Do_Yadv_Pole_Sum +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Xtp +! +! !DESCRIPTION: Subroutine Xtp does horizontal advection in the E-W direction. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Xtp( ilmt, jn, js, pu, crx, dq1, qqv, xmass, fx, & + J1P, J2P, I2_GL, JU1_GL, J2_GL, ILO, IHI, JULO, JHI, & + I1, I2, JU1, J2, iord ) + +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Controls various options in E-W advection + INTEGER, INTENT(IN) :: ilmt + + ! Northward of latitude index = jn, Courant numbers could be > 1, + ! so use the flux-form semi-Lagrangian scheme + INTEGER, INTENT(IN) :: jn + + ! Southward of latitude index = js, Courant numbers could be > 1, + ! so use the flux-form semi-Lagrangian scheme + INTEGER, INTENT(IN) :: js + + ! Option for E-W transport scheme. See module header for more info. + INTEGER, INTENT(IN) :: iord + + ! pressure at edges in "u" [hPa] + REAL*8, INTENT(IN) :: pu(ILO:IHI, JULO:JHI) + + ! Courant number in E-W direction + REAL*8, INTENT(IN) :: crx(ILO:IHI, JULO:JHI) + + ! Horizontal mass flux in E-W direction [hPa] + REAL*8, INTENT(IN) :: xmass(ILO:IHI, JULO:JHI) +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Species density [hPa] + REAL*8, INTENT(INOUT) :: dq1(ILO:IHI, JULO:JHI) + + ! Concentration contribution from N-S advection [mixing ratio] + REAL*8, INTENT(INOUT) :: qqv(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! E-W flux [mixing ratio] + REAL*8, INTENT(OUT) :: fx(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: il, ij, ic + INTEGER :: iu, ix, iuw, iue, imp + INTEGER :: jvan + REAL*8 :: rc + REAL*8 :: ric, ril + + ! Arrays + INTEGER :: isav(i1:i2) + REAL*8 :: dcx(-i2/3:i2+i2/3, julo:jhi) + REAL*8 :: qtmp(-i2/3:i2+i2/3, julo:jhi) + + + ! ---------------- + ! Begin execution. + ! ---------------- + + dcx(:,:) = 0.0d0 + fx(:,:) = 0.0d0 + + imp = i2+1 + + ! NOTE: these loops do not parallelize well (bmy, 12/5/08) + + ! Populate qtmp + do il=i1,i2 + qtmp(il,:) = qqv(il,:) + enddo + + do il = -i2/3,0 + qtmp(il,:) = qqv(i2+il,:) + enddo + + do il = i2+1,i2+i2/3 + qtmp(il,:) = qqv(il-i2,:) + enddo + + if (IORD /= 1) then + qtmp(i1-1,:) = qqv(i2,:) + qtmp(i1-2,:) = qqv(i2-1,:) + qtmp(i2+1,:) = qqv(i1,:) + qtmp(i2+2,:) = qqv(i1+1,:) + +! ========== + call Xmist & +! ========== + (dcx, qtmp, & + j1p, j2p, i2_gl, ju1_gl, j2_gl, ilo, ihi, julo, jhi, & + i1, i2, ju1, j2) + end if + + + jvan = Max (1, j2_gl / 18) + + +! ============== + do ij = j1p, j2p +! ================= + +! ====================================== + if ((ij > js) .and. (ij < jn)) then +! ====================================== + +! ------------------------------------------------------ +! Do horizontal Eulerian advection in the E-W direction. +! ------------------------------------------------------ + + if ((IORD == 1) .or. & + (ij == j1p) .or. (ij == j2p)) then + + do il = i1, i2 + ril = il + iu = ril - crx(il,ij) + + fx(il,ij) = qtmp(iu,ij) + end do + + else + + if ((IORD == 2) .or. & + (ij <= (j1p+jvan)) .or. (ij >= (j2p-jvan))) then + + do il = i1, i2 + ril = il + iu = ril - crx(il,ij) + + fx(il,ij) = & + qtmp(iu,ij) + & + (dcx(iu,ij) * & + (Sign (1.0d0, crx(il,ij)) - crx(il,ij))) + end do + + else + +! ========== + call Fxppm & + (ij, ilmt, crx, dcx, fx, qtmp, & + -i2/3, i2+i2/3, julo, jhi, i1, i2) +! qtmp (inout) - can be updated +! ========== + + end if + + end if + + !--------------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to write this as an explicit loop over IL + ! to facilitate OpenMP parallelization. Preserve original + ! code here. (bmy, 12/5/08) + !fx(i1:i2,ij,ik) = fx(i1:i2,ij,ik) * xmass(i1:i2,ij,ik) + !--------------------------------------------------------------- + do il = i1, i2 + fx(il,ij) = fx(il,ij) * xmass(il,ij) + enddo + +! ==== + else +! ==== + +! ------------------------------------------------------------ +! Do horizontal Conservative (flux-form) Semi-Lagrangian +! advection in the E-W direction (van Leer at high latitudes). +! ------------------------------------------------------------ + + if ((IORD == 1) .or. & + (ij == j1p) .or. (ij == j2p)) then + + do il = i1, i2 + ic = crx(il,ij) + isav(il) = il - ic + ril = il + iu = ril - crx(il,ij) + ric = ic + rc = crx(il,ij) - ric + + fx(il,ij) = rc * qtmp(iu,ij) + end do + + else + + do il = i1, i2 + ic = crx(il,ij) + isav(il) = il - ic + ril = il + iu = ril - crx(il,ij) + ric = ic + rc = crx(il,ij) - ric + + fx(il,ij) = & + rc * & + (qtmp(iu,ij) + & + (dcx(iu,ij) * (Sign (1.0d0, rc) - rc))) + end do + + end if + + do il = i1, i2 + + if (crx(il,ij) > 1.0d0) then + + do ix = isav(il), il - 1 + fx(il,ij) = fx(il,ij) + qtmp(ix,ij) + end do + + else if (crx(il,ij) < -1.0d0) then + + do ix = il, isav(il) - 1 + fx(il,ij) = fx(il,ij) - qtmp(ix,ij) + end do + + end if + + end do + + !--------------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to write this as an explicit loop over IL + ! to facilitate OpenMP parallelization. Preserve original + ! code here. (bmy, 12/5/08) + !fx(i1:i2,ij,ik) = pu(i1:i2,ij,ik) * fx(i1:i2,ij,ik) + !--------------------------------------------------------------- + do il = i1, i2 + fx(il,ij) = pu(il,ij) * fx(il,ij) + enddo + +! ====== + end if +! ====== + +! ====== + end do +! ====== + + ! NOTE: This loop does not parallelize well (bmy, 12/5/08) + do ij = j1p, j2p + do il = i1, i2-1 + + dq1(il,ij) = dq1(il,ij) + & + (fx(il,ij) - fx(il+1,ij)) + + end do + dq1(i2,ij) = dq1(i2,ij) + & + (fx(i2,ij) - fx(i1,ij)) + end do + + END SUBROUTINE Xtp +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Xmist +! +! !DESCRIPTION: Subroutine Xmist computes the linear tracer slope in the +! E-W direction. It uses the Lin et. al. 1994 algorithm. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Xmist( dcx, qqv, J1P, J2P, I2_GL, JU1_GL, J2_GL, ILO, IHI, & + JULO, JHI, I1, I2, JU1, J2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Concentration contribution from N-S advection [mixing ratio] + REAL*8, INTENT(IN) :: qqv(-I2/3:I2+I2/3, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Slope of concentration distribution in E-W direction [mixing ratio] + REAL*8, INTENT(OUT) :: dcx(-I2/3:I2+I2/3, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: il, ij + REAL*8 :: pmax, pmin + REAL*8 :: r24 + REAL*8 :: tmp + + +! ---------------- +! Begin execution. +! ---------------- + + r24 = 1.0d0 / 24.0d0 + + do ij = j1p+1, j2p-1 + do il = i1, i2 + + tmp = & + ((8.0d0 * (qqv(il+1,ij) - qqv(il-1,ij))) + & + qqv(il-2,ij) - qqv(il+2,ij)) * & + r24 + + pmax = & + Max (qqv(il-1,ij), qqv(il,ij), qqv(il+1,ij)) - & + qqv(il,ij) + + pmin = & + qqv(il,ij) - & + Min (qqv(il-1,ij), qqv(il,ij), qqv(il+1,ij)) + + dcx(il,ij) = Sign (Min (Abs (tmp), pmax, pmin), tmp) + + end do + end do + + !-------------------------------------------------------------------- + ! Prior to 12/4/08: + ! We need to add outer IK and IJ loops for OpenMP parallelization. + ! Preserve original code here (bmy, 12/4/08) + !! Populate ghost zones of dcx (ccc, 11/20/08) + !do il = -i2/3, 0 + ! dcx(il,:,:) = dcx(i2+il,:,:) + !enddo + ! + !do il = i2+1, i2+i2/3 + ! dcx(il,:,:) = dcx(il-i2,:,:) + !enddo + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !-------------------------------------------------------------------- + + ! Populate ghost zones of dcx (ccc, 11/20/08) + + do ij = julo, jhi + + do il = -i2/3, 0 + dcx(il,ij) = dcx(i2+il,ij) + enddo + + do il = i2+1, i2+i2/3 + dcx(il,ij) = dcx(il-i2,ij) + + enddo + enddo + + END SUBROUTINE Xmist +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Fxppm +! +! !DESCRIPTION: Subroutine Fxppm is the 1D "outer" flux form operator based +! on the Piecewise Parabolic Method (PPM; see also Lin and Rood 1996) for +! computing the fluxes in the E-W direction. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Fxppm( ij, ilmt, crx, dcx, fx, qqv, & + ILO, IHI, JULO, JHI, I1, I2 ) +! +! !INPUT PARAMETERS: +! + ! Local min & max longitude (I) and altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Latitude (IJ) and altitude (IK) indices + INTEGER, INTENT(IN) :: ij + + ! Controls various options in E-W advection + INTEGER, INTENT(IN) :: ilmt + + ! Courant number in E-W direction + REAL*8, INTENT(IN) :: crx(I1:I2, JULO:JHI) +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Concentration contribution from N-S advection [mixing ratio] + REAL*8, INTENT(INOUT) :: qqv(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Slope of concentration distribution in E-W direction (mixing ratio) + REAL*8, INTENT(OUT) :: dcx(ILO:IHI, JULO:JHI) + + ! E-W flux [mixing ratio] + REAL*8, INTENT(OUT) :: fx(I1:I2, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REMARKS: +! This routine is called from w/in a OpenMP parallel loop fro + +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +! Also remove the allocatable arrays, which +! interfere w/ OpenMP parallelization. +! 01 Apr 2009 - C. Carouge - The input arrays are now 2D only. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + !------------------------------------------------------------------------- + ! Prior to 12/5/08: + ! Remove this (explanation below). + !LOGICAL, SAVE :: first = .true. + !------------------------------------------------------------------------- + + INTEGER :: il + INTEGER :: ilm1 + INTEGER :: lenx + REAL*8 :: r13, r23 + REAL*8 :: rval + + !------------------------------------------------------------------------ + ! Prior to 12/5/08: + ! NOTE: It is a bad idea to make these arrays allocatable. The way this + ! was implemented, it tried to create these arrays once for each thread. + ! This led to a segmentation fault. Better to just define these arrays + ! with the appropriate dimensions. Also note, we don't really need to + ! use SAVE since these arrays are being reset to zero on each call + ! to Fxppm. (bmy, 12/5/08) + ! + !! Arrays + !REAL*8, ALLOCATABLE, SAVE :: a6(:) + !REAL*8, ALLOCATABLE, SAVE :: al(:) + !REAL*8, ALLOCATABLE, SAVE :: ar(:) + !REAL*8, ALLOCATABLE, SAVE :: a61(:) + !REAL*8, ALLOCATABLE, SAVE :: al1(:) + !REAL*8, ALLOCATABLE, SAVE :: ar1(:) + !REAL*8, ALLOCATABLE, SAVE :: dcxi1(:) + !REAL*8, ALLOCATABLE, SAVE :: qqvi1(:) + !------------------------------------------------------------------------ + + ! Arrays + REAL*8 :: a6( ILO:IHI ) + REAL*8 :: al( ILO:IHI ) + REAL*8 :: ar( ILO:IHI ) + REAL*8 :: a61( (IHI-1) - (ILO+1) + 1 ) + REAL*8 :: al1( (IHI-1) - (ILO+1) + 1 ) + REAL*8 :: ar1( (IHI-1) - (ILO+1) + 1 ) + REAL*8 :: dcxi1( (IHI-1) - (ILO+1) + 1 ) + REAL*8 :: qqvi1( (IHI-1) - (ILO+1) + 1 ) + + ! ---------------- + ! Begin execution. + ! ---------------- + +!------------------------------------------------------------------------------ +! Prior to 12/5/08: +! Remove the ALLOCATE command, since we are now declaring these as regular +! subroutine arrays and not making them allocatable. (bmy, 12/5/08) +!! ========== +! if (first) then +!! ========== +! +! first = .false. +! +! Allocate (a6(ilo:ihi)) +! Allocate (al(ilo:ihi)) +! Allocate (ar(ilo:ihi)) +! a6 = 0.0d0; al = 0.0d0; ar = 0.0d0 +! +! Allocate (a61((ihi-1)-(ilo+1)+1)) +! Allocate (al1((ihi-1)-(ilo+1)+1)) +! Allocate (ar1((ihi-1)-(ilo+1)+1)) +! a61 = 0.0d0; al1 = 0.0d0; ar1 = 0.0d0 +! +! Allocate (dcxi1((ihi-1)-(ilo+1)+1)) +! Allocate (qqvi1((ihi-1)-(ilo+1)+1)) +! dcxi1 = 0.0d0; qqvi1 = 0.0d0 +! +! end if +!------------------------------------------------------------------------------ + + ! Zero arrays (bmy, 12/5/08) + a6 = 0.0d0 + al = 0.0d0 + ar = 0.0d0 + a61 = 0.0d0 + al1 = 0.0d0 + ar1 = 0.0d0 + dcxi1 = 0.0d0 + qqvi1 = 0.0d0 + + r13 = 1.0d0 / 3.0d0 + r23 = 2.0d0 / 3.0d0 + + + do il = ilo + 1, ihi + + rval = 0.5d0 * (qqv(il-1,ij) + qqv(il,ij)) + & + (dcx(il-1,ij) - dcx(il,ij)) * r13 + + al(il) = rval + ar(il-1) = rval + + end do + + + do il = ilo + 1, ihi - 1 + a6(il) = 3.0d0 * & + (qqv(il,ij) + qqv(il,ij) - (al(il) + ar(il))) + end do + + +! ============== + if (ilmt <= 2) then +! ============== + + a61(:) = 0.0d0 + al1(:) = 0.0d0 + ar1(:) = 0.0d0 + + dcxi1(:) = 0.0d0 + qqvi1(:) = 0.0d0 + + lenx = 0 + + do il = ilo + 1, ihi - 1 + + lenx = lenx + 1 + + a61(lenx) = a6(il) + al1(lenx) = al(il) + ar1(lenx) = ar(il) + + dcxi1(lenx) = dcx(il,ij) + qqvi1(lenx) = qqv(il,ij) + + end do + +! =========== + call Lmtppm & + (lenx, ilmt, a61, al1, ar1, dcxi1, qqvi1) +! =========== + + lenx = 0 + + do il = ilo + 1, ihi - 1 + + lenx = lenx + 1 + + a6(il) = a61(lenx) + al(il) = al1(lenx) + ar(il) = ar1(lenx) + + dcx(il,ij) = dcxi1(lenx) + qqv(il,ij) = qqvi1(lenx) + + end do + + ! Populate ghost zones of qqv and dcx with new values (ccc, 11/20/08) + do il = -i2/3,0 + dcx(il,ij) = dcx(i2+il,ij) + qqv(il,ij) = qqv(i2+il,ij) + enddo + + do il = i2+1, i2+i2/3 + dcx(il,ij) = dcx(il-i2,ij) + qqv(il,ij) = qqv(il-i2,ij) + enddo + + end if + + + do il = i1+1, i2 + + if (crx(il,ij) > 0.0d0) then + + ilm1 = il - 1 + + fx(il,ij) = & + ar(ilm1) + & + 0.5d0 * crx(il,ij) * & + (al(ilm1) - ar(ilm1) + & + (a6(ilm1) * (1.0d0 - (r23 * crx(il,ij))))) + + else + + fx(il,ij) = & + al(il) - & + 0.5d0 * crx(il,ij) * & + (ar(il) - al(il) + & + (a6(il) * (1.0d0 + (r23 * crx(il,ij))))) + + end if + + end do + + ! First box case (ccc, 11/20/08) + if (crx(i1,ij) > 0.0d0) then + + ilm1 = i2 + + fx(i1,ij) = & + ar(ilm1) + & + 0.5d0 * crx(i1,ij) * & + (al(ilm1) - ar(ilm1) + & + (a6(ilm1) * (1.0d0 - (r23 * crx(i1,ij))))) + + else + + fx(i1,ij) = & + al(i1) - & + 0.5d0 * crx(i1,ij) * & + (ar(i1) - al(i1) + & + (a6(i1) * (1.0d0 + (r23 * crx(i1,ij))))) + + end if + + + + END SUBROUTINE Fxppm +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Lmtppm +! +! !DESCRIPTION: Subroutine Lmtppm enforces the full monotonic, semi-monotonic, +! or the positive-definite constraint to the sub-grid parabolic distribution +! of the Piecewise Parabolic Method (PPM). +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Lmtppm( lenx, lmt, a6, al, ar, dc, qa ) +! +! !INPUT PARAMETERS: + + ! If 0 => full monotonicity; + ! If 1 => semi-monotonic constraint (no undershoots); + ! If 2 => positive-definite constraint + INTEGER, INTENT(IN) :: lmt + + ! Vector length + INTEGER, INTENT(IN) :: lenx +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Curvature of the test parabola + REAL*8, INTENT(INOUT) :: a6(lenx) + + ! Left edge value of the test parabola + REAL*8, INTENT(INOUT) :: al(lenx) + + ! Right edge value of the test parabola + REAL*8, INTENT(INOUT) :: ar(lenx) + + ! 0.5 * mismatch + REAL*8, INTENT(INOUT) :: dc(lenx) + + ! Cell-averaged value + REAL*8, INTENT(INOUT) :: qa(lenx) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: il + REAL*8 :: a6da + REAL*8 :: da1, da2 + REAL*8 :: fmin, ftmp + REAL*8 :: r12 + + +! ---------------- +! Begin execution. +! ---------------- + + r12 = 1.0d0 / 12.0d0 + + +! ============= + if (lmt == 0) then +! ============= + +! ---------------- +! Full constraint. +! ---------------- + + do il = 1, lenx + + if (dc(il) == 0.0d0) then + + a6(il) = 0.0d0 + al(il) = qa(il) + ar(il) = qa(il) + + else + + da1 = ar(il) - al(il) + da2 = da1 * da1 + a6da = a6(il) * da1 + + if (a6da < -da2) then + + a6(il) = 3.0d0 * (al(il) - qa(il)) + ar(il) = al(il) - a6(il) + + else if (a6da > da2) then + + a6(il) = 3.0d0 * (ar(il) - qa(il)) + al(il) = ar(il) - a6(il) + + end if + + end if + + end do + + +! ================== + else if (lmt == 1) then +! ================== + +! -------------------------- +! Semi-monotonic constraint. +! -------------------------- + + do il = 1, lenx + + if (Abs (ar(il) - al(il)) < -a6(il)) then + + if ((qa(il) < ar(il)) .and. (qa(il) < al(il))) then + + a6(il) = 0.0d0 + al(il) = qa(il) + ar(il) = qa(il) + + else if (ar(il) > al(il)) then + + a6(il) = 3.0d0 * (al(il) - qa(il)) + ar(il) = al(il) - a6(il) + + else + + a6(il) = 3.0d0 * (ar(il) - qa(il)) + al(il) = ar(il) - a6(il) + + end if + + end if + + end do + + +! ================== + else if (lmt == 2) then +! ================== + + do il = 1, lenx + + if (Abs (ar(il) - al(il)) < -a6(il)) then + + ftmp = ar(il) - al(il) + + fmin = qa(il) + & + 0.25d0 * (ftmp * ftmp) / a6(il) + & + a6(il) * r12 + + if (fmin < 0.0d0) then + + if ((qa(il) < ar(il)) .and. (qa(il) < al(il))) then + + a6(il) = 0.0d0 + al(il) = qa(il) + ar(il) = qa(il) + + else if (ar(il) > al(il)) then + + a6(il) = 3.0d0 * (al(il) - qa(il)) + ar(il) = al(il) - a6(il) + + else + + a6(il) = 3.0d0 * (ar(il) - qa(il)) + al(il) = ar(il) - a6(il) + + end if + + end if + + end if + + end do + + end if + + + END SUBROUTINE Lmtppm +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Ytp +! +! !DESCRIPTION: Subroutine Ytp does horizontal advection in the N-S direction. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Ytp( jlmt, geofac_pc, geofac, cry, dq1, qqu, qqv, & + ymass, fy, J1P, J2P, I1_GL, I2_GL, JU1_GL, & + J2_GL, ilong, ILO, IHI, JULO, JHI, I1, & + I2, JU1, J2, jord ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! ??? + INTEGER, INTENT(IN) :: ilong + + ! Controls various options in N-S advection + INTEGER, INTENT(IN) :: jlmt + + ! N-S transport scheme (see module header for more info) + INTEGER, INTENT(IN) :: jord + + ! special geometrical factor (geofac) for Polar cap + REAL*8, INTENT(IN) :: geofac_pc + + ! geometrical factor for meridional advection; geofac uses correct + ! spherical geometry, and replaces acosp as the meridional geometrical + ! factor in tpcore + REAL*8, INTENT(IN) :: geofac(JU1_GL:J2_GL) + + ! Courant number in N-S direction + REAL*8, INTENT(IN) :: cry(ILO:IHI, JULO:JHI) + + ! Concentration contribution from E-W advection [mixing ratio] + REAL*8, INTENT(IN) :: qqu(ILO:IHI, JULO:JHI) + + ! Horizontal mass flux in N-S direction [hPa] + REAL*8, INTENT(IN) :: ymass(ILO:IHI, JULO:JHI) +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Species density [hPa] + REAL*8, INTENT(INOUT) :: dq1(ILO:IHI, JULO:JHI) + + ! Concentration contribution from N-S advection [mixing ratio] + REAL*8, INTENT(INOUT) :: qqv(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! N-S flux [mixing ratio] + REAL*8, INTENT(OUT) :: fy(ILO:IHI, JULO:JHI+1) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: il, ij + INTEGER :: jv + REAL*8 :: rj1p + + ! Arrays + REAL*8 :: dcy(ilo:ihi, julo:jhi) + + +! ---------------- +! Begin execution. +! ---------------- + + dcy(:,:) = 0.0d0 + fy(:,:) = 0.0d0 + + rj1p = j1p + + +! ============== + if (JORD == 1) then +! ============== + + do ij = j1p, j2p+1 + do il = i1, i2 +!c? + jv = rj1p - cry(il,ij) + + qqv(il,ij) = qqu(il,jv) + + end do + end do + +! ==== + else +! ==== + +! ========== + call Ymist & +! ========== + (4, dcy, qqu, & + i1_gl, i2_gl, ju1_gl, j2_gl, j1p, & + ilo, ihi, julo, jhi, i1, i2, ju1, j2) + + + if ((JORD <= 0) .or. (JORD >= 3)) then + +! ========== + call Fyppm & +! ========== + (jlmt, cry, dcy, qqu, qqv, & + j1p, j2p, i1_gl, i2_gl, ju1_gl, j2_gl, ilong, & + ilo, ihi, julo, jhi, i1, i2, ju1, j2) + + else + + do ij = j1p, j2p+1 + do il = i1, i2 +!c? + jv = rj1p - cry(il,ij) + + qqv(il,ij) = & + qqu(il,jv) + & + ((Sign (1.0d0, cry(il,ij)) - cry(il,ij)) * & + dcy(il,jv)) + + end do + end do + end if + + end if + + !----------------------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to add an outer IK loop for OpenMP parallelization. + ! Preserve original code here (bmy, 12/5/08) + !do ij = j1p, j2p+1 + ! qqv(i1:i2,ij,:) = qqv(i1:i2,ij,:) * ymass(i1:i2,ij,:) + !end do + ! The IK loop is moved outside the subroutine (ccc, 4/1/09) + !----------------------------------------------------------------------- + + do ij = j1p, j2p+1 + qqv(i1:i2,ij) = qqv(i1:i2,ij) * ymass(i1:i2,ij) + end do + + !.sds.. save N-S species flux as diagnostic + do ij = i1,i2 + fy(ij,j1p:j2p+1) = qqv(ij,j1p:j2p+1) * geofac(j1p:j2p+1) + enddo + + !-------------------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to add an outer IK loop for OpenMP parallelization. + ! Preserve original code here (bmy, 12/5/08) + !!... meridional flux update + !do ij = j1p, j2p + ! + ! dq1(i1:i2,ij,:) = & + ! dq1(i1:i2,ij,:) + & + ! (qqv(i1:i2,ij,:) - qqv(i1:i2,ij+1,:)) * geofac(ij) + ! + !end do + ! The IK loop is moved outside the subroutine (ccc, 4/1/09) + !-------------------------------------------------------------------- + + !... meridional flux update + do ij = j1p, j2p + + dq1(i1:i2,ij) = & + dq1(i1:i2,ij) + & + (qqv(i1:i2,ij) - qqv(i1:i2,ij+1)) * geofac(ij) + + end do + +! ==================== + call Do_Ytp_Pole_Sum & +! ==================== + (geofac_pc, dq1, qqv, fy, & + i1_gl, i2_gl, ju1_gl, j2_gl, j1p, j2p, & + ilo, ihi, julo, jhi, i1, i2, ju1, j2) + + END SUBROUTINE Ytp +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Ymist +! +! !DESCRIPTION: Subroutine Ymist computes the linear tracer slope in the N-S +! direction. It uses the Lin et. al. 1994 algorithm. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Ymist( id, dcy, qqu, I1_GL, I2_GL, JU1_GL, & + J2_GL, J1P, ILO, IHI, JULO, JHI, & + I1, I2, JU1, J2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude index at the edge of the South polar cap + ! J1P=JU1_GL+1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! The "order" of the accuracy in the computed linear "slope" + ! (or mismatch, Lin et al. 1994); it is either 2 or 4. + INTEGER, INTENT(IN) :: id + + ! Concentration contribution from E-W advection (mixing ratio) + REAL*8, INTENT(IN) :: qqu(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Slope of concentration distribution in N-S direction [mixing ratio] + REAL*8, INTENT(OUT) :: dcy(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: il, ij + REAL*8 :: pmax, pmin + REAL*8 :: r24 + REAL*8 :: tmp + + ! Arrays + ! I suppose the values for these indexes are 0. + ! It should work as the pole values are re-calculated in the + ! pole functions. (ccc) + REAL*8 :: qtmp(ilo:ihi, julo-2:jhi+2) + +! ---------------- +! Begin execution. +! ---------------- + + r24 = 1.0d0 / 24.0d0 + + ! Populate qtmp + qtmp = 0. + do ij=ju1,j2 + qtmp(:,ij) = qqu(:,ij) + enddo + +! ============ + if (id == 2) then +! ============ + + do ij = ju1 - 1, j2 - 1 + do il = i1, i2 + + tmp = 0.25d0 * (qtmp(il,ij+2) - qtmp(il,ij)) + + pmax = & + Max (qtmp(il,ij), qtmp(il,ij+1), qtmp(il,ij+2)) - & + qtmp(il,ij+1) + + pmin = & + qtmp(il,ij+1) - & + Min (qtmp(il,ij), qtmp(il,ij+1), qtmp(il,ij+2)) + + dcy(il,ij+1) = Sign (Min (Abs (tmp), pmin, pmax), tmp) + + end do + end do + +! ==== + else +! ==== + +! ======================== + call Do_Ymist_Pole1_I2d2 & +! ======================== + (dcy, qtmp, & + i1_gl, i2_gl, ju1_gl, j2_gl, & + ilo, ihi, julo, jhi, i1, i2, ju1, j2) + + do ij = ju1 - 2, j2 - 2 + do il = i1, i2 + + tmp = ((8.0d0 * (qtmp(il,ij+3) - qtmp(il,ij+1))) + & + qtmp(il,ij) - qtmp(il,ij+4)) * & + r24 + + pmax = & + Max (qtmp(il,ij+1), qtmp(il,ij+2), qtmp(il,ij+3)) & + - qtmp(il,ij+2) + + pmin = & + qtmp(il,ij+2) - & + Min (qtmp(il,ij+1), qtmp(il,ij+2), qtmp(il,ij+3)) + + dcy(il,ij+2) = Sign (Min (Abs (tmp), pmin, pmax), tmp) + + end do + end do + + end if + + +! ======================== + call Do_Ymist_Pole2_I2d2 & +! ======================== + (dcy, qtmp, & + i1_gl, i2_gl, ju1_gl, j2_gl, j1p, & + ilo, ihi, julo, jhi, i1, i2, ju1, j2) + + + END SUBROUTINE Ymist +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Ymist_Pole1_I2d2 +! +! !DESCRIPTION: Subroutine Do\_Ymist\_Pole1\_I2d2 sets "dcy" at the Poles. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Ymist_Pole1_I2d2( dcy, qqu, I1_GL, I2_GL, JU1_GL, & + J2_GL, ILO, IHI, JULO, JHI, & + I1, I2, JU1, J2 ) +! +! !INPUT PARAMETERS: +! + ! Global min & max longitude (I) and latitude (J) indices + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Concentration contribution from E-W advection [mixing ratio] + REAL*8, INTENT(IN) :: qqu(ILO:IHI, JULO-2:JHI+2) +! +! !OUTPUT PARAMETERS: +! + ! Slope of concentration distribution in N-S direction [mixing ratio] + REAL*8, INTENT(OUT) :: dcy(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: i2d2 + INTEGER :: il + REAL*8 :: pmax, pmin + REAL*8 :: r24 + REAL*8 :: tmp + + +! ---------------- +! Begin execution. +! ---------------- + + i2d2 = i2_gl / 2 + + r24 = 1.0d0 / 24.0d0 + + +! ================== + if (ju1 == ju1_gl) then +! ================== + + do il = i1, i2d2 + + tmp = & + ((8.0d0 * (qqu(il,ju1+2) - qqu(il,ju1))) + & + qqu(il+i2d2,ju1+1) - qqu(il,ju1+3)) * & + r24 + + pmax = Max (qqu(il,ju1), qqu(il,ju1+1), & + qqu(il,ju1+2)) - & + qqu(il,ju1+1) + + pmin = qqu(il,ju1+1) - & + Min (qqu(il,ju1), qqu(il,ju1+1), & + qqu(il,ju1+2)) + + dcy(il,ju1+1) = & + Sign (Min (Abs (tmp), pmin, pmax), tmp) + + end do + + do il = i1 + i2d2, i2 + + tmp = & + ((8.0d0 * (qqu(il,ju1+2) - qqu(il,ju1))) + & + qqu(il-i2d2,ju1+1) - qqu(il,ju1+3)) * & + r24 + + pmax = Max (qqu(il,ju1), qqu(il,ju1+1), & + qqu(il,ju1+2)) - & + qqu(il,ju1+1) + + pmin = qqu(il,ju1+1) - & + Min (qqu(il,ju1), qqu(il,ju1+1), & + qqu(il,ju1+2)) + + dcy(il,ju1+1) = & + Sign (Min (Abs (tmp), pmin, pmax), tmp) + + end do + +! ====== + end if +! ====== + + +! ================ + if (j2 == j2_gl) then +! ================ + + do il = i1, i2d2 + + tmp = & + ((8.0d0 * (qqu(il,j2) - qqu(il,j2-2))) + & + qqu(il,j2-3) - qqu(il+i2d2,j2-1)) * & + r24 + + pmax = Max (qqu(il,j2-2), qqu(il,j2-1), & + qqu(il,j2)) - & + qqu(il,j2-1) + + pmin = qqu(il,j2-1) - & + Min (qqu(il,j2-2), qqu(il,j2-1), & + qqu(il,j2)) + + dcy(il,j2-1) = & + Sign (Min (Abs (tmp), pmin, pmax), tmp) + + end do + + do il = i1 + i2d2, i2 + + tmp = & + ((8.0d0 * (qqu(il,j2) - qqu(il,j2-2))) + & + qqu(il,j2-3) - qqu(il-i2d2,j2-1)) * & + r24 + + pmax = Max (qqu(il,j2-2), qqu(il,j2-1), & + qqu(il,j2)) - & + qqu(il,j2-1) + + pmin = qqu(il,j2-1) - & + Min (qqu(il,j2-2), qqu(il,j2-1), & + qqu(il,j2)) + + dcy(il,j2-1) = & + Sign (Min (Abs (tmp), pmin, pmax), tmp) + + end do + +! ====== + end if +! ====== + + + END SUBROUTINE Do_Ymist_Pole1_I2d2 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Ymist_Pole2_I2d2 +! +! !DESCRIPTION: Subroutine Do\_Ymist\_Pole2\_I2d2 sets "dcy" at the Poles. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Ymist_Pole2_I2d2( dcy, qqu, I1_GL, I2_GL, JU1_GL, & + J2_GL, J1P, ILO, IHI, JULO, & + JHI, I1, I2, JU1, J2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude index at the edge of the South polar cap + ! J1P=JU1_GL+1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Concentration contribution from E-W advection [mixing ratio] + REAL*8, INTENT(IN) :: qqu(ILO:IHI, JULO-2:JHI+2) +! +! !OUTPUT PARAMETERS: +! + ! Slope of concentration distribution in N-S direction [mixing ratio] + REAL*8, INTENT(OUT) :: dcy(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: i2d2 + INTEGER :: il + REAL*8 :: pmax, pmin + REAL*8 :: tmp + +! ---------------- +! Begin execution. +! ---------------- + + i2d2 = i2_gl / 2 + + +! ================== + if (ju1 == ju1_gl) then +! ================== + + if (j1p /= ju1_gl+1) then + + dcy(i1:i2,ju1) = 0.0d0 + + else + +! ----------------------------------------------- +! Determine slope in South Polar cap for scalars. +! ----------------------------------------------- + + do il = i1, i2d2 + + tmp = & + 0.25d0 * & + (qqu(il,ju1+1) - qqu(il+i2d2,ju1+1)) + + pmax = & + Max (qqu(il,ju1+1), qqu(il,ju1), & + qqu(il+i2d2,ju1+1)) - & + qqu(il,ju1) + + pmin = & + qqu(il,ju1) - & + Min (qqu(il,ju1+1), qqu(il,ju1), & + qqu(il+i2d2,ju1+1)) + + dcy(il,ju1) = & + Sign (Min (Abs (tmp), pmax, pmin), tmp) + + end do + + !---------------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to add and outer IK loop for OpenMP parallelization. + ! Preserve original code here (bmy, 12/5/08) + !do il = i1 + i2d2, i2 + ! dcy(il,ju1,:) = -dcy(il-i2d2,ju1,:) + !end do + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !---------------------------------------------------------------- + + do il = i1 + i2d2, i2 + dcy(il,ju1) = -dcy(il-i2d2,ju1) + end do + + end if + +! ====== + end if +! ====== + + +! ================ + if (j2 == j2_gl) then +! ================ + + if (j1p /= ju1_gl+1) then + + dcy(i1:i2,j2) = 0.0d0 + + else + +! ----------------------------------------------- +! Determine slope in North Polar cap for scalars. +! ----------------------------------------------- + + do il = i1, i2d2 + + tmp = & + 0.25d0 * & + (qqu(il+i2d2,j2-1) - qqu(il,j2-1)) + + pmax = & + Max (qqu(il+i2d2,j2-1), qqu(il,j2), & + qqu(il,j2-1)) - & + qqu(il,j2) + + pmin = & + qqu(il,j2) - & + Min (qqu(il+i2d2,j2-1), qqu(il,j2), & + qqu(il,j2-1)) + + dcy(il,j2) = & + Sign (Min (Abs (tmp), pmax, pmin), tmp) + + end do + + !---------------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to add and outer IK loop for OpenMP parallelization. + ! Preserve original code here (bmy, 12/5/08) + !do il = i1 + i2d2, i2 + ! dcy(il,j2,:) = -dcy(il-i2d2,j2,:) + !end do + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !---------------------------------------------------------------- + + do il = i1 + i2d2, i2 + dcy(il,j2) = -dcy(il-i2d2,j2) + end do + + end if + +! ====== + end if +! ====== + + + END SUBROUTINE Do_Ymist_Pole2_I2d2 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Fyppm +! +! !DESCRIPTION: Subroutine Fyppm is the 1D "outer" flux form operator based +! on the Piecewise Parabolic Method (PPM; see also Lin and Rood 1996) for +! computing the fluxes in the N-S direction. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Fyppm( jlmt, cry, dcy, qqu, qqv, j1p, j2p, & + i1_gl, i2_gl, ju1_gl, j2_gl, ilong, ilo, ihi, & + julo, jhi, i1, i2, ju1, j2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! ILONG ?? + INTEGER, INTENT(IN) :: ilong + + ! Controls various options in N-S advection + INTEGER, INTENT(IN) :: jlmt + + ! Courant number in N-S direction + REAL*8, INTENT(IN) :: cry(ILO:IHI, JULO:JHI) + + ! Slope of concentration distribution in N-S direction [mixing ratio] + REAL*8, INTENT(IN) :: dcy(ILO:IHI, JULO:JHI) + + ! Concentration contribution from E-W advection [mixing ratio] + REAL*8, INTENT(IN) :: qqu(ILO:IHI, JULO:JHI) +! +! !OUTPUT PARAMETERS: +! + ! Concentration contribution from N-S advection [mixing ratio] + REAL*8, INTENT(OUT) :: qqv(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: ijm1 + INTEGER :: il, ij + INTEGER :: lenx + REAL*8 :: r13, r23 + + ! Arrays + REAL*8 :: a61 (ilong*((JHI-1)-(JULO+1)+1)) + REAL*8 :: al1 (ilong*((JHI-1)-(JULO+1)+1)) + REAL*8 :: ar1 (ilong*((JHI-1)-(JULO+1)+1)) + REAL*8 :: dcy1(ilong*((JHI-1)-(JULO+1)+1)) + REAL*8 :: qqu1(ilong*((JHI-1)-(JULO+1)+1)) + REAL*8 :: a6(ILO:IHI, JULO:JHI) + REAL*8 :: al(ILO:IHI, JULO:JHI) + REAL*8 :: ar(ILO:IHI, JULO:JHI) + + ! NOTE: The code was writtein with I1:I2 as the first dimension of AL, + ! AR, A6, AL1, A61, AR1. However, the limits should really should be + ! ILO:IHI. In practice, however, for a global grid (and OpenMP + ! parallelization) ILO=I1 and IHI=I2. Nevertheless, we will change the + ! limits to ILO:IHI to be consistent and to avoid future problems. + ! (bmy, 12/5/08) + +! ---------------- +! Begin execution. +! ---------------- + + a6(:,:) = 0.0d0; al(:,:) = 0.0d0; ar(:,:) = 0.0d0 + + + r13 = 1.0d0 / 3.0d0 + r23 = 2.0d0 / 3.0d0 + + !----------------------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to add IK and IL loops for OpenMP parallelization. + ! Preserve original code here (bmy, 12/5/08) + !do ij = julo + 1, jhi + ! al(i1:i2,ij,:) = & + ! 0.5d0 * (qqu(i1:i2,ij-1,:) + qqu(i1:i2,ij,:)) + & + ! (dcy(i1:i2,ij-1,:) - dcy(i1:i2,ij,:)) * r13 + !end do + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !----------------------------------------------------------------------- + + do ij = julo+1, jhi + do il = ilo, ihi + al(il,ij) = & + 0.5d0 * (qqu(il,ij-1) + qqu(il,ij)) + & + (dcy(il,ij-1) - dcy(il,ij)) * r13 + ar(il,ij-1) = al(il,ij) + end do + end do + + !------------------------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to add IK and IL loops for OpenMP parallelization. + ! Preserve original code here (bmy, 12/5/08) + ! NOTE: This DO loop doesn't parallelize, so leave it alone (bmy, 12/5/08) + !do ij = julo, jhi - 1 + ! ar(i1:i2,ij,:) = al(i1:i2,ij+1,:) + !end do + !------------------------------------------------------------------------- + +! ======================= + call Do_Fyppm_Pole_I2d2 & +! ======================= + (al, ar, & + i1_gl, i2_gl, ju1_gl, j2_gl, & + ilo, ihi, julo, jhi, i1, i2, ju1, j2) + + !----------------------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to add IK and IL loops for OpenMP parallelization. + ! Preserve original code here (bmy, 12/5/08) + !do ij = julo + 1, jhi - 1 + ! + ! a6(i1:i2,ij,:) = & + ! 3.0d0 * & + ! (qqu(i1:i2,ij,:) + qqu(i1:i2,ij,:) - & + ! (al(i1:i2,ij,:) + ar(i1:i2,ij,:))) + ! + !end do + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !----------------------------------------------------------------------- + + do ij = julo+1, jhi-1 + do il = ilo, ihi + + a6(il,ij) = & + 3.0d0 * & + (qqu(il,ij) + qqu(il,ij) - & + (al(il,ij) + ar(il,ij))) + + end do + end do + +! ============== + if (jlmt <= 2) then +! ============== + + + lenx = 0 + + do ij = julo + 1, jhi - 1 + !=== Prior to 12/5/08 + !do il = i1, i2 + do il = ilo, ihi + + lenx = lenx + 1 + + a61 (lenx) = a6 (il,ij) + al1 (lenx) = al (il,ij) + ar1 (lenx) = ar (il,ij) + dcy1(lenx) = dcy(il,ij) + qqu1(lenx) = qqu(il,ij) + + end do + end do + +! =========== + call Lmtppm & + (lenx, jlmt, a61, al1, ar1, dcy1, qqu1) +! =========== + + lenx = 0 + + do ij = julo + 1, jhi - 1 + !=== Prior to 12/5/08 + !do il = i1, i2 + do il = ilo, ihi + + lenx = lenx + 1 + + a6(il,ij) = a61(lenx) + al(il,ij) = al1(lenx) + ar(il,ij) = ar1(lenx) + + end do + end do + + + end if + + + do ij = j1p, j2p+1 + + ijm1 = ij - 1 + + !=== Prior to 12/5/08 + !do il = i1, i2 + do il = ilo, ihi + + if (cry(il,ij) > 0.0d0) then + + qqv(il,ij) = & + ar(il,ijm1) + & + 0.5d0 * cry(il,ij) * & + (al(il,ijm1) - ar(il,ijm1) + & + (a6(il,ijm1) * (1.0d0 - (r23 * cry(il,ij))))) + + else + + qqv(il,ij) = & + al(il,ij) - & + 0.5d0 * cry(il,ij) * & + (ar(il,ij) - al(il,ij) + & + (a6(il,ij) * (1.0d0 + (r23 * cry(il,ij))))) + + end if + + end do + + end do + + + END SUBROUTINE Fyppm +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Fyppm_Pole_I2d2 +! +! !DESCRIPTION: Subroutine Do\_Fyppm\_Pole\_I2d2 sets "al" \& "ar" at +! the Poles. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Fyppm_Pole_I2d2( al, ar, I1_GL, I2_GL, JU1_GL, J2_GL, & + ILO, IHI, JULO, JHI, I1, I2, & + JU1, J2 ) +! +! !INPUT PARAMETERS: +! + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI +! +! !OUTPUT PARAMETERS: +! + ! Left (al) and right (ar) edge values of the test parabola + REAL*8, INTENT(INOUT) :: al(ILO:IHI, JULO:JHI) + REAL*8, INTENT(INOUT) :: ar(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: i2d2 + INTEGER :: il + + +! ---------------- +! Begin execution. +! ---------------- + + i2d2 = i2_gl / 2 + + + + !----------------------------------------------------------- + ! Prior to 12/5/08: + ! We need to add an IK loop for OpenMP parallelization. + ! Preserve original code here. (bmy, 12/5/08) + !do il = i1, i2d2 + ! al(il, ju1,:) = al(il+i2d2,ju1+1,:) + ! al(il+i2d2,ju1,:) = al(il, ju1+1,:) + !end do + ! The IK loop was moved outside the subroutine (ccc, 4/1/09) + !----------------------------------------------------------- + + do il = i1, i2d2 + al(il, ju1) = al(il+i2d2,ju1+1) + al(il+i2d2,ju1) = al(il, ju1+1) + ar(il, j2) = ar(il+i2d2,j2-1) + ar(il+i2d2,j2) = ar(il, j2-1) + end do + + + + END SUBROUTINE Do_Fyppm_Pole_I2d2 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Ytp_Pole_Sum +! +! !DESCRIPTION: Subroutine Do\_Ytp\_Pole\_Sum sets "dq1" at the Poles. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Ytp_Pole_Sum( geofac_pc, dq1, qqv, fy, I1_GL, & + I2_GL, JU1_GL, J2_GL, J1P, J2P, & + ILO, IHI, JULO, JHI, I1, & + I2, JU1, J2 ) +! +! !input PARAMETERS: +! + ! Global latitude indices at the edges of the S/N polar caps + ! J1P=JU1_GL+1; J2P=J2_GL-1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2; J2P=J2_GL-2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P, J2P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: I1_GL, I2_GL + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Special geometrical factor (geofac) for Polar cap + REAL*8, INTENT(IN) :: geofac_pc + + ! Concentration contribution from N-S advection [mixing ratio] + REAL*8, INTENT(IN) :: qqv(ILO:IHI, JULO:JHI) +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Species density [hPa] + REAL*8, INTENT(INOUT) :: dq1(ILO:IHI, JULO:JHI) + + ! N-S mass flux [mixing ratio] + REAL*8, INTENT(INOUT) :: fy (ILO:IHI, JULO:JHI+1) +! +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. Added +! OpenMP parallel DO loops. +! 01 Apr 2009 - C. Carouge - Moved the IK loop outside the subroutine. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: il, ik + REAL*8 :: ri2 + + ! Arrays + REAL*8 :: dq_np + REAL*8 :: dq_sp + REAL*8 :: dqik(2) ! 2 elements array for each pole value. + REAL*8 :: sumnp + REAL*8 :: sumsp + + +! ---------------- +! Begin execution. +! ---------------- + + ri2 = i2_gl + + dqik(:) = 0.0d0 + + +!... Integrate N-S flux around polar cap lat circle for each level + + sumsp = 0.0d0 + sumnp = 0.0d0 + + do il = i1, i2 + sumsp = sumsp + qqv(il,j1p) + sumnp = sumnp + qqv(il,j2p+1) + enddo + + +!... wrap in E-W direction + if (i1 == i1_gl) then + dqik(1) = dq1(i1,ju1) + dqik(2) = dq1(i1,j2) + endif + +!... normalize and set inside polar cap + + dq_sp = dqik(1) - (sumsp / ri2 * geofac_pc) + dq_np = dqik(2) + (sumnp / ri2 * geofac_pc) + + do il = i1, i2 + dq1(il,ju1) = dq_sp + dq1(il,j2) = dq_np +!... save polar flux + fy(il,ju1) = - (sumsp / ri2 * geofac_pc) + fy(il,j2+1) = (sumnp / ri2* geofac_pc) + enddo + + if (j1p /= ju1_gl+1) then + do il = i1, i2 + dq1(il,ju1+1) = dq_sp + dq1(il,j2-1) = dq_np +!... save polar flux + fy(il,ju1+1) = - (sumsp / ri2 * geofac_pc) + fy(il,j2) = (sumnp / ri2* geofac_pc) + enddo + + endif + + + END SUBROUTINE Do_Ytp_Pole_Sum +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Fzppm +! +! !DESCRIPTION: Subroutine Fzppm is the 1D "outer" flux form operator based +! on the Piecewise Parabolic Method (PPM; see also Lin and Rood 1996) for +! computing the fluxes in the vertical direction. +!\\ +!\\ +! Fzppm was modified by S.-J. Lin, 12/14/98, to allow the use of the KORD=7 +! (klmt=4) option. KORD=7 enforces the 2nd monotonicity constraint of +! Huynh (1996). Note that in Huynh's original scheme, two constraints are +! necessary for the preservation of monotonicity. To use Huynh's +! algorithm, it was modified as follows. The original PPM is still used to +! obtain the first guesses for the cell edges, and as such Huynh's 1st +! constraint is no longer needed. Huynh's median function is also replaced +! by a simpler yet functionally equivalent in-line algorithm. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Fzppm( klmt, delp1, wz, dq1, qq1, fz, & + J1P, JU1_GL, J2_GL, ILO, IHI, JULO, JHI, & + ILONG, IVERT, I1, I2, JU1, J2, K1, K2 ) +! +! !INPUT PARAMETERS: +! + ! Global latitude index at the edges of the South polar cap + ! J1P=JU1_GL+1 for a polar cap of 1 latitude band + ! J1P=JU1_GL+2 for a polar cap of 2 latitude bands + INTEGER, INTENT(IN) :: J1P + + ! Global min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: JU1_GL, J2_GL + + ! Local min & max longitude (I), latitude (J), altitude (K) indices + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + INTEGER, INTENT(IN) :: K1, K2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Dimensions in longitude & altitude ??? + INTEGER, INTENT(IN) :: ilong, ivert + + ! Controls various options in vertical advection + INTEGER, INTENT(IN) :: klmt + + ! Pressure thickness, the pseudo-density in a + ! hydrostatic system at t1 [hPa] + REAL*8, INTENT(IN) :: delp1(ILO:IHI, JULO:JHI, K1:K2) + + ! Large scale mass flux (per time step tdt) in the vertical + ! direction as diagnosed from the hydrostatic relationship [hPa] + REAL*8, INTENT(IN) :: wz(I1:I2, JU1:J2, K1:K2) + + ! Species concentration [mixing ratio] + REAL*8, INTENT(IN) :: qq1(ILO:IHI, JULO:JHI, K1:K2) +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Species density [hPa] + REAL*8, INTENT(INOUT) :: dq1(ILO:IHI, JULO:JHI, K1:K2) +! +! !OUTPUT PARAMETERS: +! + ! Vertical flux [mixing ratio] + REAL*8, INTENT(OUT) :: fz(ILO:IHI, JULO:JHI, K1:K2) + +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: il, ij, ik + INTEGER :: k1p1, k1p2 + INTEGER :: k2m1, k2m2 + INTEGER :: lenx + REAL*8 :: a1, a2 + REAL*8 :: aa, bb + REAL*8 :: c0, c1, c2 + REAL*8 :: cm, cp + REAL*8 :: fac1, fac2 + REAL*8 :: lac + REAL*8 :: qmax, qmin + REAL*8 :: qmp + REAL*8 :: r13, r23 + REAL*8 :: tmp + + ! Arrays + REAL*8 :: a61 (ilong*(ivert-4)) + REAL*8 :: al1 (ilong*(ivert-4)) + REAL*8 :: ar1 (ilong*(ivert-4)) + REAL*8 :: dca1 (ilong*(ivert-4)) + REAL*8 :: qq1a1(ilong*(ivert-4)) + REAL*8 :: a6 (i1:i2, k1:k2) + REAL*8 :: al (i1:i2, k1:k2) + REAL*8 :: ar (i1:i2, k1:k2) + REAL*8 :: dca (i1:i2, k1:k2) + REAL*8 :: dlp1a(i1:i2, k1:k2) + REAL*8 :: qq1a (i1:i2, k1:k2) + REAL*8 :: wza (i1:i2, k1:k2) + REAL*8 :: dc (i1:i2, ju1:j2, k1:k2) + ! Work array + REAL*8 :: dpi(I1:I2, JU1:J2, K1:K2) + + + +! ---------------- +! Begin execution. +! ---------------- + + a6(:,:) = 0.0d0 + al(:,:) = 0.0d0 + ar(:,:) = 0.0d0 + dc(:,:,:) = 0.0d0 +!.sds... diagnostic vertical flux for species - set top to 0.0 + fz(:,:,:) = 0.0 + + + k1p1 = k1 + 1 + k1p2 = k1 + 2 + + k2m1 = k2 - 1 + k2m2 = k2 - 2 + + r13 = 1.0d0 / 3.0d0 + r23 = 2.0d0 / 3.0d0 + + +! ------------------- +! Compute dc for PPM. +! ------------------- + + do ik = k1, k2m1 + dpi(:,:,ik) = qq1(i1:i2,ju1:j2,ik+1) - qq1(i1:i2,ju1:j2,ik) + end do + + + do ik = k1p1, k2m1 + + do ij = ju1, j2 + do il = i1, i2 + + c0 = delp1(il,ij,ik) / & + (delp1(il,ij,ik-1) + delp1(il,ij,ik) + & + delp1(il,ij,ik+1)) + + c1 = (delp1(il,ij,ik-1) + (0.5d0 * delp1(il,ij,ik))) / & + (delp1(il,ij,ik+1) + delp1(il,ij,ik)) + + c2 = (delp1(il,ij,ik+1) + (0.5d0 * delp1(il,ij,ik))) / & + (delp1(il,ij,ik-1) + delp1(il,ij,ik)) + + tmp = c0 * & + ((c1 * dpi(il,ij,ik)) + & + (c2 * dpi(il,ij,ik-1))) + + qmax = & + Max (qq1(il,ij,ik-1), & + qq1(il,ij,ik), & + qq1(il,ij,ik+1)) - & + qq1(il,ij,ik) + + qmin = & + qq1(il,ij,ik) - & + Min (qq1(il,ij,ik-1), & + qq1(il,ij,ik), & + qq1(il,ij,ik+1)) + + dc(il,ij,ik) = Sign (Min (Abs (tmp), qmax, qmin), tmp) + + end do + end do + + end do + + +!c? +! ------------------------------------- +! Loop over latitudes (to save memory). +! ------------------------------------- + +! ======================= + ijloop: do ij = ju1, j2 +! ======================= + + if (((ij == ju1_gl+1) .or. (ij == j2_gl-1)) .and. & + (j1p /= ju1_gl+1)) then +! ============ + cycle ijloop +! ============ + end if + + + !---------------------------------------------------------------- + ! Prior to 12/5/08: + ! Replace these with explicit loops below to facilitate + ! OpenMP parallelization. Preserve original code here. + ! (bmy, 12/5/08) + ! + !dca(:,:) = dc(:,ij,:) ! the monotone slope + !wza(:,:) = wz(:,ij,:) + ! + !dlp1a(:,:) = delp1(i1:i2,ij,:) + !qq1a (:,:) = qq1 (i1:i2,ij,:) + !---------------------------------------------------------------- + + do ik = k1, k2 + do il = i1, i2 + dca (il,ik) = dc (il,ij,ik) ! the monotone slope + wza (il,ik) = wz (il,ij,ik) + dlp1a(il,ik) = delp1(il,ij,ik) + qq1a (il,ik) = qq1 (il,ij,ik) + enddo + enddo + +! ---------------------------------------------------------------- +! Compute first guesses at cell interfaces. First guesses are +! required to be continuous. Three-cell parabolic subgrid +! distribution at model top; two-cell parabolic with zero gradient +! subgrid distribution at the surface. +! ---------------------------------------------------------------- + +! --------------------------- +! First guess top edge value. +! --------------------------- + + do il = i1, i2 + +! ------------------------------------------------------------ +! Three-cell PPM; compute a, b, & c of q = aP^2 + bP + c using +! cell averages and dlp1a. +! ------------------------------------------------------------ + + fac1 = dpi(il,ij,k1p1) - & + dpi(il,ij,k1) * (dlp1a(il,k1p1) + dlp1a(il,k1p2)) / & + (dlp1a(il,k1) + dlp1a(il,k1p1)) + + fac2 = (dlp1a(il,k1p1) + dlp1a(il,k1p2)) * & + (dlp1a(il,k1) + dlp1a(il,k1p1) + dlp1a(il,k1p2)) + + aa = 3.0d0 * fac1 / fac2 + + bb = & + 2.0d0 * dpi(il,ij,k1) / (dlp1a(il,k1) + dlp1a(il,k1p1)) - & + r23 * aa * (2.0d0 * dlp1a(il,k1) + dlp1a(il,k1p1)) + + al(il,k1) = qq1a(il,k1) - & + dlp1a(il,k1) * & + (r13 * aa * dlp1a(il,k1) + & + 0.5d0 * bb) + + al(il,k1p1) = dlp1a(il,k1) * (aa * dlp1a(il,k1) + bb) + & + al(il,k1) + +! --------------------- +! Check if change sign. +! --------------------- + + if ((qq1a(il,k1) * al(il,k1)) <= 0.0d0) then + + al (il,k1) = 0.0d0 + dca(il,k1) = 0.0d0 + + else + + dca(il,k1) = qq1a(il,k1) - al(il,k1) + + end if + + end do + +! ------- +! Bottom. +! ------- + + do il = i1, i2 + +! --------------------------------------------------- +! 2-cell PPM with zero gradient right at the surface. +! --------------------------------------------------- + + fac1 = dpi(il,ij,k2m1) * (dlp1a(il,k2) * dlp1a(il,k2)) / & + ((dlp1a(il,k2) + dlp1a(il,k2m1)) * & + (2.0d0 * dlp1a(il,k2) + dlp1a(il,k2m1))) + + ar(il,k2) = qq1a(il,k2) + fac1 + al(il,k2) = qq1a(il,k2) - (fac1 + fac1) + + if ((qq1a(il,k2) * ar(il,k2)) <= 0.0d0) then + ar(il,k2) = 0.0d0 + end if + + dca(il,k2) = ar(il,k2) - qq1a(il,k2) + + end do + + +! ---------------------------------------- +! 4th order interpolation in the interior. +! ---------------------------------------- + + do ik = k1p2, k2m1 + do il = i1, i2 + + c1 = (dpi(il,ij,ik-1) * dlp1a(il,ik-1)) / & + (dlp1a(il,ik-1) + dlp1a(il,ik)) + + c2 = 2.0d0 / & + (dlp1a(il,ik-2) + dlp1a(il,ik-1) + & + dlp1a(il,ik) + dlp1a(il,ik+1)) + + a1 = (dlp1a(il,ik-2) + dlp1a(il,ik-1)) / & + (2.0d0 * dlp1a(il,ik-1) + dlp1a(il,ik)) + + a2 = (dlp1a(il,ik) + dlp1a(il,ik+1)) / & + (2.0d0 * dlp1a(il,ik) + dlp1a(il,ik-1)) + + al(il,ik) = & + qq1a(il,ik-1) + c1 + & + c2 * & + (dlp1a(il,ik) * (c1 * (a1 - a2) + a2 * dca(il,ik-1)) - & + dlp1a(il,ik-1) * a1 * dca(il,ik)) + + end do + end do + + !----------------------------------------------------------------- + ! Prior to 12/5/08: + ! Replace these with explicit loops below to facilitate + ! OpenMP parallelization. Preserve original code here. + ! (bmy, 12/5/08) + ! + !do ik = k1, k2m1 + ! ar(:,ik) = al(:,ik+1) + !end do + !----------------------------------------------------------------- + + do ik = k1, k2m1 + do il = i1, i2 + ar(il,ik) = al(il,ik+1) + end do + end do + +! --------------------------------------- +! Top & Bottom 2 layers always monotonic. +! --------------------------------------- + + lenx = i2 - i1 + 1 + + do ik = k1, k1p1 + + do il = i1, i2 + + a6(il,ik) = & + 3.0d0 * (qq1a(il,ik) + qq1a(il,ik) - & + (al(il,ik) + ar(il,ik))) + end do + +! =========== + call Lmtppm & + (lenx, 0, a6(i1,ik), al(i1,ik), ar(i1,ik), & + dca(i1,ik), qq1a(i1,ik)) +! =========== + + end do + + + do ik = k2m1, k2 + + do il = i1, i2 + + a6(il,ik) = & + 3.0d0 * (qq1a(il,ik) + qq1a(il,ik) - & + (al(il,ik) + ar(il,ik))) + end do + +! =========== + call Lmtppm & + (lenx, 0, a6(i1,ik), al(i1,ik), ar(i1,ik), & + dca(i1,ik), qq1a(i1,ik)) +! =========== + + end do + + +! --------------------------- +! Interior depending on klmt. +! --------------------------- + +! ============== + if (klmt == 4) then +! ============== + +! ------------------------------- +! KORD=7, Huynh's 2nd constraint. +! ------------------------------- + + !----------------------------------------------------------------- + ! Prior to 12/5/08: + ! Replace these with explicit loops below to facilitate + ! OpenMP parallelization. Preserve original code here. + ! (bmy, 12/5/08) + ! + !do ik = k1p1, k2m1 + ! dca(:,ik) = dpi(:,ij,ik) - dpi(:,ij,ik-1) + !end do + !----------------------------------------------------------------- + + do ik = k1p1, k2m1 + do il = i1, i2 + dca(il,ik) = dpi(il,ij,ik) - dpi(il,ij,ik-1) + end do + end do + + + do ik = k1p2, k2m2 + do il = i1, i2 + +! ------------ +! Right edges. +! ------------ + + qmp = qq1a(il,ik) + (2.0d0 * dpi(il,ij,ik-1)) + lac = qq1a(il,ik) + & + (1.5d0 * dca(il,ik-1)) + (0.5d0 * dpi(il,ij,ik-1)) + qmin = Min (qq1a(il,ik), qmp, lac) + qmax = Max (qq1a(il,ik), qmp, lac) + + ar(il,ik) = Min (Max (ar(il,ik), qmin), qmax) + +! ----------- +! Left edges. +! ----------- + + qmp = qq1a(il,ik) - (2.0d0 * dpi(il,ij,ik)) + lac = qq1a(il,ik) + & + (1.5d0 * dca(il,ik+1)) - (0.5d0 * dpi(il,ij,ik)) + qmin = Min (qq1a(il,ik), qmp, lac) + qmax = Max (qq1a(il,ik), qmp, lac) + + al(il,ik) = Min (Max (al(il,ik), qmin), qmax) + +! ------------- +! Recompute a6. +! ------------- + + a6(il,ik) = & + 3.0d0 * (qq1a(il,ik) + qq1a(il,ik) - & + (ar(il,ik) + al(il,ik))) + end do + end do + + +! =================== + else if (klmt <= 2) then +! =================== + + lenx = 0 + + do ik = k1p2, k2m2 + do il = i1, i2 + + lenx = lenx + 1 + + al1 (lenx) = al (il,ik) + ar1 (lenx) = ar (il,ik) + dca1 (lenx) = dca (il,ik) + qq1a1(lenx) = qq1a(il,ik) + + a61 (lenx) = 3.0d0 * (qq1a1(lenx) + qq1a1(lenx) - & + (al1(lenx) + ar1(lenx))) + end do + end do + +! =========== + call Lmtppm & + (lenx, klmt, a61, al1, ar1, dca1, qq1a1) +! =========== + + lenx = 0 + + do ik = k1p2, k2m2 + do il = i1, i2 + + lenx = lenx + 1 + + a6 (il,ik) = a61 (lenx) + al (il,ik) = al1 (lenx) + ar (il,ik) = ar1 (lenx) + dca (il,ik) = dca1 (lenx) + qq1a(il,ik) = qq1a1(lenx) + + end do + end do + + + end if + + + do ik = k1, k2m1 + do il = i1, i2 + + if (wza(il,ik) > 0.0d0) then + + cm = wza(il,ik) / dlp1a(il,ik) + + dca(il,ik+1) = & + ar(il,ik) + & + 0.5d0 * cm * & + (al(il,ik) - ar(il,ik) + & + a6(il,ik) * (1.0d0 - r23 * cm)) + + else + + cp = wza(il,ik) / dlp1a(il,ik+1) + + dca(il,ik+1) = & + al(il,ik+1) + & + 0.5d0 * cp * & + (al(il,ik+1) - ar(il,ik+1) - & + a6(il,ik+1) * (1.0d0 + r23 * cp)) + + end if + + end do + end do + + + !----------------------------------------------------------------- + ! Prior to 12/5/08: + ! Replace these with explicit loops below to facilitate + ! OpenMP parallelization. Preserve original code here. + ! (bmy, 12/5/08) + ! + !do ik = k1, k2m1 + ! dca(:,ik+1) = wza(:,ik) * dca(:,ik+1) + ! !.sds.. save vertical flux for species as diagnostic + ! fz(i1:i2,ij,ik+1) = dca(:,ik+1) + !end do + ! + !dq1(i1:i2,ij,k1) = dq1(i1:i2,ij,k1) - dca(:,k1p1) + !dq1(i1:i2,ij,k2) = dq1(i1:i2,ij,k2) + dca(:,k2) + ! + !do ik = k1p1, k2m1 + ! + ! dq1(i1:i2,ij,ik) = & + ! dq1(i1:i2,ij,ik) + dca(:,ik) - dca(:,ik+1) + ! + !end do + !----------------------------------------------------------------- + do ik = k1, k2m1 + do il = i1, i2 + dca(il,ik+1) = wza(il,ik) * dca(il,ik+1) + !.sds.. save vertical flux for species as diagnostic + fz(il,ij,ik+1) = dca(il,ik+1) + end do + end do + + do il = i1, i2 + dq1(il,ij,k1) = dq1(il,ij,k1) - dca(il,k1p1) + dq1(il,ij,k2) = dq1(il,ij,k2) + dca(il,k2) + enddo + + do ik = k1p1, k2m1 + do il = i1, i2 + + dq1(il,ij,ik) = & + dq1(il,ij,ik) + dca(il,ik) - dca(il,ik+1) + + end do + end do +! ============= + end do ijloop +! ============= + + + END SUBROUTINE Fzppm + +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Average_Press_Poles +! +! !DESCRIPTION: Subroutine Average\_Press\_Poles averages pressure at the +! Poles when the Polar cap is enlarged. It makes the last two latitudes +! equal. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Average_Press_Poles( area_1D, press, I1, I2, JU1, & + J2, ILO, IHI, JULO, JHI ) +! +! !INPUT PARAMETERS: +! + ! Local min & max longitude (I), latitude (J) + INTEGER, INTENT(IN) :: I1, I2 + INTEGER, INTENT(IN) :: JU1, J2 + + ! Local min & max longitude (I) and latitude (J) indices + INTEGER, INTENT(IN) :: ILO, IHI + INTEGER, INTENT(IN) :: JULO, JHI + + ! Surface area of grid box + REAL*8, INTENT(IN) :: AREA_1D(JU1:J2) +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Surface pressure [hPa] + REAL*8, INTENT(INOUT) :: press(ILO:IHI, JULO:JHI) +! +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! Implemented into GEOS-Chem by Claire Carouge (ccarouge@seas.harvard.edu) +! +! !REMARKS: +! Subroutine from pjc_pfix. Call this one once everything is working fine. +! +! !REVISION HISTORY: +! 05 Dec 2008 - C. Carouge - Replaced TPCORE routines by S-J Lin and Kevin +! Yeh with the TPCORE routines from GMI model. +! This eliminates the polar overshoot in the +! stratosphere. +! 05 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. Also +! make sure all numerical constants are declared +! with the "D" double-precision exponent. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: I, J + REAL*8 :: meanp + REAL*8 :: REL_AREA(JU1:J2) + REAL*8 :: SUM_AREA + + !---------------- + !Begin execution. + !---------------- + + ! Compute the sum of surface area + SUM_AREA = SUM( AREA_1D ) * DBLE( I2 ) + + ! Calculate rel_area for each lat. (ccc, 11/20/08) + DO J = JU1, J2 + REL_AREA(J) = AREA_1D(J) / SUM_AREA + ENDDO + + !-------------- + ! South Pole + !-------------- + + ! Surface area of the S. Polar cap + SUM_AREA = SUM( rel_area( JU1:JU1+1 ) ) * DBLE( I2 ) + + ! Zero + meanp = 0.d0 + + ! Sum pressure * surface area over the S. Polar cap + DO J = JU1, JU1+1 + DO I = I1, I2 + meanp = meanp + ( rel_area(J) * press(I,J) ) + ENDDO + ENDDO + + ! Normalize pressure in all grid boxes w/in the S. Polar cap + press( :, JU1:JU1+1 ) = meanp / SUM_AREA + + !-------------- + ! North Pole + !-------------- + + ! Surface area of the N. Polar cap + SUM_AREA = SUM( rel_area( J2-1:J2 ) ) * DBLE( I2 ) + + ! Zero + meanp = 0.d0 + + ! Sum pressure * surface area over the N. Polar cap + DO J = J2-1, J2 + DO I = I1, I2 + meanp = meanp + ( rel_area(J) * press(I,J) ) + ENDDO + ENDDO + + ! Normalize pressure in all grid boxes w/in the N. Polar cap + press( :, J2-1:J2 ) = meanp / SUM_AREA + + END SUBROUTINE Average_Press_Poles + +END MODULE Tpcore_FvDas_mod +!EOC diff --git a/code/tpcore_mod.f b/code/tpcore_mod.f new file mode 100644 index 0000000..265d6e3 --- /dev/null +++ b/code/tpcore_mod.f @@ -0,0 +1,4237 @@ +! $Id: tpcore_mod.f,v 1.1 2009/06/09 21:51:51 daven Exp $ + MODULE TPCORE_MOD +! +!****************************************************************************** +! Module TPCORE_MOD contains the TPCORE transport subroutine package by +! S-J Lin, version 7.1. (bmy, 7/16/01, 9/18/07) +! +! Module Routines: +! ============================================================================ +! (1 ) TPCORE : TPCORE driver program +! (2 ) COSA : TPCORE intermediate subroutine +! (3 ) COSC : TPCORE intermediate subroutine +! (4 ) FCT3D : TPCORE intermediate subroutine +! (5 ) FILEW : TPCORE intermediate subroutine +! (6 ) FILNS : TPCORE intermediate subroutine +! (7 ) FXPPM : TPCORE intermediate subroutine +! (8 ) FYPPM : TPCORE intermediate subroutine +! (9 ) FZPPM : TPCORE intermediate subroutine +! (10) HILO : TPCORE intermediate subroutine +! (11) HILO3D : TPCORE intermediate subroutine +! (12) LMTPPM : TPCORE intermediate subroutine +! (13) QCKXYZ : TPCORE intermediate subroutine +! (14) XADV : TPCORE intermediate subroutine +! (15) XMIST : TPCORE intermediate subroutine +! (16) XTP : TPCORE intermediate subroutine +! (17) YMIST : TPCORE intermediate subroutine +! (18) YTP : TPCORE intermediate subroutine +! (19) PRESS_FIX : Wrapper for pressure-fixer subroutine DYN0 +! (20) DYN0 : Implements pressure fix for mass fluxes in TPCORE +! (21) PFILTR : Applies pressure filter to ALFA and BETA mass fluxes +! (22) LOCFLT : Local pressure filter -- called from PFILTR +! (23) POLFLT : Polar pressure filter -- called from PFILTR +! (24) DIAG_FLUX : Computes TPCORE mass fluxes for ND24, ND25, ND26 diags +! +! GEOS-CHEM modules referenced by tagged_co_mod.f +! ============================================================================ +! (1 ) diag_mod.f : Module containing GEOS-CHEM diagnostic arrays +! (2 ) dao_mod.f : Module containing DAO met field arrays +! (3 ) global_ch4_mod.f : Module containing routines to read 3-D CH4 field +! (4 ) grid_mod.f : Module containing horizontal grid information +! (5 ) pressure_mod.f : Module containing routines to compute P(I,J,L) +! (6 ) time_mod.f : Module containing routines to compute date & time +! +! NOTES: +! (1 ) The TPCORE subroutines have not been modified, except to replace +! obsolete parallel loop directives. It is more convenient to place +! all of the TPCORE subroutines into a single module, this reduces +! clutter. (bmy, 7/16/01) +! (2 ) All parallel loops are now specified with OpenMP directives, +! for cross-platform compatibility. (bmy, 7/16/01) +! (3 ) The routines in TPCORE_MOD have been validated against the previous +! version (Code_4.16). (bmy, 7/16/01) +! (4 ) Updated comments (bmy, 9/4/01) +! (5 ) Removed obsolete code from 7/12/01. Also implemented pressure-fix +! subroutines PRESS_FIX, DYN0, PFLITR, LOCFLT, POLFLT. (bmy, 10/9/01) +! (6 ) Now use PSC2 instead of PS in subroutine DYN0. Also delineate the +! first-time header text with horizontal lines. (bdf, bmy, 4/15/02) +! (7 ) Now zero XMASS_PF and YMASS_PF arrays on every call to TPCORE. +! This will avoid floating-point exceptions on the Alpha platform. +! (bmy, 4/18/02) +! (8 ) Now divide module header into MODULE PRIVATE, MODULE VARIABLES, and +! MODULE ROUTINES sections. Updated comments (bmy, 5/28/02) +! (9 ) Deleted obsolete code from 4/02. (bdf, bmy, 8/22/02) +! (10) Minor bug fix for ALPHA platform: delete extra comma in format +! statement 2 in routine TPCORE. Bug fix: now stop the run if NDT is +! too large. This makes sure we don't violate the Courant limit. +! (bmy, 11/22/02) +! (11) Also add output for the SUN/Sparc platform. Rename DEC_COMPAQ to +! COMPAQ. Also assume that all platforms other than CRAY use OPENMP +! parallelization commands (bmy, 3/23/03) +! (12) Now references "grid_mod.f" and "time_mod.f" (bmy, 3/24/03) +! (13) Now print output for IBM/AIX platform in "tpcore" (gcc, bmy, 6/27/03) +! (14) Remove obsolete code for CO-OH parameterization (bmy, 6/24/05) +! (15) Bug fix in DIAG_FLUX: now dimension FX, FX properly (bmy, 7/21/05) +! (16) Now print output for IFORT compiler in "tpcore" (bmy, 10/18/05) +! (17) Remove support for LINUX_IFC & LINUX_EFC compilers (bmy, 8/4/06) +! (18) Corrected mass flux diagnostics (phs, 9/18/07) +!****************************************************************************** +! + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "tpcore_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except this routine + PUBLIC :: TPCORE + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + +C ****6***0*********0*********0*********0*********0*********0**********72 + subroutine tpcore(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IM, + & JM,j1,NL,AP,BP,PT,AE,FILL,MFCT,Umax) +C****6***0*********0*********0*********0*********0*********0**********72 + +C TransPort module for Goddard Chemistry Transport Model (G-CTM), Goddard +C Earth Observing System General Circulation Model (GEOS-GCM), and Data +C Assimilation System (GEOS-DAS). + +C Purpose: perform the transport of 3-D mixing ratio fields using +C externally specified winds on the hybrid Eta-coordinate. +C One call to tpcore updates the 3-D mixing ratio +C fields for one time step (NDT). [vertical mass flux is computed +C internally using a center differenced hydrostatic mass +C continuity equation]. + +C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) schemes +C (Lin and Rood 1996, MWR) with a modified MFCT option (Zalesak 1979). + +C Multitasking version: 7.1 +C Last modified: Sept 2, 1999 +C Changes from version 7.m: large-time-step bug in xtp fixed. +C Suggested compiler options: +C CRAY f77 compiler: cf77 -Zp -c -Wd'-dec' -Wf' -a stack -exm' +C CRAY f90 compiler: f90 -c -eZ -DCRAY -Dmultitask +C SGI Origin: f77 -c -DSGI -Dmultitask -r8 -64 -O3 -mips4 -mp +C loader: f77 -64 -mp +C +C Send comments/suggestions to +C +C S.-J. Lin +C Address: +C Code 910.3, NASA/GSFC, Greenbelt, MD 20771 +C Phone: 301-614-6161 +C E-mail: slin@dao.gsfc.nasa.gov +C +C The algorithm is based on the following papers: + +C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi- +C Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070. +C +C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of +C the van Leer-type transport schemes and its applications to the moist- +C ure transport in a General Circulation Model. Mon. Wea. Rev., 122, +C 1575-1593. +C +C 3. Lin, S.-J., and R. B. Rood, 1997: Multidimensional flux form semi- +C Lagrangian transport schemes- MFCT option. To be submitted. + +C ====== +C INPUT: +C ====== + +C IGD: (horizontal) grid type on which winds are defined. +C IGD = 0 A-Grid [all variables defined at the same point from south +C pole (j=1) to north pole (j=JM) ] + +C IGD = 1 GEOS-GCM C-Grid (Max Suarez's center difference dynamical core) + +C [North] + +C V(i,j) +C | +C | +C | +C [WEST] U(i-1,j)---Q(i,j)---U(i,j) [EAST] +C | +C | +C | +C V(i,j-1) + +C [South] + +C U(i, 1) is defined at South Pole. +C V(i, 1) is half grid north of the South Pole. +C V(i,JM-1) is half grid south of the North Pole. +C +C V must be defined at j=1 and j=JM-1 if IGD=1 +C V at JM need not be defined. + +C Q(IM,JM,NL,NC): mixing ratios at current time (t) +C NC: total # of constituents +C IM: first (E-W) dimension; # of Grid intervals in E-W is IM +C JM: 2nd (N-S) dimension; # of Grid intervals in N-S is JM-1 +C NL: 3rd dimension (# of layers); vertical index increases from 1 at +C the model top to NL near the surface (see fig. below). +C It is assumed that NL > 5. +C +C PS1(IM,JM): surface pressure at current time (t) +C PS2(IM,JM): surface pressure at mid-time-level (t+NDT/2) +C PS2 is replaced by the predicted PS (at t+NDT) on output. +C Note: surface pressure can have any unit or can be multiplied by any +C const. +C +C The hybrid ETA-coordinate: +C +C pressure at layer edges are defined as follows: +C +C p(i,j,k) = AP(k)*PT + BP(k)*PS(i,j) (1) +C +C Where PT is a constant having the same unit as PS. +C AP and BP are unitless constants given at layer edges. +C In all cases BP(1) = 0., BP(NL+1) = 1. +C The pressure at the model top is PTOP = AP(1)*PT +C +C ********************* +C For pure sigma system +C ********************* +C AP(k) = 1 for all k, PT = PTOP, +C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP, where Psfc +C is the true surface pressure. +C +C ///////////////////////////////// +C / \ ------ Model top P=PTOP --------- AP(1), BP(1) +C | +C delp(1) | ........... Q(i,j,1) ............ +C | +C W(k=1) \ / --------------------------------- AP(2), BP(2) +C +C +C +C W(k-1) / \ --------------------------------- AP(k), BP(k) +C | +C delp(K) | ........... Q(i,j,k) ............ +C | +C W(k) \ / --------------------------------- AP(k+1), BP(k+1) +C +C +C +C / \ --------------------------------- AP(NL), BP(NL) +C | +C delp(NL) | ........... Q(i,j,NL) ......... +C | +C W(NL)=0 \ / -----Earth's surface P=Psfc ------ AP(NL+1), BP(NL+1) +C ////////////////////////////////// + +C U(IM,JM,NL) & V(IM,JM,NL):winds (m/s) at mid-time-level (t+NDT/2) +C Note that on return U and V are destroyed. + +C NDT (integer): time step in seconds (need not be constant during the course of +C the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5 +C (Lat-Lon) resolution. Smaller values maybe needed if the model +C has a well-resolved stratosphere and Max(V) > 225 m/s +C +C J1 determines the size of the polar cap: +C South polar cap edge is located at -90 + (j1-1.5)*180/(JM-1) deg. +C North polar cap edge is located at 90 - (j1-1.5)*180/(JM-1) deg. +C There are currently only two choices (j1=2 or 3). +C IM must be an even integer if j1 = 2. Recommended value: J1=3. +C +C IORD, JORD, and KORD are integers controlling various options in E-W, N-S, +C and vertical transport, respectively. +C +C +C _ORD= +C 1: 1st order upstream scheme (too diffusive, not a real option; it +C can be used for debugging purposes; this is THE only known "linear" +C monotonic advection scheme.). +C 2: 2nd order van Leer (full monotonicity constraint; +C see Lin et al 1994, MWR) +C 3: monotonic PPM* (Collela & Woodward 1984) +C 4: semi-monotonic PPM (same as 3, but overshoots are allowed) +C 5: positive-definite PPM (constraint on the subgrid distribution is +C only strong enough to prevent generation of negative values; +C both overshoots & undershootes are possible). +C 6: un-constrained PPM (nearly diffusion free; faster but +C positivity of the subgrid distribution is not quaranteed. Use +C this option only when the fields and winds are very smooth or +C when MFCT=.true.) +C 7: Huynh/Van Leer/Lin full monotonicity constraint +C Only KORD can be set to 7 to enable the use of Huynh's 2nd monotonicity +C constraint for piece-wise parabolic distribution. +C +C *PPM: Piece-wise Parabolic Method +C +C Recommended values: +C IORD=JORD=3 for high horizontal resolution. +C KORD=6 or 7 if MFCT=.true. +C KORD=3 or 7 if MFCT=.false. +C +C The implicit numerical diffusion decreases as _ORD increases. +C DO not use option 4 or 5 for non-positive definite scalars +C (such as Ertel Potential Vorticity). +C +C If numerical diffusion is a problem (particularly at low horizontal +C resolution) then the following setup is recommended: +C IORD=JORD=KORD=6 and MFCT=.true. +C +C AE: Radius of the sphere (meters). +C Recommended value for the planet earth: 6.371E6 +C +C FILL (logical): flag to do filling for negatives (see note below). +C MFCT (logical): flag to do a Zalesak-type Multidimensional Flux +C correction. It shouldn't be necessary to call the +C filling routine when MFCT is true. +C +C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s). +C (225 m/s is a good value for troposphere model; 300 m/s otherwise) +C +C ====== +C Output +C ====== +C +C Q: the updated mixing ratios at t+NDT (original values are over-written) +C W(;;NL): large-scale vertical mass flux as diagnosed from the hydrostatic +C relationship. W will have the same unit as PS1 and PS2 (eg, mb). +C W must be divided by NDT to get the correct mass-flux unit. +C The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND +C is the pressure thickness in the "upwind" direction. For example, +C C(k) = W(k)/delp(k) if W(k) > 0; +C C(k) = W(k)/delp(k+1) if W(k) < 0. +C ( W > 0 is downward, ie, toward surface) +C PS2: predicted PS at t+NDT (original values are over-written) +C +C Memory usage: +C This code is optimized for speed. it requres 18 dynamically allocated +C 3D work arrays (IM,JM,NL) regardless of the value of NC. +C Older versions (version 4 or 4.5) use less memory if NC is small. + +C ===== +C NOTES: +C ===== +C +C This forward-in-time upstream-biased transport scheme degenerates to +C the 2nd order center-in-time center-in-space mass continuity eqn. +C if Q = 1 (constant fields will remain constant). This degeneracy ensures +C that the computed vertical velocity to be identical to GEOS-1 GCM +C for on-line transport. +C +C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when +C winds are noisy near poles). +C +C The user needs to change the parameter Jmax or Kmax if the resolution +C is greater than 0.25 deg in N-S or 500 layers in the vertical direction. +C (this TransPort Core is otherwise resolution independent and can be used +C as a library routine). + +C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd +C order accurate for non-uniform grid (vertical sigma coord.). + +C Time step is limitted only by transport in the meridional direction. +C (the FFSL scheme is not implemented in the meridional direction). + +C Since only 1-D limiters are applied, negative values could +C potentially be generated when large time step is used and when the +C initial fields contain discontinuities. +C This does not necessarily imply the integration is unstable. +C These negatives are typically very small. A filling algorithm is +C activated if the user set "fill" to be true. +C Alternatively, one can use the MFCT option to enforce monotonicity. + + ! Added to pass C-preprocessor switches (bmy, 3/9/01) +# include "define.h" + +C ****6***0*********0*********0*********0*********0*********0**********72 + PARAMETER (Jmax = 721, kmax = 200) +C ****6***0*********0*********0*********0*********0*********0**********72 + +C Input-Output arrays + + REAL Q(IM,JM,NL,NC),PS1(IM,JM),PS2(IM,JM),W(IM,JM,NL), + & U(IM,JM,NL),V(IM,JM,NL),AP(NL+1),BP(NL+1) + LOGICAL ZCROSS, FILL, MFCT, deform + +C Local dynamic arrays + + REAL CRX(IM,JM,NL),CRY(IM,JM,NL),delp(IM,JM,NL),delp1(IM,JM,NL), + & xmass(IM,JM,NL),ymass(IM,JM,NL),delp2(IM,JM,NL), + & DG1(IM),DG2(IM,JM),DPI(IM,JM,NL),qlow(IM,JM,NL), + & WK(IM,JM,NL),PU(IM,JM,NL),DQ(IM,JM,NL), + & fx(IM+1,JM,NL),fy(IM,JM,NL),fz(IM,JM,NL+1), + & qz(IM,JM,NL),Qmax(IM,JM,NL),Qmin(IM,JM,NL) + +! bey, 6/20/00. for mass-flux diagnostic + REAL fx1_tp(IM,JM,NL), fy1_tp(IM,JM,NL), fz1_tp(IM,JM,NL) + + INTEGER JS(NL),JN(NL) + +C Local static arrays + + REAL DTDX(Jmax), DTDX5(Jmax), acosp(Jmax),cosp(Jmax), + & cose(Jmax), DAP(kmax), DBK(kmax) + + DATA NDT0, NSTEP /0, 0/ + DATA ZCROSS /.true./ + +C Saved internal variables: + SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML, DTDX, + & DTDX5, acosp, COSP, COSE, DAP,DBK + + ! New variables for TPCORE pressure fixer (bdf, bmy, 10/11/01) + REAL YMASS_PF(IM,JM,NL), XMASS_PF(IM,JM,NL), TEMP(IM,JM,NL) + LOGICAL PRESSURE_FIX + PRESSURE_FIX = .TRUE. + +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + deform = .false. + JM1 = JM -1 + IMH = IM/2 + j2 = JM - j1 + 1 + + NSTEP = NSTEP + 1 + +C****6***0*********0*********0*********0*********0*********0**********72 +C Initialization +C****6***0*********0*********0*********0*********0*********0**********72 + + ! Moved further down to be done for each tracer (phs, 30/8/07) +!! ! For mass flux diagnostics (bey, 6/20/00) +!! fx1_tp(:,:,:) = 0d0 +!! fy1_tp(:,:,:) = 0d0 +!! fz1_tp(:,:,:) = 0d0 +!! +!! ! Also need to initialize these arrays, so that the flux diagnostics +!! ! will be identical for single or multi processor (bmy, 9/29/00) +!! fx(:,:,:) = 0d0 +!! fy(:,:,:) = 0d0 +!! fz(:,:,:) = 0d0 +!! + ! Need to initialize these arrays in order to avoid + ! floating-point exceptions on Alpha (lyj, bmy, 4/19/02) + YMASS_PF(:,:,:) = 0d0 + XMASS_PF(:,:,:) = 0d0 + + if(NSTEP.eq.1) then + + ! Updated output (bmy, 3/13/03) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'T P C O R E -- FFSL TransPort Core v. 7.1' + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) 'Originally written by S-J Lin' + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) + & 'Modified for GEOS-CHEM by Isabelle Bey, Brendan Field, and' + WRITE( 6, '(a)' ) + & 'Bob Yantosca, with the addition of flux diagnostics and the' + WRITE( 6, '(a)' ) 'DYN0 pressure fixer from M. Prather' + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) 'Last Modification Date: 8/22/02' + WRITE( 6, '(a)' ) + +#if ( multitask ) + WRITE( 6, '(a)' ) 'TPCORE was compiled for multitasking' +#if defined( CRAY ) + WRITE( 6, '(a)' ) 'for CRAY' +#elif defined( SGI_MIPS ) + WRITE( 6, '(a)' ) 'for SGI Origin/Power Challenge machines' +#elif defined( COMPAQ ) + WRITE( 6, '(a)' ) 'for COMPAQ/HP RISC Alpha machines' +#elif defined( LINUX_PGI ) + WRITE( 6, '(a)' ) 'for Linux environment w/ PGI compiler' +#elif defined( LINUX_IFORT ) + WRITE( 6, '(a)' ) 'for Linux environment w/ Intel IFORT compiler' +#elif defined( SPARC ) + WRITE( 6, '(a)' ) 'for SUN/Sparc machines' +#elif defined( IBM_AIX ) + WRITE( 6, '(a)' ) 'for IBM/AIX machines' +#endif +#endif + + ! Added output on the first time TPCORE is called (bmy, 10/11/01) + IF ( PRESSURE_FIX ) THEN + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) 'TPCORE PRESSURE FIXER is turned ON!' + ENDIF + + if( MFCT ) then + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) 'MFCT option is on!' + endif + + ! Updated output (bmy, 4/15/02) + WRITE( 6, '(a)' ) + WRITE( 6, 2 ) IM, JM, NL, j1 + 2 FORMAT( 'IM= ', i3,1x,'JM= ', i3,1x,'NL= ',i3,1x,'J1= ',i3 ) + + ! Updated output (bmy, 4/15/02) + WRITE( 6, 3 ) NC, IORD, JORD, KORD, NDT + 3 FORMAT( 'NC= ',i3,1x,'IORD=',i3,1x,'JORD=',i3,1x, + & 'KORD=',i3,1x,'NDT= ',i8) + + if(NL.LT.6) then + write(6,*) 'stop in module tpcore' + write(6,*) 'NL must be >=6' + stop + endif + + if(Jmax.lt.JM .or. Kmax.lt.NL) then + write(6,*) 'stop in module tpcore' + write(6,*) 'Jmax or Kmax is too small; see documentation' + stop + endif + + DO 5 k=1,NL + DAP(k) = (AP(k+1) - AP(k))*PT +5 DBK(k) = BP(k+1) - BP(k) + + PI = 4. * ATAN(1.) + DL = 2.*PI / float(IM) + DP = PI / float(JM1) + + if(IGD.eq.0) then +C Compute analytic cosine at cell edges + call cosa(cosp,cose,JM,PI,DP) + else +C Define cosine consistent with GEOS-GCM (using dycore2.0 or later) + call cosc(cosp,cose,JM,PI,DP) + endif + + do 15 J=2,JM1 +15 acosp(j) = 1./cosp(j) + +C Inverse of the Scaled polar cap area. + + agle = (float(j1)-1.5)*DP + RCAP = DP / ( float(IM)*(1.-COS(agle)) ) + acosp(1) = RCAP + acosp(JM) = RCAP + ENDIF + + if(NDT0 .ne. NDT) then + DT = NDT + NDT0 = NDT + + CR1 = abs(Umax*DT)/(DL*AE) + MaxDT = DP*AE / abs(Umax) + 0.5 + + ! Updated output (bmy, 4/15/02) + WRITE( 6, '(a)' ) + WRITE(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT + + ! Bug fix: Now stop the run if NDT is too large. This will make + ! sure that we don't violate the Courant limit. (bmy, 11/22/02) + if(MaxDT .lt. abs(NDT)) then + write(6,*) 'Warning!!! NDT maybe too large!' + STOP + endif + + if(CR1.ge.0.95) then + JS0 = 0 + JN0 = 0 + IML = IM-2 + ZTC = 0. + else + ZTC = acos(CR1) * (180./PI) + JS0 = float(JM1)*(90.-ZTC)/180. + 2 + JS0 = max(JS0, J1+1) + IML = min(6*JS0/(J1-1)+2, 4*IM/5) + JN0 = JM-JS0+1 + endif + + ! Updated output (bmy, 4/15/02) + WRITE( 6, '(''ZTC= '', f13.6)') ZTC + WRITE( 6, 21 ) JS0, JN0, IML + 21 FORMAT( 'JS= ',i3,1x, 'JN= ',i3,1x,'IML= ',i3 ) + + do 22 J=2,JM1 + DTDX(j) = DT / ( DL*AE*COSP(J) ) + DTDX5(j) = 0.5*DTDX(j) +22 continue + + DTDY = DT /(AE*DP) + DTDY5 = 0.5*DTDY + + ! Updated output (bmy, 4/15/02) + WRITE( 6, 23 ) J1, J2 + 23 FORMAT( 'J1= ',i3,1x, 'J2= ',i3 ) + + ! Fancy output to stdout (bmy, 3/13/03) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + ENDIF ! END INITIALIZATION. + +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute Courant number +C****6***0*********0*********0*********0*********0*********0**********72 + + if(IGD.eq.0) then + +C Convert winds on A-Grid to Courant # on C-Grid. + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all shared(NL,im,jm1,jm,U,V,dtdx5,dtdy5,CRX,CRY) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + do k=1,NL + do 46 j=2,JM1 + do 46 i=2,IM +46 CRX(i,j,k) = dtdx5(j)*(U(i,j,k)+U(i-1,j,k)) + +C for i=1 + do 48 j=2,JM1 +48 CRX(1,j,k) = dtdx5(j)*(U(1,j,k)+U(IM,j,k)) + + do 49 j=2,JM + do 49 i=1,IM +49 CRY(i,j,k) = DTDY5*(V(i,j,k)+V(i,j-1,k)) + enddo + else +C Convert winds on C-grid to Courant # +C Beware of the index shifting!! (GEOS-GCM) + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all shared(NL,im,jm1,jm,U,V,dtdx,dtdy,CRX,CRY) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + DO 65 k=1,NL + do 50 j=2,JM1 + do 50 i=2,IM +50 CRX(i,j,k) = dtdx(j)*U(i-1,j,k) + + do 55 j=2,JM1 +55 CRX(1,j,k) = dtdx(j)*U(IM,j,k) + + do 60 j=2,JM + do 60 i=1,IM +60 CRY(i,j,k) = DTDY*V(i,j-1,k) +65 continue + endif + + !================================================================= + ! ***** T P C O R E P R E S S U R E F I X E R ***** + ! + ! Run pressure fixer to fix mass conservation problem. Pressure + ! fixer routines PRESS_FIX, DYN0, PFILTR, LOCFLT, and POLFLT + ! change the mass fluxes so they become consistant with met field + ! pressures. (bdf, bmy, 10/11/01) + ! + ! NOTE: The pressure fixer is not 100% perfect; tracer mass will + ! increase on the order of 0.5%/yr. However, this is much + ! better than w/o the pressure fixer, where the mass may + ! increase by as much as 40%/yr. (bdf, bmy, 10/22/01) + !================================================================= + IF ( PRESSURE_FIX ) THEN + + ! Loop over vertical levels -- + ! added parallel loop #if statements (bmy, 10/11/01) +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all shared(NL,IM,JM,JM1,COSE,XMASS_PF,YMASS_PF,DELP2,CRX,CRY) +CMIC$* private(I,J,K,D5) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, D5 ) +#endif +#endif + DO K = 1, NL + + ! DELP = pressure thickness: + ! the pseudo-density in a hydrostatic system. + DO J = 1, JM + DO I = 1, IM + DELP2(I,J,K) = DAP(K) + DBK(K)*PS2(I,J) + ENDDO + ENDDO + + ! calculate mass fluxes for pressure fixer. + + ! N-S component + DO J = J1, J2+1 + D5 = 0.5 * COSE(J) + + DO I = 1, IM + YMASS_PF(I,J,K) = + & CRY(I,J,K) * D5 * (DELP2(I,J,K)+DELP2(I,J-1,K)) + ENDDO + ENDDO + + ! Enlarged polar cap. + IF(J1.NE.2) THEN + DO I=1,IM + YMASS_PF(I,1,K) = 0 + YMASS_PF(I,JM1+1,K) = 0 + ENDDO + ENDIF + + ! E-W component + DO J = J1, J2 + DO I = 2, IM + PU(I,J,K) = 0.5 * (DELP2(I,J,K) + DELP2(I-1,J,K)) + ENDDO + ENDDO + + DO J = J1, J2 + PU(1,J,K) = 0.5 * (DELP2(1,J,K) + DELP2(IM,J,K)) + ENDDO + + DO J = J1, J2 + DO I = 1, IM + XMASS_PF(I,J,K) = PU(I,J,K) * CRX(I,J,K) + ENDDO + ENDDO + + ENDDO + + !============================================================== + ! Call PRESS_FIX to apply the pressure fix to the mass fluxes + ! XMASS_PF, YMASS_PF. PRESS_FIX will call routine DYN0, etc. + !============================================================== + CALL PRESS_FIX( XMASS_PF, YMASS_PF, NDT, ACOSP, J1 ) + + ! Loop over vertical levels -- + ! added parallel loop #if statements (bmy, 10/11/01) +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all shared(NL,IM,JM,XMASS_PF,PU,YMASS_PF,DELP2,COSE,CRX,CRY) +CMIC$* private(I,J,K,D5) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, D5 ) +#endif +#endif + DO K = 1, NL + + ! Recreate the CRX variable with the new values + ! of XMASS_PF, which has been adjusted by DYN0 + DO J = J1, J2 + DO I = 1, IM + CRX(I,J,K) = XMASS_PF(I,J,K) / PU(I,J,K) + ENDDO + ENDDO + + ! Recreate the CRY variable with the new values + ! of YMASS_PF, which has been adjusted by DYN0 + DO J = J1, J2+1 + D5 = 0.5 * COSE(J) + + DO I = 1, IM + CRY(I,J,K) = YMASS_PF(I,J,K) / + & ( D5 * ( DELP2(I,J,K) + DELP2(I,J-1,K) ) ) + ENDDO + ENDDO + ENDDO + ENDIF + + !================================================================= + ! End of TPCORE PRESSURE FIXER -- continue as usual + !================================================================= + +C****6***0*********0*********0*********0*********0*********0**********72 +C Find JN and JS +C****6***0*********0*********0*********0*********0*********0**********72 + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope shared(JS,JN,CRX,CRY,PS2,U,V,DPI,ymass,delp2,PU) +CMIC$* shared(xmass) +CMIC$* private(i,j,k,sum1,sum2,D5) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, SUM1, SUM2, D5 ) +#endif +#endif + + do 1000 k=1,NL + JS(k) = j1 + JN(k) = j2 + + do 111 j=JS0,j1+1,-1 + do 111 i=1,IM + if(abs(CRX(i,j,k)) .GT. 1.) then + JS(k) = j + go to 112 + endif +111 continue +112 continue + + do 122 j=JN0,j2-1 + do 122 i=1,IM + if(abs(CRX(i,j,k)) .GT. 1.) then + JN(k) = j + go to 133 + endif +122 continue +133 continue + +C****6***0*********0*********0*********0*********0*********0**********72 +C ***** Compute horizontal mass fluxes ***** +C****6***0*********0*********0*********0*********0*********0**********72 + +C delp = pressure thickness: the psudo-density in a hydrostatic system. + do 30 j=1,JM + do 30 i=1,IM +30 delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j) + +C N-S componenet + + do j=j1,j2+1 + D5 = 0.5 * COSE(j) + do i=1,IM + ymass(i,j,k) = CRY(i,j,k)*D5*(delp2(i,j,k) + delp2(i,j-1,k)) + enddo + enddo + + DO 75 j=j1,j2 + DO 75 i=1,IM +75 DPI(i,j,k) = (ymass(i,j,k)-ymass(i,j+1,k)) * acosp(j) + + if(j1.ne.2) then ! Enlarged polar cap. + do 95 i=1,IM + DPI(i, 2,k) = 0. +95 DPI(i,JM1,k) = 0. + endif + +C Poles + sum1 = ymass(IM,j1 ,k) + sum2 = ymass(IM,j2+1,k) + do 98 i=1,IM-1 + sum1 = sum1 + ymass(i,j1 ,k) +98 sum2 = sum2 + ymass(i,j2+1,k) + + sum1 = - sum1 * RCAP + sum2 = sum2 * RCAP + do 100 i=1,IM + DPI(i, 1,k) = sum1 +100 DPI(i,JM,k) = sum2 + +C E-W component + do j=j1,j2 + do i=2,IM + PU(i,j,k) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k)) + enddo + enddo + + do j=j1,j2 + PU(1,j,k) = 0.5 * (delp2(1,j,k) + delp2(IM,j,k)) + enddo + + DO 110 j=j1,j2 + DO 110 i=1,IM +110 xmass(i,j,k) = PU(i,j,k)*CRX(i,j,k) + + DO 120 j=j1,j2 + DO 120 i=1,IM-1 +120 DPI(i,j,k) = DPI(i,j,k) + xmass(i,j,k) - xmass(i+1,j,k) + + DO 130 j=j1,j2 +130 DPI(IM,j,k) = DPI(IM,j,k) + xmass(IM,j,k) - xmass(1,j,k) + +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute Courant number at cell center +C****6***0*********0*********0*********0*********0*********0**********72 + + DO 135 j=2,JM1 + do 135 i=1,IM-1 + if(CRX(i,j,k)*CRX(i+1,j,k) .gt. 0.) then + if(CRX(i,j,k) .gt. 0.) then + U(i,j,k) = CRX(i,j,k) + else + U(i,j,k) = CRX(i+1,j,k) + endif + else + U(i,j,k) = 0. + endif +135 continue + + i=IM + DO 136 j=2,JM1 + if(CRX(i,j,k)*CRX(1,j,k) .gt. 0.) then + if(CRX(i,j,k) .gt. 0.) then + U(i,j,k) = CRX(i,j,k) + else + U(i,j,k) = CRX(1,j,k) + endif + else + U(i,j,k) = 0. + endif +136 continue + + do 138 j=2,JM1 + do 138 i=1,IM + if(CRY(i,j,k)*CRY(i,j+1,k) .gt. 0.) then + if(CRY(i,j,k) .gt. 0.) then + V(i,j,k) = CRY(i,j,k) + else + V(i,j,k) = CRY(i,j+1,k) + endif + else + V(i,j,k) = 0. + endif +138 continue + + do 139 i=1,IMH + V(i, 1,k) = 0.5*(CRY(i,2,k)-CRY(i+IMH,2,k)) + V(i+IMH, 1,k) = -V(i,1,k) + V(i, JM,k) = 0.5*(CRY(i,JM,k)-CRY(i+IMH,JM1,k)) +139 V(i+IMH,JM,k) = -V(i,JM,k) +1000 continue + +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute vertical mass flux (same dimensional unit as PS) +C****6***0*********0*********0*********0*********0*********0**********72 + +C compute total column mass CONVERGENCE. + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope shared(im,jm,DPI,PS1,PS2,W,DBK) +CMIC$* shared(DPI,PS1,PS2,W,DBK) +CMIC$* private(i,j,k,DG1) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, DG1 ) +#endif +#endif + + do 395 j=1,jm + + do 320 i=1,IM +320 DG1(i) = DPI(i,j,1) + + do 330 k=2,NL + do 330 i=1,IM + DG1(i) = DG1(i) + DPI(i,j,k) +330 continue + + do 360 i=1,IM + +C Compute PS2 (PS at n+1) using the hydrostatic assumption. +C Changes (increases) to surface pressure = total column mass convergence + + PS2(i,j) = PS1(i,j) + DG1(i) + +C compute vertical mass flux from mass conservation principle. + + W(i,j,1) = DPI(i,j,1) - DBK(1)*DG1(i) + W(i,j,NL) = 0. +360 continue + + do 370 k=2,NL-1 + do 370 i=1,IM + W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*DG1(i) +370 continue +395 continue + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all +CMIC$* shared(deform,NL,im,jm,delp,delp1,delp2,DPI,DAP,DBK,PS1,PS2) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + DO 390 k=1,NL + + DO 380 j=1,JM + DO 380 i=1,IM + delp1(i,j,k) = DAP(k) + DBK(k)*PS1(i,j) + delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j) +380 delp (i,j,k) = delp1(i,j,k) + DPI(i,j,k) + +C Check deformation of the flow fields + if(deform) then + + DO 385 j=1,JM + DO 385 i=1,IM + if(delp(i,j,k) .le. 0.) then +c write(6,*) k,'Noisy wind fields -> delp* is negative!' +c write(6,*) ' *** Smooth the wind fields or reduce NDT' + stop + endif +385 continue + endif +390 continue + +C****6***0*********0*********0*********0*********0*********0**********72 +C Do transport one tracer at a time. +C****6***0*********0*********0*********0*********0*********0**********72 + + DO 5000 IC=1,NC + + ! Moved initialization to 0 here (30/8/07, phs) + ! For mass flux diagnostics (bey, 6/20/00) + fx1_tp(:,:,:) = 0d0 + fy1_tp(:,:,:) = 0d0 + fz1_tp(:,:,:) = 0d0 + + ! Also need to initialize these arrays, so that the flux diagnostics + ! will be identical for single or multi processor (bmy, 9/29/00) + fx(:,:,:) = 0d0 + fy(:,:,:) = 0d0 + fz(:,:,:) = 0d0 + + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(q,DQ,delp1,U,V,j1,j2,JS,JN,im,jm,IML,IC,IORD,JORD) +CMIC$* shared(CRX,CRY,PU,xmass,ymass,fx,fy,acosp,rcap,qz) +CMIC$* shared(fx1_tp, fy1_tp) +CMIC$* private(i,j,k,jt,wk,DG2) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, JT, WK, DG2 ) +#endif +#endif + + do 2500 k=1,NL + + if(j1.ne.2) then + DO 405 I=1,IM + q(I, 2,k,IC) = q(I, 1,k,IC) +405 q(I,JM1,k,IC) = q(I,JM,k,IC) + endif + +C Initialize DQ + + DO 420 j=1,JM + DO 420 i=1,IM +420 DQ(i,j,k) = q(i,j,k,IC)*delp1(i,j,k) + +C E-W advective cross term + call xadv(IM,JM,j1,j2,q(1,1,k,IC),U(1,1,k),JS(k),JN(k),IML, + & wk(1,1,1)) + do 430 j=1,JM + do 430 i=1,IM +430 wk(i,j,1) = q(i,j,k,IC) + 0.5*wk(i,j,1) + +C N-S advective cross term + do 66 j=j1,j2 + do 66 i=1,IM + jt = float(j) - V(i,j,k) +66 wk(i,j,2) = V(i,j,k) * (q(i,jt,k,IC) - q(i,jt+1,k,IC)) + + do 77 j=j1,j2 + do 77 i=1,IM +77 wk(i,j,2) = q(i,j,k,IC) + 0.5*wk(i,j,2) + +C****6***0*********0*********0*********0*********0*********0**********72 +C compute flux in E-W direction +C Return flux contribution from TPCORE in FX1_TP array (bey, 9/28/00) + call xtp(IM,JM,IML,j1,j2,JN(k),JS(k),PU(1,1,k),DQ(1,1,k), + & wk(1,1,2),CRX(1,1,k),fx(1,1,k),xmass(1,1,k),IORD, + & fx1_tp(:,:,k)) + +C compute flux in N-S direction +C Return flux contribution from TPCORE in FY1_TP array (bey, 9/28/00) + call ytp(IM,JM,j1,j2,acosp,RCAP,DQ(1,1,k),wk(1,1,1), + & CRY(1,1,k),DG2,ymass(1,1,k),WK(1,1,3),wk(1,1,4), + & WK(1,1,5),WK(1,1,6),fy(1,1,k),JORD, + & fy1_tp(:,:,k)) +C****6***0*********0*********0*********0*********0*********0**********72 + + if(ZCROSS) then + +C qz is the horizontal advection modified value for input to the +C vertical transport operator FZPPM +C Note: DQ contains only first order upwind contribution. + + do 88 j=1,JM + do 88 i=1,IM +88 qz(i,j,k) = DQ(i,j,k) / delp(i,j,k) + + else + + do 99 j=1,JM + do 99 i=1,IM +99 qz(i,j,k) = q(i,j,k,IC) + + endif + +2500 continue ! k-loop + +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute fluxes in the vertical direction +C Return flux contribution from FZPPM in FZ1_TP for ND26 (bey, 9/28/00) + call FZPPM(qz,fz,IM,JM,NL,DQ,W,delp,KORD,fz1_tp) +C****6***0*********0*********0*********0*********0*********0**********72 + + if( MFCT ) then + +C qlow is the low order "monotonic" solution + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all +CMIC$* shared(NL,im,jm,j1,jm1,qlow,DQ,delp2) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + + DO k=1,NL + + DO 560 j=1,JM + DO 560 i=1,IM +560 qlow(i,j,k) = DQ(i,j,k) / delp2(i,j,k) + + if(j1.ne.2) then + DO 561 i=1,IM + qlow(i, 2,k) = qlow(i, 1,k) + qlow(i,JM1,k) = qlow(i,JM,k) +561 CONTINUE + endif + + enddo + +C****6***0*********0*********0*********0*********0*********0**********72 + call FCT3D(Q(1,1,1,IC),qlow,fx,fy,fz,IM,JM,NL,j1,j2,delp2, + & DPI,qz,wk,Qmax,Qmin,DG2,U,V,acosp,RCAP) +C Note: Q is destroyed!!! +C****6***0*********0*********0*********0*********0*********0**********72 + ENDIF + +C Final update + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* private(i,j,k,sum1,sum2) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, SUM1, SUM2 ) +#endif +#endif + + do 101 k=1,NL + + do 425 j=j1,j2 + do 425 i=1,IM + DQ(i,j,k) = DQ(i,j,k) + fx(i,j,k) - fx(i+1,j,k) + & + (fy(i,j,k) - fy(i,j+1,k))*acosp(j) + & + fz(i,j,k) - fz(i,j,k+1) + +425 continue + + sum1 = fy(IM,j1 ,k) + sum2 = fy(IM,J2+1,k) + + do i=1,IM-1 + sum1 = sum1 + fy(i,j1 ,k) + sum2 = sum2 + fy(i,J2+1,k) + enddo + + DQ(1, 1,k) = DQ(1, 1,k) - sum1*RCAP + fz(1, 1,k) - fz(1, 1,k+1) + DQ(1,JM,k) = DQ(1,JM,k) + sum2*RCAP + fz(1,JM,k) - fz(1,JM,k+1) + + do i=2,IM + DQ(i, 1,k) = DQ(1, 1,k) + DQ(i,JM,k) = DQ(1,JM,k) + enddo + +101 continue + + !================================================================= + ! bey, 6/20/00. for mass-flux diagnostic + ! NOTE: DIAG_FLUX is not called within a parallel loop, + ! so parallelization can be done within the subroutine + !================================================================= + CALL DIAG_FLUX( IC, FX, FX1_TP, FY, FY1_TP, + & FZ, FZ1_TP, NDT, ACOSP ) + +C****6***0*********0*********0*********0*********0*********0**********72 + if(FILL) call qckxyz(DQ,DG2,IM,JM,NL,j1,j2,cosp,acosp,IC,NSTEP) +C****6***0*********0*********0*********0*********0*********0**********72 + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all +CMIC$* shared(q,IC,NL,j1,im,jm,jm1,DQ,delp2) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + DO k=1,NL + + DO 447 j=1,JM + DO 447 i=1,IM +447 Q(i,j,k,IC) = DQ(i,j,k) / delp2(i,j,k) + + if(j1.ne.2) then + DO 450 I=1,IM + Q(I, 2,k,IC) = Q(I, 1,k,IC) + Q(I,JM1,k,IC) = Q(I,JM,k,IC) +450 CONTINUE + endif + + enddo + +5000 continue + RETURN + END SUBROUTINE TPCORE + +!------------------------------------------------------------------------------ + + subroutine cosa(cosp,cose,JM,PI,DP) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL cosp(*),cose(*),sine(JM) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + do 10 j=2,JM + ph5 = -0.5*PI + (float(j-1)-0.5)*DP +10 sine(j) = SIN(ph5) + + do 80 J=2,JM-1 +80 cosp(J) = (sine(j+1)-sine(j))/DP + + cosp( 1) = 0. + cosp(JM) = 0. + +C Define cosine at edges.. + + do 90 j=2,JM +90 cose(j) = 0.5 * (cosp(j-1)+cosp(j)) + cose(1) = cose(2) + return + end subroutine cosa + +!------------------------------------------------------------------------------ + + subroutine cosc(cosp,cose,JNP,PI,DP) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL cosp(*),cose(*) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + phi = -0.5*PI + do 55 j=2,JNP-1 + phi = phi + DP +55 cosp(j) = cos(phi) + cosp( 1) = 0. + cosp(JNP) = 0. +C + do 66 j=2,JNP + cose(j) = 0.5*(cosp(j)+cosp(j-1)) +66 CONTINUE +C + do 77 j=2,JNP-1 + cosp(j) = 0.5*(cose(j)+cose(j+1)) +77 CONTINUE + return + end subroutine cosc + +!------------------------------------------------------------------------------ + + subroutine FCT3D(P,plow,fx,fy,fz,im,jm,km,j1,j2,delp,adx,ady, + & wk1,Qmax,Qmin,wkx,CRX,CRY,acosp,RCAP) +C****6***0*********0*********0*********0*********0*********0**********72 + + ! Added to pass C-preprocessor switches (bmy, 3/9/01) +# include "define.h" + +C MFCT Limiter +C plow: low order solution matrix +C P: current solution matrix + + PARAMETER (esl = 1.E-30) + REAL P(IM,JM,km),CRX(IM,JM,km),CRY(IM,JM,km),plow(IM,JM,km), + & Qmax(IM,JM,km),Qmin(IM,JM,km),acosp(*),delp(im,jm,km), + & adx(IM,JM,km),ady(IM,JM,km),fx(IM+1,JM,km), + & fy(IM,JM,km),fz(im,jm,km+1),wk1(IM,JM,km), + & wkx(im,jm),wkn(im,jm) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + + JM1 = JM-1 + +C Find local min/max of the low-order monotone solution + call hilo3D(P,im,jm,km,j1,j2,adx,ady,Qmax,Qmin,wkx,wkn) + call hilo3D(plow,im,jm,km,j1,j2,Qmax,Qmin,wk1,P,wkx,wkn) +C P is destroyed! + +C GOTO 123 +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(im,j1,j2,km,CRX,CRY,adx,ady,Qmax,Qmin) +CMIC$* private(i,j,k,IT,JT,PS1,PS2,PN1,PN2) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, IT, JT, PS1, PS2, PN1, PN2 ) +#endif +#endif + + DO 1000 k=1,km + do j=j1,j2 + DO i=1,IM + + IT = NINT( float(i) - CRX(i,j,k) ) +C Wrap around in E-W + if(IT .lt. 1) then + IT = IM + IT + elseif(IT .GT. IM) then + IT = IT - IM + endif + + JT = NINT( float(j) - CRY(i,j,k) ) + Qmax(i,j,k) = max(Qmax(i,j,k), adx(IT,JT,k)) + Qmin(i,j,k) = min(Qmin(i,j,k), ady(IT,JT,k)) + enddo + enddo + +C Poles: + PS1 = max(Qmax(1, 1,k), adx(1, 1,k)) + PS2 = min(Qmin(1, 1,k), ady(1, 1,k)) + + PN1 = max(Qmax(1,JM,k), adx(1,JM,k)) + PN2 = min(Qmin(1,JM,k), ady(1,JM,k)) + DO i=1,IM + Qmax(i, 1,k) = PS1 + Qmin(i, 1,k) = PS2 + + Qmax(i,JM,k) = PN1 + Qmin(i,JM,k) = PN2 + enddo +1000 continue + +123 continue +C Flux Limiter +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(adx,ady,fx,fy,fz,plow,Qmax,Qmin,delp) +CMIC$* private(wkx,wkn) +CMIC$* private(i,j,k,ain,aou,bin,bou,cin,cou,btop,bdon) +#else +!$OMP PARALLEL DO PRIVATE( WKX, WKN, I, J, K, AIN, AOU, +!$OMP+ BIN, BOU, CIN, COU, BTOP, BDON ) +#endif +#endif + + DO 2000 k=1,km + + DO j=j1,j2 + DO i=1,IM + if(fx(i,j,k) .gt. 0.) then + Ain = fx(i,j,k) + Aou = 0. + else + Ain = 0. + Aou = -fx(i,j,k) + endif + + if(fx(i+1,j,k) .gt. 0.) then + Aou = Aou + fx(i+1,j,k) + else + Ain = Ain - fx(i+1,j,k) + endif + + if(fy(i,j,k) .gt. 0.) then + Bin = fy(i,j,k) + Bou = 0. + else + Bin = 0. + Bou = -fy(i,j,k) + endif + + if(fy(i,j+1,k) .gt. 0.) then + Bou = Bou + fy(i,j+1,k) + else + Bin = Bin - fy(i,j+1,k) + endif + + if(fz(i,j,k) .gt. 0.) then + Cin = fz(i,j,k) + Cou = 0. + else + Cin = 0. + Cou = -fz(i,j,k) + endif + + if(fz(i,j,k+1) .gt. 0.) then + Cou = Cou + fz(i,j,k+1) + else + Cin = Cin - fz(i,j,k+1) + endif + +C****6***0*********0*********0*********0*********0*********0**********72 + wkx(i,j) = Ain + Bin*acosp(j) + Cin + wkn(i,j) = Aou + Bou*acosp(j) + Cou +C****6***0*********0*********0*********0*********0*********0**********72 + enddo + enddo + + DO j=j1,j2 + DO i=1,IM + adx(i,j,k) = delp(i,j,k)*(Qmax(i,j,k)-plow(i,j,k))/(wkx(i,j)+esl) + ady(i,j,k) = delp(i,j,k)*(plow(i,j,k)-Qmin(i,j,k))/(wkn(i,j)+esl) + enddo + enddo + +C S Pole + Ain = 0. + Aou = 0. + DO i=1,IM + if(fy(i,j1,k).gt. 0.) then + Aou = Aou + fy(i,j1,k) + else + Ain = Ain + fy(i,j1,k) + endif + enddo + Ain = -Ain * RCAP + Aou = Aou * RCAP + +C add vertical contribution... + + i=1 + j=1 + if(fz(i,j,k) .gt. 0.) then + Cin = fz(i,j,k) + Cou = 0. + else + Cin = 0. + Cou = -fz(i,j,k) + endif + + if(fz(i,j,k+1) .gt. 0.) then + Cou = Cou + fz(i,j,k+1) + else + Cin = Cin - fz(i,j,k+1) + endif + +C****6***0*********0*********0*********0*********0*********0**********72 + btop = delp(1,1,k)*(Qmax(1,1,k)-plow(1,1,k))/(Ain+Cin+esl) + bdon = delp(1,1,k)*(plow(1,1,k)-Qmin(1,1,k))/(Aou+Cou+esl) +C****6***0*********0*********0*********0*********0*********0**********72 + + DO i=1,IM + adx(i,j,k) = btop + ady(i,j,k) = bdon + enddo +C N Pole + J=JM + Ain = 0. + Aou = 0. + DO i=1,IM + if(fy(i,j2+1,k).gt. 0.) then + Ain = Ain + fy(i,j2+1,k) + else + Aou = Aou + fy(i,j2+1,k) + endif + enddo + Ain = Ain * RCAP + Aou = -Aou * RCAP + +C add vertical contribution... + + i=1 + if(fz(i,j,k) .gt. 0.) then + Cin = fz(i,j,k) + Cou = 0. + else + Cin = 0. + Cou = -fz(i,j,k) + endif + + if(fz(i,j,k+1) .gt. 0.) then + Cou = Cou + fz(i,j,k+1) + else + Cin = Cin - fz(i,j,k+1) + endif + +C****6***0*********0*********0*********0*********0*********0**********72 + btop = delp(1,j,k)*(Qmax(1,j,k)-plow(1,j,k))/(Ain+Cin+esl) + bdon = delp(1,j,k)*(plow(1,j,k)-Qmin(1,j,k))/(Aou+Cou+esl) +C****6***0*********0*********0*********0*********0*********0**********72 + + DO i=1,IM + adx(i,j,k) = btop + ady(i,j,k) = bdon + enddo + + if(j1 .ne. 2) then + DO i=1,IM +C SP + adx(i,2,k) = adx(i,1,k) + ady(i,2,k) = ady(i,1,k) +C NP + adx(i,JM1,k) = adx(i,JM,k) + ady(i,JM1,k) = ady(i,JM,k) + enddo + endif +2000 continue + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(fz,adx,ady,im,jm,km) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + DO 3000 k=1,km + DO j=j1,j2 + do i=2,IM + if(fx(i,j,k) .gt. 0.) then + fx(i,j,k) = min(1.,ady(i-1,j,k),adx(i,j,k))*fx(i,j,k) + else + fx(i,j,k) = min(1.,adx(i-1,j,k),ady(i,j,k))*fx(i,j,k) + endif + enddo + enddo + +C For i=1 + DO j=j1,j2 + if(fx(1,j,k) .gt. 0.) then + fx(1,j,k) = min(1.,ady(IM,j,k),adx(1,j,k))*fx(1,j,k) + else + fx(1,j,k) = min(1.,adx(IM,j,k),ady(1,j,k))*fx(1,j,k) + endif + fx(IM+1,j,k) = fx(1,j,k) + enddo + + do j=j1,j2+1 + do i=1,IM + if(fy(i,j,k) .gt. 0.) then + fy(i,j,k) = min(1.,ady(i,j-1,k),adx(i,j,k))*fy(i,j,k) + else + fy(i,j,k) = min(1.,adx(i,j-1,k),ady(i,j,k))*fy(i,j,k) + endif + enddo + enddo + + if(k .ne. 1) then + do j=1,jm + do i=1,im + if(fz(i,j,k) .gt. 0.) then + fz(i,j,k) = min(1.,ady(i,j,k-1),adx(i,j,k))*fz(i,j,k) + else + fz(i,j,k) = min(1.,adx(i,j,k-1),ady(i,j,k))*fz(i,j,k) + endif + enddo + enddo + endif + +3000 continue + + return + end subroutine fct3d + +!------------------------------------------------------------------------------ + + subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL q(IMR,*),qtmp(JNP,IMR) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + ipx = 0 +C Copy & swap direction for vectorization. + do 25 i=1,imr + do 25 j=j1,j2 +25 qtmp(j,i) = q(i,j) +C + do 55 i=2,imr-1 + do 55 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(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 +c east + d0 = max(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 + tiny + endif +55 continue +c + i=1 + do 65 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,imr)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,imr) = qtmp(j,imr) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +65 continue + i=IMR + do 75 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(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 +c east + d0 = max(0.,qtmp(j,1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,1) = qtmp(j,1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +75 continue +C + if(ipx.ne.0) then + do 85 j=j1,j2 + do 85 i=1,imr +85 q(i,j) = qtmp(j,i) + else + +C Pole + if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1 + endif + return + end subroutine filew + +!------------------------------------------------------------------------------ + + subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL q(IMR,*),cosp(*),acosp(*) + LOGICAL first + DATA first /.true./ + SAVE cap1 +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + if(first) then + DP = 4.*ATAN(1.)/float(JNP-1) + cap1 = IMR*(1.-COS((j1-1.5)*DP))/DP + first = .false. + endif +C + ipy = 0 + do 55 j=j1+1,j2-1 + DO 55 i=1,IMR + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C North + dn = q(i,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C + do i=1,imr + IF(q(i,j1).LT.0.) THEN + ipy = 1 + dq = - q(i,j1)*cosp(j1) +C North + dn = q(i,j1+1)*cosp(j1+1) + d0 = max(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 +C + j = j2 + do i=1,imr + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(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 +C +C Check Poles. + if(q(1,1).lt.0.) then + dq = q(1,1)*cap1/float(IMR)*acosp(j1) + do i=1,imr + q(i,1) = 0. + q(i,j1) = q(i,j1) + dq + if(q(i,j1).lt.0.) ipy = 1 + enddo + endif +C + if(q(1,JNP).lt.0.) then + dq = q(1,JNP)*cap1/float(IMR)*acosp(j2) + do i=1,imr + q(i,JNP) = 0. + q(i,j2) = q(i,j2) + dq + if(q(i,j2).lt.0.) ipy = 1 + enddo + endif +C + return + end subroutine filns + +!------------------------------------------------------------------------------ + + subroutine fxppm(IMR,IML,UT,P,DC,fx1,fx2,IORD) +C****6***0*********0*********0*********0*********0*********0**********72 + PARAMETER ( R3 = 1./3., R23 = 2./3. ) + REAL UT(*),fx1(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1) + REAL AR(0:IMR),AL(0:IMR),A6(0:IMR),fx2(*) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + LMT = IORD - 3 +C + DO 10 i=1,IMR +10 AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3 +C + do 20 i=1,IMR-1 +20 AR(i) = AL(i+1) + AR(IMR) = AL(1) +C + do 30 i=1,IMR +30 A6(i) = 3.*(p(i)+p(i) - (AL(i)+AR(i))) +C + if(LMT.LE.2) call lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT) +C + AL(0) = AL(IMR) + AR(0) = AR(IMR) + A6(0) = A6(IMR) +C +C Abs(UT(i)) < 1 + DO i=1,IMR + IF(UT(i).GT.0.) then + fx1(i) = P(i-1) + fx2(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) + + & A6(i-1)*(1.-R23*UT(i)) ) + else + fx1(i) = P(i) + fx2(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) + + & A6(i)*(1.+R23*UT(i))) + endif + enddo +C + DO i=1,IMR + fx2(i) = fx2(i) - fx1(i) + enddo + return + end subroutine fxppm + +!------------------------------------------------------------------------------ + + subroutine fyppm(C,P,DC,fy1,fy2,IMR,JNP,j1,j2,A6,AR,AL,JORD) +C****6***0*********0*********0*********0*********0*********0**********72 + PARAMETER ( R3 = 1./3., R23 = 2./3. ) + REAL C(IMR,*),fy1(IMR,*),P(IMR,*),DC(IMR,*),fy2(IMR,JNP) + REAL AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + IMH = IMR / 2 + JMR = JNP - 1 + j11 = j1-1 + IMJM1 = IMR*(J2-J1+2) + len = IMR*(J2-J1+3) + LMT = JORD - 3 +C + DO 10 i=1,IMR*JMR + AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3 + AR(i,1) = AL(i,2) +10 CONTINUE +C +C Poles: +C + DO i=1,IMH + AL(i,1) = AL(i+IMH,2) + AL(i+IMH,1) = AL(i,2) +C + AR(i,JNP) = AR(i+IMH,JMR) + AR(i+IMH,JNP) = AR(i,JMR) + enddo +C + do 30 i=1,len +30 A6(i,j11) = 3.*(p(i,j11)+p(i,j11) - (AL(i,j11)+AR(i,j11))) +C + if(LMT.le.2) call lmtppm(DC(1,j11),A6(1,j11),AR(1,j11), + & AL(1,j11),P(1,j11),len,LMT) +C + DO 140 i=1,IMJM1 + IF(C(i,j1).GT.0.) then + fy1(i,j1) = P(i,j11) + fy2(i,j1) = AR(i,j11) + 0.5*C(i,j1)*(AL(i,j11) - AR(i,j11) + + & A6(i,j11)*(1.-R23*C(i,j1)) ) + else + fy1(i,j1) = P(i,j1) + fy2(i,j1) = AL(i,j1) - 0.5*C(i,j1)*(AR(i,j1) - AL(i,j1) + + & A6(i,j1)*(1.+R23*C(i,j1))) + endif +140 continue +c + DO i=1,IMJM1 + fy2(i,j1) = fy2(i,j1) - fy1(i,j1) + ENDDO + return + end subroutine fyppm + +!------------------------------------------------------------------------------ + + subroutine FZPPM(P,fz,IMR,JNP,NL,DQ,WZ,delp,KORD,fz1_tp) +C****6***0*********0*********0*********0*********0*********0**********72 + + ! Added to pass C-preprocessor switches (bmy, 3/9/01) +# include "define.h" + + PARAMETER ( R23 = 2./3., R3 = 1./3.) + REAL WZ(IMR,JNP,NL),P(IMR,JNP,NL),DQ(IMR,JNP,NL), + & fz(IMR,JNP,NL+1),delp(IMR,JNP,NL) +C local 2d arrays + REAL AR(IMR,NL),AL(IMR,NL),A6(IMR,NL),delq(IMR,NL),DC(IMR,NL) + +! bey, 6/20/00. for mass-flux diagnostic + real fz1_tp(IMR,JNP,NL) + + real lac +c real x, y, z +c real median +c median(x,y,z) = min(max(x,y), max(y,z), max(z,x)) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + km = NL + km1 = NL-1 + LMT = max(KORD - 3, 0) + +C find global min/max + + ! VMAX1D causes bus errors on SGI. Replace with F90 intrinsic + ! functions "MAXVAL" and "MINVAL". These functions produced + ! identical results as vmax1d in testing. "MAXVAL" and "MINVAL" + ! should also execute more efficiently as well. (bmy, 4/24/00) + Tmax = MAXVAL( P(:,:,1) ) + Tmin = MINVAL( P(:,:,1) ) + Bmax = MAXVAL( P(:,:,NL) ) + Bmin = MINVAL( P(:,:,NL) ) + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(LMT,Tmax,Tmin,Bmax,Bmin,JNP,IMR) +CMIC$* shared(fz,DQ,WZ,fz1_tp) +CMIC$* private(i,j,k,c1,c2,tmp,qmax,qmin,A1,A2,d1,d2,qm,dp,c3) +CMIC$* private(cmax,cmin,DC,delq,AR,AL,A6,CM,CP, qmp, lac) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, C1, C2, TMP, QMAX, QMIN, A1, A2, +!$OMP+ D1, D2, QM, DP, C3, CMAX, CMIN, DC, DELQ, +!$OMP+ AR, AL, A6, CM, CP, QMP, LAC ) +#endif +#endif + + do 4000 j=1,JNP + + do 500 k=2,km + do 500 i=1,IMR +500 A6(i,k) = delp(i,j,k-1) + delp(i,j,k) + + do 1000 k=1,km1 + do 1000 i=1,IMR +1000 delq(i,k) = P(i,j,k+1) - P(i,j,k) + + DO 1220 k=2,km1 + DO 1220 I=1,IMR + c1 = (delp(i,j,k-1)+0.5*delp(i,j,k))/A6(i,k+1) + c2 = (delp(i,j,k+1)+0.5*delp(i,j,k))/A6(i,k) + tmp = delp(i,j,k)*(c1*delq(i,k) + c2*delq(i,k-1)) + & / (A6(i,k)+delp(i,j,k+1)) + Qmax = max(P(i,j,k-1),P(i,j,k),P(i,j,k+1)) - P(i,j,k) + Qmin = P(i,j,k) - min(P(i,j,k-1),P(i,j,k),P(i,j,k+1)) + DC(i,k) = sign(min(abs(tmp),Qmax,Qmin), tmp) +1220 CONTINUE + +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute the first guess at cell interface +C First guesses are required to be continuous. +C****6***0*********0*********0*********0*********0*********0**********72 + +C Interior. + + DO 12 k=3,km1 + DO 12 i=1,IMR + c1 = delq(i,k-1)*delp(i,j,k-1) / A6(i,k) + A1 = A6(i,k-1) / (A6(i,k) + delp(i,j,k-1)) + A2 = A6(i,k+1) / (A6(i,k) + delp(i,j,k)) + AL(i,k) = P(i,j,k-1) + c1 + 2./(A6(i,k-1)+A6(i,k+1)) * + & ( delp(i,j,k )*(c1*(A1 - A2)+A2*DC(i,k-1)) - + & delp(i,j,k-1)*A1*DC(i,k ) ) +12 CONTINUE + +C Area preserving cubic with 2nd deriv. = 0 at the boundaries +C Top + DO 10 i=1,IMR + d1 = delp(i,j,1) + d2 = delp(i,j,2) + qm = (d2*P(i,j,1)+d1*P(i,j,2)) / (d1+d2) + dp = 2.*(P(i,j,2)-P(i,j,1)) / (d1+d2) + c1 = 4.*(AL(i,3)-qm-d2*dp) / ( d2*(2.*d2*d2+d1*(d2+3.*d1)) ) + c3 = dp - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2) + AL(i,2) = qm - 0.25*c1*d1*d2*(d2+3.*d1) + AL(i,1) = d1*(2.*c1*d1**2-c3) + AL(i,2) + DC(i,1) = P(i,j,1) - AL(i,1) +C No over- and undershoot condition + AL(i,1) = max(Tmin,AL(i,1)) + AL(i,1) = min(Tmax,AL(i,1)) + Cmax = max(P(i,j,1), P(i,j,2)) + Cmin = min(P(i,j,1), P(i,j,2)) + AL(i,2) = max(Cmin,AL(i,2)) + AL(i,2) = min(Cmax,AL(i,2)) +10 continue + +C Bottom + DO 15 i=1,IMR + d1 = delp(i,j,km ) + d2 = delp(i,j,km1) + qm = (d2*P(i,j,km)+d1*P(i,j,km1)) / (d1+d2) + dp = 2.*(P(i,j,km1)-P(i,j,km)) / (d1+d2) + c1 = 4.*(AL(i,km1)-qm-d2*dp) / (d2*(2.*d2*d2+d1*(d2+3.*d1))) + c3 = dp - 0.5*c1*(d2*(5.*d1+d2)-3.*d1**2) + AL(i,km) = qm - 0.25*c1*d1*d2*(d2+3.*d1) + AR(i,km) = d1*(2.*c1*d1**2-c3) + AL(i,km) + DC(i,km) = AR(i,km) - P(i,j,km) +C No over- and undershoot condition + Cmax = max(P(i,j,km), P(i,j,km1)) + Cmin = min(P(i,j,km), P(i,j,km1)) + AL(i,km) = max(Cmin,AL(i,km)) + AL(i,km) = min(Cmax,AL(i,km)) + AR(i,km) = max(Bmin,AR(i,km)) + AR(i,km) = min(Bmax,AR(i,km)) +15 continue + + do 20 k=1,km1 + do 20 i=1,IMR + AR(i,k) = AL(i,k+1) +20 continue + +C f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) +C Top 2 layers + do k=1,2 + do i=1,IMR + A6(i,k) = 3.*(P(i,j,k)+P(i,j,k) - (AL(i,k)+AR(i,k))) + enddo + call lmtppm(DC(1,k),A6(1,k),AR(1,k),AL(1,k),P(1,j,k), + & IMR,0) + enddo + +C Interior. + if(LMT.LE.2) then + do k=3,NL-2 + do i=1,IMR + A6(i,k) = 3.*(P(i,j,k)+P(i,j,k) - (AL(i,k)+AR(i,k))) + enddo + call lmtppm(DC(1,k),A6(1,k),AR(1,k),AL(1,k),P(1,j,k), + & IMR,LMT) + enddo + + elseif(LMT .eq. 4) then + +c****6***0*********0*********0*********0*********0*********0**********72 +C Huynh's 2nd constraint +c****6***0*********0*********0*********0*********0*********0**********72 + + do k=2, NL-1 + do i=1,imr + DC(i,k) = delq(i,k) - delq(i,k-1) + enddo + enddo + + do k=3, NL-2 + do i=1, imr +C Right edges + qmp = P(i,j,k) + 2.0*delq(i,k-1) + lac = P(i,j,k) + 1.5*DC(i,k-1) + 0.5*delq(i,k-1) + qmin = min(P(i,j,k), qmp, lac) + qmax = max(P(i,j,k), qmp, lac) +c AR(i,k) = median(AR(i,k), qmin, qmax) + AR(i,k) = min(max(AR(i,k), qmin), qmax) +C Left edges + qmp = P(i,j,k) - 2.0*delq(i,k) + lac = P(i,j,k) + 1.5*DC(i,k+1) - 0.5*delq(i,k) + qmin = min(P(i,j,k), qmp, lac) + qmax = max(P(i,j,k), qmp, lac) +c AL(i,k) = median(AL(i,k), qmin, qmax) + AL(i,k) = min(max(AL(i,k), qmin), qmax) +C Recompute A6 + A6(i,k) = 3.*(2.*P(i,j,k) - (AR(i,k)+AL(i,k))) + enddo + enddo + endif + +C Bottom 2 layers + do k=NL-1,NL + do i=1,IMR + A6(i,k) = 3.*(P(i,j,k)+P(i,j,k) - (AL(i,k)+AR(i,k))) + enddo + call lmtppm(DC(1,k),A6(1,k),AR(1,k),AL(1,k),P(1,j,k), + & IMR,0) + enddo + + DO 140 k=2,NL + DO 140 i=1,IMR + IF(WZ(i,j,k-1).GT.0.) then + CM = WZ(i,j,k-1) / delp(i,j,k-1) + DC(i,k) = P(i,j,k-1) + fz(i,j,k) = AR(i,k-1)+0.5*CM*(AL(i,k-1)-AR(i,k-1)+ + & A6(i,k-1)*(1.-R23*CM)) + else + CP = WZ(i,j,k-1) / delp(i,j,k) + DC(i,k) = P(i,j,k) + fz(i,j,k) = AL(i,k)+0.5*CP*(AL(i,k)-AR(i,k)- + & A6(i,k)*(1.+R23*CP)) + endif +140 continue + + DO 250 k=2,NL + DO 250 i=1,IMR + fz(i,j,k) = WZ(i,j,k-1) * (fz(i,j,k) - DC(i,k)) + DC(i,k) = WZ(i,j,k-1) * DC(i,k) +250 continue + + do 350 i=1,IMR + fz(i,j, 1) = 0. + fz(i,j,NL+1) = 0. + DQ(i,j, 1) = DQ(i,j, 1) - DC(i, 2) + DQ(i,j,NL) = DQ(i,j,NL) + DC(i,NL) + fz1_tp(i,j,1) = 0. ! PHS + fz1_tp(i,j,NL) = DC(i,NL) ! PHS - flux b/w 1st and second layer +350 continue + +!----------------------------------------------------------------------------- +! bey, 6/20/00. for mass-flux diagnostic, loop had to be extended +! do 360 k=2,km1 +! do 360 i=1,IMR +!360 DQ(i,j,k) = DQ(i,j,k) + DC(i,k) - DC(i,k+1) +!----------------------------------------------------------------------------- + do k=2,km1 + do i=1,IMR + DQ(i,j,k) = DQ(i,j,k) + DC(i,k) - DC(i,k+1) + + ! bey, 6/20/00. for mass-flux diagnostic + fz1_tp(i,j,k) = DC(i,k) + enddo + enddo + +4000 continue + return + end subroutine fzppm + + +!------------------------------------------------------------------------------ + + subroutine hilo(q,im,jm,j1,j2,qmax,qmin,bt,bd) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL q(IM,JM),Qmax(IM,JM),Qmin(IM,JM),bt(IM,*),bd(IM,*) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C y-sweep + DO j=j1,j2 + DO i=1,IM + bt(i,j) = max(q(i,j-1),q(i,j),q(i,j+1)) + bd(i,j) = min(q(i,j-1),q(i,j),q(i,j+1)) + enddo + enddo +C +C x-sweep + IM1 = IM-1 + DO j=j1,j2 + DO i=2,IM1 + Qmax(i,j) = max(bt(i-1,j),bt(i,j),bt(i+1,j)) + Qmin(i,j) = min(bd(i-1,j),bd(i,j),bd(i+1,j)) + enddo + enddo +C + DO j=j1,j2 +C i = 1 + Qmax(1,j) = max(bt(IM,j),bt(1,j),bt(2,j)) + Qmin(1,j) = min(bd(IM,j),bd(1,j),bd(2,j)) +C i = IM + Qmax(IM,j) = max(bt(IM1,j),bt(IM,j),bt(1,j)) + Qmin(IM,j) = min(bd(IM1,j),bd(IM,j),bd(1,j)) + enddo +C +C N. Pole: + Pmax = q(1,JM) + Pmin = q(1,JM) + do i=1,IM + if(q(i,j2) .gt. Pmax) then + Pmax = q(i,j2) + elseif(q(i,j2) .lt. Pmin) then + Pmin = q(i,j2) + endif + enddo +C + do i=1,IM + Qmax(i,JM) = Pmax + Qmin(i,JM) = Pmin + enddo +C +C S. Pole: + Pmax = q(1,1) + Pmin = q(1,1) + do i=1,IM + if(q(i,j1) .gt. Pmax) then + Pmax = q(i,j1) + elseif(q(i,j1) .lt. Pmin) then + Pmin = q(i,j1) + endif + enddo +C + do i=1,IM + Qmax(i,1) = Pmax + Qmin(i,1) = Pmin + enddo +C + if(j1 .ne. 2) then + JM1 = JM-1 + do i=1,IM + Qmax(i,2) = Qmax(i,1) + Qmin(i,2) = Qmin(i,1) +C + Qmax(i,JM1) = Qmax(i,JM) + Qmin(i,JM1) = Qmin(i,JM) + enddo + endif + return + end subroutine hilo + +!------------------------------------------------------------------------------ + + subroutine hilo3D(P,im,jm,km,j1,j2,Pmax,Pmin,Qmax,Qmin,bt,bd) +C****6***0*********0*********0*********0*********0*********0**********72 + + ! Added to pass C-preprocessor switches (bmy, 3/9/01) +# include "define.h" + + REAL P(IM,JM,km),Pmax(IM,JM,km),Pmin(IM,JM,km), + & Qmax(IM,JM,km),Qmin(IM,JM,km),bt(im,jm),bd(im,jm) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(P,Qmax,Qmin,im,jm,j1,j2) +CMIC$* private(k,bt,bd) +#else +!$OMP PARALLEL DO PRIVATE( K, BT, BD ) +#endif +#endif + + DO 1000 k=1,km + call hilo(P(1,1,k),im,jm,j1,j2,Qmax(1,1,k),Qmin(1,1,k),bt,bd) +1000 continue + + km1 = km-1 + km2 = km-2 + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(Pmax,Pmin,Qmax,Qmin,im,jm,km,km1,km2) +CMIC$* private(i,j) +#else +!$OMP PARALLEL DO PRIVATE( I, J ) +#endif +#endif + + DO 2000 j=1,jm + DO 2000 i=1,im +C k=1 and k=km + Pmax(i,j, 1) = max(Qmax(i,j, 2),Qmax(i,j, 1)) + Pmin(i,j, 1) = min(Qmin(i,j, 2),Qmin(i,j, 1)) + Pmax(i,j,km) = max(Qmax(i,j,km1),Qmax(i,j,km)) + Pmin(i,j,km) = min(Qmin(i,j,km1),Qmin(i,j,km)) +C k=2 and k=km1 + Pmax(i,j, 2) = max(Qmax(i,j, 3),Pmax(i,j, 1)) + Pmin(i,j, 2) = min(Qmin(i,j, 3),Pmin(i,j, 1)) + Pmax(i,j,km1) = max(Qmax(i,j,km2),Pmax(i,j,km)) + Pmin(i,j,km1) = min(Qmin(i,j,km2),Pmin(i,j,km)) +2000 continue + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(Pmax,Pmin,Qmax,Qmin,im,jm,km,km1,km2) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + DO 3000 k=3,km2 + DO 3000 j=1,jm + DO 3000 i=1,im + Pmax(i,j,k) = max(Qmax(i,j,k-1),Qmax(i,j,k),Qmax(i,j,k+1)) + Pmin(i,j,k) = min(Qmin(i,j,k-1),Qmin(i,j,k),Qmin(i,j,k+1)) +3000 continue + return + end subroutine hilo3D + +!------------------------------------------------------------------------------ + + subroutine lmtppm(DC,A6,AR,AL,P,IM,LMT) +C****6***0*********0*********0*********0*********0*********0**********72 +C +C A6 = CURVATURE OF THE TEST PARABOLA +C AR = RIGHT EDGE VALUE OF THE TEST PARABOLA +C AL = LEFT EDGE VALUE OF THE TEST PARABOLA +C DC = 0.5 * MISMATCH +C P = CELL-AVERAGED VALUE +C IM = VECTOR LENGTH +C +C OPTIONS: +C +C LMT = 0: FULL MONOTONICITY +C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS) +C LMT = 2: POSITIVE-DEFINITE CONSTRAINT +C + PARAMETER ( R12 = 1./12. ) + REAL A6(IM),AR(IM),AL(IM),P(IM),DC(IM) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + if(LMT.eq.0) then +C Full constraint + do 100 i=1,IM + if(DC(i).eq.0.) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + else + da1 = AR(i) - AL(i) + da2 = da1**2 + A6DA = A6(i)*da1 + if(A6DA .lt. -da2) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + elseif(A6DA .gt. da2) then + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif + endif +100 continue + elseif(LMT.eq.1) then +C Semi-monotonic constraint + do 150 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 150 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +150 continue + elseif(LMT.eq.2) then + do 250 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 250 + fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12 + if(fmin.ge.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) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +250 continue + endif + return + end subroutine lmtppm + +!------------------------------------------------------------------------------ + + SUBROUTINE qckxyz(Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp,IC,NSTEP) +C****6***0*********0*********0*********0*********0*********0**********72 + + ! Added to pass C-preprocessor switches (bmy, 3/9/01) +# include "define.h" + + PARAMETER ( tiny = 1.E-30 ) + PARAMETER ( kmax = 200 ) + REAL Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*) + integer IP(kmax) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + NLM1 = NLAY-1 + +C Do horizontal filling. + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* private(i,j,L,qtmp) +#else +!$OMP PARALLEL DO PRIVATE( I, J, L, QTMP ) +#endif +#endif + + do 1000 L=1,NLAY + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ip(L),tiny) + if(ip(L).ne.0) + & call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ip(L),tiny) +1000 continue + + ipz = 0 + do L=1,NLAY + if(ip(L) .ne. 0) then + ipz = L + go to 111 + endif + enddo + return + +111 continue + + if(ipz .eq. 0) return + + if(ipz .eq. 1) then + lpz = 2 + else + lpz = ipz + endif + +C Do vertical filling. + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* private(i,j,L,qup,qly,dup) +#else +!$OMP PARALLEL DO PRIVATE( I, J, L, QUP, QLY, DUP ) +#endif +#endif + + do 2000 j=j1,j2 + + if(ipz .eq. 1) then +C Top layer + do i=1,IMR + if(Q(i,j,1).LT.0.) then + Q(i,j,2) = Q(i,j,2) + Q(i,j,1) + Q(i,j,1) = 0. + endif + enddo + endif + + DO 225 L = lpz,NLM1 + do i=1,IMR + IF( Q(i,j,L).LT.0.) THEN +C From above + qup = Q(i,j,L-1) + qly = -Q(i,j,L) + dup = min(qly,qup) + Q(i,j,L-1) = qup - dup + Q(i,j,L ) = dup-qly +C Below + Q(i,j,L+1) = Q(i,j,L+1) + Q(i,j,L) + Q(i,j,L) = 0. + ENDIF + enddo +225 CONTINUE + +C BOTTOM LAYER + L = NLAY + do i=1,IMR + IF( Q(i,j,L).LT.0.) THEN + +C From above + + qup = Q(i,j,NLM1) + qly = -Q(i,j,L) + dup = min(qly,qup) + Q(i,j,NLM1) = qup - dup + +C From "below" the surface. + Q(i,j,L) = 0. + ENDIF + enddo +2000 continue + + RETURN + END SUBROUTINE qckxyz + +!------------------------------------------------------------------------------ + + subroutine xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + JMR = JNP-1 + do 1309 j=j1,j2 + if(J.GT.JS .and. J.LT.JN) GO TO 1309 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + do i=-IML,0 + qtmp(i) = p(IMR+i,j) + qtmp(IMR+1-i) = p(1-i,j) + enddo +C + DO i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + enddo + + do i=1,IMR + adx(i,j) = adx(i,j) - p(i,j) + enddo +1309 continue + +C Eulerian upwind + + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + qtmp(0) = p(IMR,J) + qtmp(IMR+1) = p(1,J) +C + DO i=1,IMR + IP = i - UA(i,j) + adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1)) + enddo + enddo +C + if(j1.ne.2) then + do i=1,IMR + adx(i, 2) = 0. + adx(i,JMR) = 0. + enddo + endif + +C set cross term due to x-adv at the poles to zero. + do i=1,IMR + adx(i, 1) = 0. + adx(i,JNP) = 0. + enddo + return + end subroutine xadv + +!------------------------------------------------------------------------------ + + subroutine xmist(IMR,IML,P,DC) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C +C 2nd order version. +C + do 10 i=1,IMR + tmp = 0.25*(p(i+1) - p(i-1)) + Pmax = max(P(i-1), p(i), p(i+1)) - p(i) + Pmin = p(i) - min(P(i-1), p(i), p(i+1)) +10 DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp) + return + end subroutine xmist + +!------------------------------------------------------------------------------ + + subroutine xtp(im,jm,IML,j1,j2,JN,JS,PU,DQ,q,C,fx2,xmass,IORD, + & fx1_tp) +C****6***0*********0*********0*********0*********0*********0**********72 + + REAL C(im,*),DC(-IML:im+IML+1),xmass(im,jm), + & fx1(im+1),DQ(im,jm),qtmp(-IML:im+1+IML) + REAL PU(im,jm),q(im,jm) + real fx2(im+1,jm) + INTEGER isave(im) +! bey, 6/20/00. for mass-flux diagnostic + real fx1_tp(im,jm) + +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + IMP = im + 1 +C +C van Leer at high latitudes + jvan = max(1,jm/20) + j1vl = j1+jvan + j2vl = j2-jvan +C + do 1310 j=j1,j2 +C + do i=1,im + qtmp(i) = q(i,j) + enddo +C + if(j.ge.JN .or. j.le.JS) goto 2222 +C****6***0*********0*********0*********0*********0*********0**********72 +C *** Eulerian *** +C****6***0*********0*********0*********0*********0*********0**********72 +C + qtmp(0) = q(im,J) + qtmp(-1) = q(im-1,J) + qtmp(IMP) = q(1,J) + qtmp(IMP+1) = q(2,J) + + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + do i=1,im + iu = float(i) - c(i,j) + fx1(i) = qtmp(iu) + enddo + +C Zero high order contribution + DO i=1,im + fx2(i,j) = 0. + enddo + ELSE + call xmist(im,IML,Qtmp,DC) + DC(0) = DC(im) +C + if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then + DO i=1,im + iu = float(i) - c(i,j) + fx1(i ) = qtmp(iu) + fx2(i,j) = DC(iu)*(sign(1.,c(i,j))-c(i,j)) + enddo + else + call fxppm(im,IML,C(1,j),Qtmp,DC,fx1,fx2(1,j),IORD) + endif +C + ENDIF +C + DO i=1,im + fx1(i ) = fx1(i )*xmass(i,j) + fx2(i,j) = fx2(i,j)*xmass(i,j) + enddo +C + goto 1309 +C +C****6***0*********0*********0*********0*********0*********0**********72 +C *** Conservative (flux-form) Semi-Lagrangian transport *** +C****6***0*********0*********0*********0*********0*********0**********72 + +2222 continue + +C ghost zone for the western edge: + iuw = -c(1,j) + iuw = min(0, iuw) + + do i=iuw, 0 + qtmp(i) = q(im+i,j) + enddo + +C ghost zone for the eastern edge: + iue = imp - c(im,j) + iue = max(imp, iue) + + do i=imp, iue + qtmp(i) = q(i-im,j) + enddo + + if(iord.eq.1 .or. j.eq.j1. or. j.eq.j2) then + do i=1,im + iu = c(i,j) + if(c(i,j) .le. 0.) then + itmp = i - iu + isave(i) = itmp - 1 + else + itmp = i - iu - 1 + isave(i) = itmp + 1 + endif + fx1(i) = (c(i,j)-iu) * qtmp(itmp) + enddo + +C Zero high order contribution + do i=1,im + fx2(i,j) = 0. + enddo + + ELSE + call xmist(im,IML,qtmp,dc) + + do i=iuw, 0 + dc(i) = dc(im+i) + enddo + + do i=imp, iue + dc(i) = dc(i-im) + enddo + + do i=1,im + iu = c(i,j) + rut = c(i,j) - iu + if(c(i,j) .le. 0.) then + itmp = i - iu + isave(i) = itmp - 1 + fx2(i,j) = -rut*dc(itmp)*(1.+rut) + else + itmp = i - iu - 1 + isave(i) = itmp + 1 + fx2(i,j) = rut*dc(itmp)*(1.-rut) + endif + fx1(i) = rut*qtmp(itmp) + enddo + + ENDIF + + do i=1,im + IF(c(i,j).GT.1.) then +CDIR$ NOVECTOR + do ist = isave(i),i-1 + fx1(i) = fx1(i) + qtmp(ist) + enddo + elseIF(c(i,j).LT.-1.) then +CDIR$ NOVECTOR + do ist = i,isave(i) + fx1(i) = fx1(i) - qtmp(ist) + enddo + endif + enddo +CDIR$ VECTOR + do i=1,im + fx1(i) = PU(i,j)*fx1(i) + fx2(i,j) = PU(i,j)*fx2(i,j) + enddo + +1309 fx1(IMP ) = fx1(1 ) + fx2(IMP,j) = fx2(1,j) + +C Update using low order fluxes. + DO i=1,im + + DQ(i,j) = DQ(i,j) + fx1(i)-fx1(i+1) + +! bey, 6/20/00. for mass-flux diagnostic + fx1_tp(i,j) = fx1(i) + enddo + +1310 continue + return + end subroutine xtp + +!------------------------------------------------------------------------------ + + subroutine ymist(IMR,JNP,j1,P,DC) +C****6***0*********0*********0*********0*********0*********0**********72 + PARAMETER ( R24 = 1./24. ) + REAL P(IMR,JNP),DC(IMR,JNP) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C +C 2nd order version for scalars +C + IMH = IMR / 2 + JMR = JNP - 1 +C + do 10 i=1,IMR*(JMR-1) + tmp = 0.25*(p(i,3) - p(i,1)) + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +10 CONTINUE +C +C Poles: +C + if(j1.ne.2) then + do i=1,IMR + DC(i,1) = 0. + DC(i,JNP) = 0. + enddo + else +C Determine slopes in polar caps for scalars! +C + do 20 i=1,IMH +C South + tmp = 0.25*(p(i,2) - p(i+imh,2)) + Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1) + Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2)) + DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp) +C North. + tmp = 0.25*(p(i+imh,JMR) - p(i,JMR)) + Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP) + Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR)) + DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp) +20 continue +C +C Scalars: + do 25 i=imh+1,IMR + DC(i, 1) = - DC(i-imh, 1) + DC(i,JNP) = - DC(i-imh,JNP) +25 continue + endif + return + end subroutine ymist + +!------------------------------------------------------------------------------ + + subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,C,DC2 + & ,ymass,fy1,A6,AR,AL,fy2,JORD, + & fy1_tp) +C****6***0*********0*********0*********0*********0*********0**********72 + + REAL P(IMR,JNP),C(IMR,JNP),ymass(IMR,JNP),fy2(IMR,JNP), + & DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP) + +! bey, 6/20/00. for mass-flux diagnostic + REAL fy1_tp(IMR,JNP) + +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + +C Work array + REAL fy1(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) +C + JMR = JNP - 1 + len = IMR*(J2-J1+2) + + if(JORD.eq.1) then + + DO 1000 i=1,len + JT = float(J1) - C(i,J1) +1000 fy1(i,j1) = p(i,JT) + + DO 1050 i=1,len +1050 fy2(i,j1) = 0. + + else + call ymist(IMR,JNP,j1,P,DC2) +C + if(JORD.LE.0 .or. JORD.GE.3) then + call fyppm(C,P,DC2,fy1,fy2,IMR,JNP,j1,j2,A6,AR,AL,JORD) + else + DO 1200 i=1,len + JT = float(J1) - C(i,J1) + fy1(i,j1) = p(i,JT) +1200 fy2(i,j1) = (sign(1.,C(i,j1))-C(i,j1))*DC2(i,JT) + endif + endif +C + DO 1300 i=1,len + fy1(i,j1) = fy1(i,j1)*ymass(i,j1) +1300 fy2(i,j1) = fy2(i,j1)*ymass(i,j1) +C +!============================================================================= +! This loop had to be extended for the mass-flux diagnostics (bmy, 4/26/00) +! DO 1400 j=j1,j2 +! DO 1400 i=1,IMR +!1400 DQ(i,j) = DQ(i,j) + (fy1(i,j) - fy1(i,j+1)) * acosp(j) +!============================================================================= + DO j=j1,j2 + DO i=1,IMR + DQ(i,j) = DQ(i,j) + (fy1(i,j) - fy1(i,j+1)) * acosp(j) + + ! bey, 6/20/00. for mass-flux diagnostic + fy1_tp(i,j) = fy1(i,j) + ENDDO + ENDDO +C +C Poles + sum1 = fy1(IMR,j1 ) + sum2 = fy1(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + fy1(i,j1 ) + sum2 = sum2 + fy1(i,J2+1) + enddo +C + sum1 = DQ(1, 1) - sum1 * RCAP + sum2 = DQ(1,JNP) + sum2 * RCAP + do i=1,IMR + DQ(i, 1) = sum1 + DQ(i,JNP) = sum2 + enddo +C + if(j1.ne.2) then + do i=1,IMR + DQ(i, 2) = sum1 + DQ(i,JMR) = sum2 + enddo + endif + return + end subroutine ytp + +!------------------------------------------------------------------------------ + + SUBROUTINE PRESS_FIX( FX, FY, NDT, ACOSP, J1 ) +! +!****************************************************************************** +! Subroutine PRESS_FIX is a wrapper for the Pressure fixer DYN0. PRESS_FIX +! takes the mass fluxes in pressure units and converts them to [kg air/s] +! using the correct geometry for TPCORE. (bdf, bmy, 10/11/01, 2/4/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FX (REAL*8 ) : E-W flux passed from TPCORE [mb/timestep] +! (2 ) FY (REAL*8 ) : N-S flux passed from TPCORE [mb/timestep] +! (3 ) NDT (INTEGER) : Dynamic timestep for TPCORE [s] +! (4 ) ACOSP (REAL*8 ) : Array of inverse cosines [unitless] +! (5 ) J1 (INTEGER) : TPCORE polar cap extent [# of boxes] +! +! NOTES: +! (1 ) Adapted from original code from LLNL. Added comments and F90 syntax +! for declarations. (bdf, bmy, 10/11/01) +! (2 ) For now, assumes that JGLOB=JJPAR, and DXYP(J) is equivalent to +! DXYP(J+J0). (bmy, 10/11/01) +! (3 ) Now declare DXYP as a local array, and initialize it with calls +! to routine GET_AREA_M2 of "grid_mod.f". Now use function GET_TS_DYN +! from "time_mod.f". Remove reference to CMN header file. (bmy, 2/4/03) +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_AREA_M2 + USE TIME_MOD, ONLY : GET_TS_DYN + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic switches +# include "CMN_GCTM" ! g0_100 + + ! Arguments + INTEGER, INTENT(IN) :: NDT, J1 + REAL*8, INTENT(IN) :: ACOSP(JJPAR) + REAL*8, INTENT(INOUT) :: FX(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(INOUT) :: FY(IIPAR,JJPAR,LLPAR) + + ! Local variables + INTEGER :: I, J, J2, K, K2, L + REAL*8 :: DTC, DTDYN, NSDYN, SUM1, SUM2 + REAL*8 :: NP_FLUX(IIPAR,LLPAR) + REAL*8 :: SP_FLUX(IIPAR,LLPAR) + REAL*8 :: ALFA(IIPAR+1,JJPAR,LLPAR) + REAL*8 :: BETA(IIPAR,JJPAR+1,LLPAR) + REAL*8 :: GAMA(IIPAR,JJPAR,LLPAR+1) + REAL*8 :: UMFLX(IIPAR,JJPAR,LLPAR) + REAL*8 :: VMFLX(IIPAR,JJPAR,LLPAR) + + ! Local SAVEd variables + LOGICAL, SAVE :: FIRST = .TRUE. + REAL*8, SAVE :: DXYP(JJPAR) + + !================================================================= + ! PRESS_FIX begins here! + ! + ! K is the vertical index down from the atmosphere top downwards + ! K2 is the vertical index up from the surface + !================================================================= + + ! Initialize arrays + ALFA = 0d0 + BETA = 0d0 + GAMA = 0d0 + + ! NSDYN is the dynamic time step in seconds + NSDYN = GET_TS_DYN() * 60d0 + + ! J2 is the south polar edge + J2 = JJPAR - J1 + 1 + + ! DTDYN = double precision value for NDT, the dynamic timestep + DTDYN = DBLE( NDT ) + + ! Save grid box surface areas [m2] into the local DXYP array + IF ( FIRST ) THEN + DO J = 1, JJPAR + DXYP(J) = GET_AREA_M2( J ) + ENDDO + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + !================================================================= + ! FX is the E-W mass flux from TPCORE in [mb/timestep]. + ! UMFLX is the mass flux in [kg air/s], which is what DYN0 needs. + ! + ! FY is the E-W mass flux from TPCORE in [mb/timestep]. + ! VMFLX is the mass flux in [kg air/s], which is what DYN0 needs. + ! + ! The unit conversion from [mb/timestep] to [kg air/s] is: + ! + ! mb | 100 Pa | 1 kg air | s^2 | step | DXYP m^2 kg air + ! ------+--------+----------+-------+--------+---------- = ------- + ! step | mb | Pa m s^2 | 9.8 m | DTDYN s| s s + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K, K2, DTC ) + DO K = 1, LLPAR + K2 = LLPAR - K + 1 + + ! Compute UMFLX from FX + DO J = 1, JJPAR + DO I = 1, IIPAR + UMFLX(I,J,K2) = FX(I,J,K) * ( G0_100 * DXYP(J) ) / DTDYN + ENDDO + ENDDO + + ! Compute VMFLX from FY + DO I = 1, IIPAR + DO J = J1, J2+1 + IF ( FY(I,J,K) .GE. 0 ) THEN + DTC = FY(I,J,K) * G0_100 * ACOSP(J) * DXYP(J) / DTDYN + ELSE + DTC = FY(I,J,K) * G0_100 * ACOSP(J-1)* DXYP(J-1) / DTDYN + ENDIF + + VMFLX(I,J,K2) = DTC + ENDDO + ENDDO + + !================================================================= + ! TREATMENT OF THE POLES: 1 + ! copy ymass values strait into vmflx at poles for pressure fixer + !================================================================= + DO I = 1, IIPAR + VMFLX(I,1,K2) = FY(I,1,K) + VMFLX(I,J1-1,K2) = FY(I,J1-1,K) + VMFLX(I,JJPAR,K2) = FY(I,JJPAR,K) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + DO K = 1, LLPAR + + !================================================================= + ! TREATMENT OF THE POLES: 2 + ! North polar cap: J=1 + !================================================================= + SUM1 = FY(IIPAR,J1,K) + DO I = 1, IIPAR-1 + SUM1 = SUM1 + FY(I,J1,K) + ENDDO + + ! NORTH POLE FLUX IN KG. + DO I = 1, IIPAR + NP_FLUX(I,K) = SUM1 * G0_100 * ACOSP(1) * DXYP(1) + ENDDO + + !============================================================== + ! TREATMENT OF THE POLES: 3 + ! South polar cap: J=JJPAR + !============================================================== + SUM2 = FY(IIPAR,J2+1,K) + DO I = 1, IIPAR-1 + SUM2 = SUM2 + FY(I,J2+1,K) + ENDDO + + DO I = 1, IIPAR + SP_FLUX(I,K) = SUM2 * G0_100 * ACOSP(JJPAR) * DXYP(JJPAR) + ENDDO + ENDDO + + !================================================================= + ! Call DYN0 to fix the pressures + !================================================================= + CALL DYN0( NSDYN, J1, NP_FLUX, SP_FLUX, + & UMFLX, VMFLX, ALFA, BETA, GAMA ) + + !================================================================= + ! ALFA is the E-W mass flux adjusted by DYN0 in [kg air/s] + ! FX is the E-W mass flux for TPCORE in [mb/timestep]. + ! + ! BETA is the N-S mass flux adjusted by DYN0 in [kg air/s] + ! FY is the E-W mass flux for TPCORE in [mb/timestep]. + ! + ! The unit conversion from to [kg air/s] to [mb/timestep] is: + ! + ! kg air | Pa m s^2 | 9.8 m | 1 | DTDYN s | mb mb + ! --------+----------+-------+----------+---------+------- = ---- + ! s | 1 kg air | s^2 | DXYP m^2 | step | 100 Pa step + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K, K2 ) + DO K = 1, LLPAR + K2 = LLPAR - K + 1 + + ! Update FX from ALFA + DO J = 1, JJPAR + DO I = 1, IIPAR + FX(I,J,K) = ALFA(I,J,K2) * DTDYN / ( G0_100 * DXYP(J) ) + ENDDO + ENDDO + + ! Update FY from BETA + DO I = 1, IIPAR + DO J = J1, J2+1 + IF ( BETA(I,J,K) .GE. 0 ) THEN + FY(I,J,K) = BETA(I,J,K2) * DTDYN / + & ( G0_100 * ACOSP(J) * DXYP(J) ) + ELSE + FY(I,J,K) = BETA(I,J,K2) * DTDYN / + & ( G0_100 * ACOSP(J-1) * DXYP(J-1) ) + ENDIF + ENDDO + ENDDO + + ! Special treatment of BETA at the poles + DO I = 1, IIPAR + FY(I,1,K) = BETA(I,1,K2) + FY(I,J1-1,K) = BETA(I,J1-1,K2) + FY(I,JJPAR,K) = BETA(I,JJPAR,K2) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE PRESS_FIX + +!------------------------------------------------------------------------------ + + SUBROUTINE DYN0( DTWIND, J1, NP_FLUX, SP_FLUX, + & UMFLX, VMFLX, ALFA, BETA, GAMA ) +! +!****************************************************************************** +! Subroutine DYN0 is the pressure fixer for TPCORE. DYN0 readjusts the +! mass fluxes ALFA, BETA, GAMA, so that they are consistent with the +! met fields. (bdf, bmy, 10/11/01, 7/20/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) DTWIND (REAL*8 ) : Time step between wind intervals [s] +! (2 ) J1 (INTEGER) : TPCORE polar cap width +! (4 ) NP_FLUX (REAL*8 ) : North polar flux (from PRESS_FIX) in [kg] +! (5 ) SP_FLUX (REAL*8 ) : South polar flux (from PRESS_FIX) in [kg] +! (6 ) UMFLX (REAL*8 ) : Wet air mass flux in E-W direction [kg air/s] +! (7 ) VMFLX (REAL*8 ) : Wet air mass flux in N-S direction [kg air/s] +! (8 ) ALFA (REAL*8 ) : Dry air mass flux in E-W direction [kg air/s] +! (9 ) BETA (REAL*8 ) : Dry air mass flux in N-S direction [kg air/s] +! (10) GAMA (REAL*8 ) : Dry air mass flux in up/down direction [kg air/s] +! +! Arguments as Output: +! ============================================================================ +! (8 ) ALFA (REAL*8 ) : ALFA air mass, after pressure fix is applied +! (9 ) BETA (REAL*8 ) : BETA air mass, after pressure fix is applied +! (10) GAMA (REAL*8 ) : GAMA air mass, after pressure fix is applied +! +! NOTES: +! (1 ) Adapted from original code from LLNL. Added comments and F90 syntax +! for declarations. (bdf, bmy, 10/10/01) +! (2 ) For a global run (as we usually do in GEOS-CHEM) IM=ID=IIPAR and +! JM=JD=JJPAR. (bmy, 10/10/01) +! (3 ) For now, assumes that JGLOB=JJPAR, and DXYP(J) is equivalent to +! DXYP(J+J0). (bmy, 10/11/01) +! (4 ) Rename AD to AD_L so as not to conflict with the AD array in +! the header file "CMN" (bmy, 10/11/01) +! (5 ) Now reference PSC2 instead of PS from "dao_mod.f". Replace all +! instances of PS with PSC2. Updated comments. (bdf, bmy, 4/1/02) +! (6 ) Removed obsolete code from 4/1/02 (bdf, bmy, 8/22/02) +! (7 ) Now declare DXYP as a local array, and initialize it with calls +! to routine GET_AREA_M2 and GET_YOFFSET of "grid_mod.f". Now also +! references GET_BP from "pressure_mod.f" (bmy, 2/11/03) +! (8 ) Removed reference to CMN (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : SPHU, PSC2, AIRDEN, AIRVOL + USE GRID_MOD, ONLY : GET_AREA_M2, GET_YOFFSET + USE PRESSURE_MOD, ONLY : GET_BP + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: J1 + REAL*8, INTENT(IN) :: DTWIND + REAL*8, INTENT(IN) :: NP_FLUX(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: SP_FLUX(IIPAR,LLPAR) + REAL*8, INTENT(IN) :: UMFLX(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: VMFLX(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(INOUT) :: ALFA(IIPAR+1,JJPAR,LLPAR) + REAL*8, INTENT(INOUT) :: BETA(IIPAR,JJPAR+1,LLPAR) + REAL*8, INTENT(INOUT) :: GAMA(IIPAR,JJPAR,LLPAR+1) + + ! Local variables + LOGICAL :: LSP, LNP, LEW + INTEGER :: IIX, JJX, KM, JB, JE, IEPZ, IMZ + INTEGER :: I, J, J2, K, L + REAL*8 :: ALFAX, UFILT, VFILT, PCTM8, G100 + REAL*8 :: AIRQAV, AWE, SUMAD0, SUMAW0, AIRWET + REAL*8 :: AIRH2O, AIRQKG ,SUM1, SUMA, SUMP, SUMQ + REAL*8 :: SUMU, SUMV, SUMW, ZIMZ, ZDTW, G0 + REAL*8 :: AD_L(IIPAR,JJPAR,LLPAR) + REAL*8 :: AIRD(IIPAR,JJPAR,LLPAR) + REAL*8 :: AIRNEW(IIPAR,JJPAR,LLPAR) + REAL*8 :: AIRX(IIPAR,JJPAR,LLPAR) + REAL*8 :: AX(IIPAR+1,JJPAR) + REAL*8 :: BX(IIPAR,JJPAR+1) + REAL*8 :: MERR(IIPAR,JJPAR) + REAL*8 :: PCTM(IIPAR,JJPAR) + REAL*8 :: PERR(IIPAR,JJPAR) + REAL*8 :: SPHU_KG(IIPAR,JJPAR,LLPAR) + REAL*8 :: SUMAQ(IIPAR,JJPAR) + REAL*8 :: XYB(IIPAR,JJPAR) + REAL*8 :: XYZB(IIPAR,JJPAR,LLPAR) + + ! Local saved variables + LOGICAL, SAVE :: FIRST = .TRUE. + REAL*8, SAVE :: DXYP(JJPAR) + REAL*8, SAVE :: DSIG(LLPAR) + + !================================================================= + ! DYN0 begins here! + ! + ! UNITS OF AIR MASS AND TRACER = (kg) + ! + ! Air mass (kg) is given by: + ! area (m^2) * pressure thickness (Pa) / g0 + ! + ! DXYP(J) = area of [I,J] [m^2] (is longitude-symmetric) + ! + ! PSC2(I,J) = surf pressure [Pa] averaged in extended zone. + ! this is the surface pressure at the end of the + ! current dynamic timestep, passed to TPCORE. + ! + ! SPHU_KG(I,J,K) = specific humidity of grid box + ! [kg H2O/kg wet air] averaged in extended zone. + ! + ! AIRQKG(I,J) = Mass of H2O [kg] at each level + ! = PS(I,J)) * SPHU_KG(I,J,K) + ! + ! AIRD(I,J,K) = dry-air mass [kg] in each box as calculated + ! in CTM at the beginning of each time step, + ! updated at end of DYN0. + ! + ! PCTM(I,J) = inferred wet-air (total) surf press [Pa] calc. + ! in CTM (using SUMAQ & AIRD-X-NEW) + ! + ! AIRNEW(I,J,K) = new dry-air mass in each CTM box after + ! horizontal divergence (ALFA+BETA) over time + ! step DTWIND (sec) + ! + ! AIRX(I,J,K) = expected dry-air mass in each CTM box after + ! calculating the vertical divergence (GAMA) + ! (also used for GCM dry mass) + ! = XYZA(I,J,K) + XYZB(I,J,K)*PCTM(I,J) - AIRQKG + ! + ! DTWIND = time step [s] that applies to the averaged + ! wind fields (i.e., the time between successive + ! pressures. + ! + !----------------------------------------------------------------- + ! + ! Assume that we have "wet-air" mass fluxes across each boundary + ! + ! UMFLX(I,J,K) ==> [I,J,K] ==> UMFLX(I+1,J,K) [kg air/s] + ! VMFLX(I,J,K) ==> [I,J,K] ==> VMFLX(I,J+1,K) [kg air/s] + ! + ! Convert to "dry-air" mass flux in/out of box using + ! average Q at boundary + ! + ! ALFA(I,J,K) ==> [I,J,K] ==> ALFA(I+1,J,K) [kg air/s] + ! BETA(I,J,K) ==> [I,J,K] ==> BETA(I,J+1,K) [kg air/s] + ! + ! Calculate convergence in each layer of dry air, compare with + ! expected dry air mass (AIRX) and then calculate vertical + ! dry-mass fluxes + ! + ! GAMA(I,J,K) ==> [I,J,K] ==> GAMA(I,J,K+1) [kg air/s] + ! + ! Horizontal pressure filter adjusts UMFLX & VMFLX to reduce + ! error in [PCTM - PSC2] + ! + ! UMFLX + pressure filter ==> UMFLX#, + ! VMFLX + filter ==> VMFLX# (temporary) + ! + ! The pressure filter does nearest neighbor flux + ! (adjusting ALFA/BETA) + ! + !----------------------------------------------------------------- + ! + ! Note that K->K+1 is downward (increasing pressure) and + ! that boundaries: + ! GAMA(I,J,1) = GAMA(I,J,KM+1) = 0 no flux across + ! upper/lower boundaries + ! + ! BETA(I,1,K) = BETA(I,JJPAR+1,K) = 0 no flux at S & N poles + ! + ! ALFA(1,J,K) = ALFA(IIPAR+1,J,K) is NOT ZERO, but cyclic + ! + ! Dimensions for ALFA, BETA, GAMA are extended by +1 beyond grid + ! to allow simple formulation of fluxes in/out of final grid box. + ! + ! GCM input UMFLX,VMFLX,PSG is ALWAYS of GLOBAL dimensions + ! (IIPAR x JJPAR x LLPAR) + ! + ! Indices of ALFA, BETA, GAMA, SPHU_KG & PSC2 are always LOCAL + ! (IIPAR x JJPAR x KM): FOR GEOS-CHEM, KM = LLPAR (bmy + ! + ! Indices of tracer (STT), and diagnostics are local + ! (w.r.t. WINDOW. WINDOW calculations are defined by an + ! offset and size + ! + ! I0 .ge.0 and IIPAR+I0 .le. IIPAR + ! J0 .ge.0 and JJPAR+J0 .le. JJPAR + ! K0 .ge.0 and KM+K0 .le. LLPAR + ! + ! The WINDOW calculation must allow for a boundary layer + ! of grid boxes: + ! + ! IG(abs. coords) = IW(in window) + I0 + ! JG(abs. coords) = JW(in window) + J0 + ! KG(abs. coords) = KW(in window) + K0 + ! + ! vertical window (NEW) allows for an upper boundary with flow + ! across it and specified mixing ratio b.c.'s at KG = K0 + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + + ! Surface area [m2] + DO J = 1, JJPAR + DXYP(J) = GET_AREA_M2( J ) + ENDDO + + ! Sigma-level thickness [unitless] + ! Assumes we are using a pure-sigma grid + DO L = 1, LLPAR + DSIG(L) = GET_BP(L) - GET_BP(L+1) + ENDDO + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + ! for tpcore poles. + J2 = JJPAR - J1 + 1 + + ! geos code + G0 = 9.8d0 + + !================================================================= + ! XYZB is the factor needed to get mass in kg of gridbox + ! mass (kg) = XYZB (kg/mb) * P (mb) + ! + ! AD_L is the dry air mass in the grid box + ! + ! SPHU_KG is the water vapor [kg H2O/kg air] + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + XYZB(I,J,L) = DSIG(L) * DXYP(J) * 1.d2 / G0 + AD_L(I,J,L) = AIRDEN(L,I,J) * AIRVOL(I,J,L) + SPHU_KG(I,J,L) = SPHU(I,J,L) / 1000d0 + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! XYB is the factor needed to get mass in kg of column + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + XYB(I,J) = SUM( XYZB(I,J,1:LLPAR) ) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Define other variables + !================================================================= + G100 = 100.D0 / G0 + ZDTW = 1.D0 / DTWIND + LSP = ( GET_YOFFSET() .EQ. 0 ) + LNP = ( JJPAR + GET_YOFFSET() .EQ. JJPAR ) + LEW = ( IIPAR .EQ. IIPAR ) + + !================================================================= + ! Initialize ALFA with UMFLX and BETA with VMFLX + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1,IIPAR + ALFA(I,J,L) = UMFLX(I,J,L) + ENDDO + + ALFA(IIPAR+1,J,L) = ALFA(1,J,L) + ENDDO + + DO J = 2, JJPAR + DO I = 1, IIPAR + BETA(I,J,L) = VMFLX(I,J,L) + ENDDO + + DO I = 1, IIPAR + BETA(I,1,L) = 0.D0 + BETA(I,JJPAR+1,L) = 0.D0 + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! SUMAQ(I,J): column integral of water (kg) + ! Check on air mass + !================================================================= + SUMAD0 = 0.D0 + SUMAW0 = 0.D0 + + DO J = 1, JJPAR + DO I = 1, IIPAR + SUMAQ(I,J) = 0.D0 + + DO K = 1, LLPAR + AIRWET = PSC2(I,J) * XYZB(I,J,K) + AIRH2O = SPHU_KG(I,J,K) * AIRWET + SUMAQ(I,J) = SUMAQ(I,J) + AIRH2O + SUMAD0 = SUMAD0 + AIRWET + SUMAW0 = SUMAW0 + AIRH2O + ENDDO + ENDDO + ENDDO + + SUMAD0 = SUMAD0 - SUMAW0 + + !================================================================= + ! Initialize AIRD, the dry-air mass [kg] in each box as calculated + ! in CTM at the start of each time step, updated at end of DYN0. + ! + ! Compute AIRNEW, the new dry-air mass in each CTM box after + ! horizontal divergence (ALFA+BETA) over time step DTWIND (sec) + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K ) + DO K = 1, LLPAR + DO J = J1, J2 + DO I = 1, IIPAR + AIRD(I,J,K) = AD_L(I,J,K) + AIRNEW(I,J,K) = AIRD(I,J,K) + DTWIND * + & ( ALFA(I,J,K) - ALFA(I+1,J,K) + + & BETA(I,J,K) - BETA(I,J+1,K) ) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! treatment of the poles for tpcore. + ! j=2 and j=jjpar-1 don't have any airmass change. + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, K ) + DO K = 1, LLPAR + + ! J=1 + DO I = 1, IIPAR + AIRNEW(I,1,K) = AD_L(I,1,K) - NP_FLUX(I,K) + ENDDO + + ! J=JJPAR + DO I = 1, IIPAR + AIRNEW(I,JJPAR,K) = AD_L(I,JJPAR,K) + SP_FLUX(I,K) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Average AIRNEW at the South pole + !================================================================= + ZIMZ = 1.D0 / DBLE( IIPAR ) + + IF ( LSP ) THEN + JB = 2 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, K, SUMA ) + DO K = 1, LLPAR + SUMA = SUM( AIRNEW(1:IIPAR,1,K) ) * ZIMZ + + DO I = 1, IIPAR + AIRNEW(I,1,K) = SUMA + ENDDO + ENDDO +!$OMP END PARALLEL DO + ELSE + JB = 1 + ENDIF + + !================================================================= + ! Average AIRNEW at the North pole + !================================================================= + IF ( LNP ) THEN + JE = JJPAR - 1 + + ! poles, just average AIRNEW +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, K, SUMA ) + DO K = 1, LLPAR + SUMA = SUM( AIRNEW(1:IIPAR,JJPAR,K) ) * ZIMZ + + DO I = 1, IIPAR + AIRNEW(I,JJPAR,K) = SUMA + ENDDO + ENDDO +!$OMP END PARALLEL DO + ELSE + JE = JJPAR + ENDIF + + !================================================================ + ! BEGIN FILTER of PRESSURE ERRORS + ! + ! Define the error in surface pressure PERR expected at end of + ! time step filter by error in adjacent boxes, weight by areas, + ! adjust ALFA & BETA + ! + ! PCTM(I,J) = new CTM wet-air column based on + ! dry-air convergence (Pascals) + ! PERR(I,J) = pressure-error between CTM-GCM at new time + ! (before filter) + !================================================================ +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + PCTM(I,J) = SUM( AIRNEW(I,J,:) ) / XYB(I,J) + + ! special case for j=2, jjpar-1 for tpcore pole configuration. + IF ( J .eq. 2 .OR. J .eq. JJPAR-1 ) THEN + PCTM(I,J) = PSC2(I,J) + ENDIF + + PERR(I,J) = PCTM(I,J) - PSC2(I,J) + MERR(I,J) = PERR(I,J) * DXYP(J) * G100 + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Call pressure filter + CALL PFILTR( MERR, AX, BX, DXYP, IIPAR, JJPAR, + & IIPAR, JJPAR, 1, LSP, LNP, LEW ) + + !================================================================= + ! Calculate corrections to ALFA from the filtered AX + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, IIX, J, K, UFILT ) + DO J = JB, JE + DO I = 1, IIPAR+1 + IIX = MIN(I,IIPAR) + UFILT = AX(I,J) / ( XYB(IIX,J) * DTWIND ) + + DO K = 1, LLPAR + ALFA(I,J,K) = ALFA(I,J,K) + UFILT * XYZB(IIX,J,K) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Calculate corrections to BETA from the filtered BX + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, JJX, K, VFILT ) + DO J = 1, JJPAR+1 + JJX = J + IF ( J+J .gt. JJPAR ) JJX = J - 1 + + DO I = 1, IIPAR + VFILT = BX(I,J) / ( XYB(I,JJX) * DTWIND ) + + DO K = 1, LLPAR + BETA(I,J,K) = BETA(I,J,K) + VFILT * XYZB(I,JJX,K) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Calculate the corrected AIRNEW's & PCTM after P-filter: + ! has changed ALFA+BETAs and ctm surface pressure (PCTM) + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K ) + DO K = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + AIRNEW(I,J,K) = AIRD(I,J,K) + DTWIND * + & ( ALFA(I,J,K) - ALFA(I+1,J,K) + + & BETA(I,J,K) - BETA(I,J+1,K) ) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Average the adjusted AIRNEW at the South pole + !================================================================= + ZIMZ = 1.D0 / DBLE( IIPAR ) + + IF ( LSP ) THEN + JB = 2 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, K, SUMA ) + DO K = 1, LLPAR + SUMA = SUM( AIRNEW(1:IIPAR,1,K ) ) * ZIMZ + + DO I = 1, IIPAR + AIRNEW(I,1,K) = SUMA + ENDDO + ENDDO +!$OMP END PARALLEL DO + ELSE + JB = 1 + ENDIF + + !================================================================= + ! Average the adjusted AIRNEW at the North pole + !================================================================= + IF ( LNP ) THEN + JE = JJPAR -1 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, K, SUMA ) + DO K = 1, LLPAR + SUMA = SUM( AIRNEW(1:IIPAR,JJPAR,K) ) * ZIMZ + + DO I = 1,IIPAR + AIRNEW(I,JJPAR,K) = SUMA + ENDDO + ENDDO +!$OMP END PARALLEL DO + ELSE + JE = JJPAR + ENDIF + + !================================================================= + ! END OF PRESSURE FILTER + ! + ! GAMA: redistribute the new dry-air mass consistent with the + ! new CTM surface pressure, rigid upper b.c., no change in PCTM + ! + ! AIRX(I,J,K) = dry-air mass expected, based on PCTM + ! PCTM(I,J) & PERR(I,J) + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K, PCTM8, AIRQKG ) + DO J = 1, JJPAR + DO I = 1, IIPAR + PCTM8 = ( SUM( AIRNEW(I,J,:) ) + SUMAQ(I,J) ) / XYB(I,J) + PCTM(I,J) = PCTM8 + PERR(I,J) = PCTM8 - PSC2(I,J) + + DO K = 1, LLPAR + AIRQKG = SPHU_KG(I,J,K) * ( XYZB(I,J,K) * PSC2(I,J) ) + AIRX(I,J,K) = PCTM8 * XYZB(I,J,K) - AIRQKG + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! GAMA from top down to be consistent with AIRX, AIRNEW not reset! + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K ) + DO J = 1, JJPAR + DO I = 1, IIPAR + GAMA(I,J,LLPAR+1) = 0.D0 + + DO K = LLPAR, 2, -1 + GAMA(I,J,K) = GAMA(I,J,K+1) - (AIRNEW(I,J,K) - AIRX(I,J,K)) + ENDDO + + ! GAMA(I,J,1) will not be exactly ZERO, but it must be set so! + GAMA(I,J,1) = 0.D0 + + DO K = 2, LLPAR + GAMA(I,J,K) = GAMA(I,J,K) * ZDTW + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE DYN0 + +!------------------------------------------------------------------------------ + + SUBROUTINE PFILTR( MERR, ALFAX, BETAX, AXY, ID, JD, + & IM, JM, NITR, LSP, LNP, LEW ) +! +!****************************************************************************** +! Subroutine PFILTR applies the pressure-filter, the pressure +! between predicted Ps(CTM) and Ps(GCM). (bdf, bmy, 10/11/01) +! +! Arguments as Input: +! ============================================================================ +! (1 ) MERR(ID,JD) (REAL*8 ) : mass error +! (2 ) ALFAX(ID+1,JD) (REAL*8 ) : perturbed ALFA by MERR +! (3 ) BETAX(ID,JD+1) (REAL*8 ) : perturbed BETA by MERR +! (4 ) AXY(ID,JD) (REAL*8 ) : area of grid box (I,J) in [m^2] +! (5-6) ID, JD (INTEGER) : "Global" array dimensions for lon, lat +! (7-8) IM, JM (INTEGER) : "Window" array dimensions for lon, lat +! (9 ) NITR (INTEGER) : number of iterations (NITR .LE. 4) +! (10 ) LSP (LOGICAL) : true if J=1 is S. POLE +! (11 ) LNP (LOGICAL) : true if J=JM is N. POLE +! (12 ) LEW (LOGICAL) : true if cyclic in W-E direction +! (i.e. if I=1 connects to I=IM) +! +! Arguments as Output: +! ============================================================================ +! (1 ) MERR(ID,JD) (REAL*8 ) : adjusted mass error +! (2 ) ALFAX(ID+1,JD) (REAL*8 ) : adjusted ALFAX +! (3 ) BETAX(ID,JD+1) (REAL*8 ) : adjusted BETAX +! +! NOTES: +! (1 ) Adapted from original code from LLNL. Added comments and F90 syntax +! for declarations. (bdf, bmy, 10/1/01) +! (2 ) For a global run (as we usually do in GEOS-CHEM) IM=ID=IIPAR and +! JM=JD=JJPAR. (bmy, 10/11/01) +! (3 ) Removed IMEPZ -- we don't need this for GEOS-CHEM. (bmy, 10/18/01) +!****************************************************************************** +! + IMPLICIT NONE + + ! Arguments + LOGICAL, INTENT(IN) :: LSP,LNP,LEW + INTEGER, INTENT(IN) :: ID, JD, IM, JM, NITR + REAL*8, INTENT(IN) :: AXY(JD) + REAL*8, INTENT(INOUT) :: MERR(ID,JD) + REAL*8, INTENT(INOUT) :: ALFAX(ID+1,JD) + REAL*8, INTENT(INOUT) :: BETAX(ID,JD+1) + + ! Local variables + LOGICAL :: LPOLE + INTEGER :: I, J, K + REAL*8 :: X0(ID,JD) + + !================================================================= + ! PFILTR begins here! + !================================================================= + + ! LPOLE is true if J=1 is the SOUTH POLE and J=JM is the NORTH POLE + ! (this is the way GEOS-CHEM is set up, so LPOLE should be TRUE!) + LPOLE = ( LSP .AND. LNP ) + + ! Zero ALFAX, BETAX, save MERR in X0 + DO J = 1, JM + DO I = 1, IM + ALFAX(I,J) = 0.D0 + BETAX(I,J) = 0.D0 + X0(I,J) = MERR(I,J) + ENDDO + + ALFAX(IM+1,J) = 0.D0 + ENDDO + + DO I = 1, IM + BETAX(I,JM+1) = 0.D0 + ENDDO + + !================================================================= + ! Call LOCFLT to do the local filtering + !================================================================= + CALL LOCFLT( MERR, ALFAX, BETAX, AXY, ID, JD, + & IM, JM, 5, LSP, LNP, LEW ) + + !================================================================= + ! Call POLFLT to do the pole filtering (if necessary) + !================================================================= + IF ( LPOLE ) THEN + CALL POLFLT( MERR, BETAX, AXY, 1.D0, ID, JD, IM, JM ) + ENDIF + + !================================================================= + ! Compute mass error MERR and return + ! MERR, ALFAX, and BETAX are now adjusted + !================================================================= + DO J = 1, JM + DO I = 1, IM + MERR(I,J) = X0(I,J) + ALFAX(I,J) - ALFAX(I+1,J) + & + BETAX(I,J) - BETAX(I,J+1) + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE PFILTR + +!------------------------------------------------------------------------------ + + SUBROUTINE LOCFLT( XERR, AX, BX, AXY, ID, JD, + & IM, JM, NITR, LSP, LNP, LEW ) +! +!****************************************************************************** +! Subroutine LOCFLT applies the pressure-filter to non-polar boxes. +! LOCFLT is called from subroutine PFILTR above (bdf, bmy, 10/11/01) +! +! Arguments as Input: +! ============================================================================ +! (1 ) XERR(ID,JD) (REAL*8 ) : mass error +! (2 ) AX(ID+1,JD) (REAL*8 ) : perturbed ALFA by XERR +! (3 ) BX(ID,JD+1) (REAL*8 ) : perturbed BETA by XERR +! (4 ) AXY(ID,JD) (REAL*8 ) : area of grid box (I,J) in [m^2] +! (5-6) ID, JD (INTEGER) : "Global" array dimensions for lon, lat +! (7-8) IM, JM (INTEGER) : "Window" array dimensions for lon, lat +! (9 ) NITR (INTEGER) : number of iterations (NITR .LE. 4) +! (10 ) LSP (LOGICAL) : true if J=1 is S. POLE +! (11 ) LNP (LOGICAL) : true if J=JM is N. POLE +! (12 ) LEW (LOGICAL) : true if cyclic in W-E direction +! (i.e. if I=1 connects to I=IM) +! +! Arguments as Output: +! ============================================================================ +! (1 ) XERR(ID,JD) (REAL*8 ) : adjusted mass error +! (2 ) AX(ID+1,JD) (REAL*8 ) : adjusted AX +! (3 ) BX(ID,JD+1) (REAL*8 ) : adjusted BX +! +! NOTES: +! (1 ) Adapted from original code from LLNL. Added comments and F90 syntax +! for declarations. (bdf, bmy, 10/11/01) +! (2 ) For a global run (as we usually do in GEOS-CHEM) IM=ID=IIPAR and +! JM=JD=JJPAR. (bmy, 10/11/01) +!****************************************************************************** +! + IMPLICIT NONE + + ! Arguments + LOGICAL, INTENT(IN) :: LSP, LNP, LEW + INTEGER, INTENT(IN) :: ID, JD, IM, JM, NITR + REAL*8, INTENT(IN) :: AXY(JD) + REAL*8, INTENT(INOUT) :: XERR(ID,JD) + REAL*8, INTENT(INOUT) :: AX(ID+1,JD) + REAL*8, INTENT(INOUT) :: BX(ID,JD+1) + + ! Local variables + INTEGER :: I, IA, NAZ, J, J1, J2, NFLTR + REAL*8 :: SUMA, FNAZ8 + REAL*8 :: X0(ID,JD) + + !================================================================= + ! LOCFLT begins here! + ! + ! Initialize corrective column mass flows (kg): AX->alfa, BX->beta + !================================================================= + DO J = 1, JM + DO I = 1, IM + X0(I,J) = XERR(I,J) + ENDDO + ENDDO + + !================================================================= + ! Iterate over mass-error filter + ! accumulate corrections in AX & BX + !================================================================= + DO NFLTR = 1, NITR + + !============================================================== + ! calculate AX = E-W filter + !============================================================== + + ! Compute polar box limits + J1 = 1 + J2 = JM + IF ( LSP ) J1 = 2 + IF ( LNP ) J2 = JM - 1 + + ! Loop over non-polar latitudes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, FNAZ8 ) + DO J = J1, J2 + + ! Calculate pressure-filter E-W wind between boxes [I-1] & [I]. + ! Enhance filtered wind by size of EPZ, will redistribute + ! later within + FNAZ8 = 0.125d0 + + DO I = 2, IM + AX(I,J) = AX(I,J) + FNAZ8 *(XERR(I-1,J) - XERR(I,J)) + ENDDO + + ! calculate pressure-filter E-W wind at edges I=1 & I=IM+1 + IF ( LEW ) THEN + AX(IM+1,J) = AX(IM+1,J) + FNAZ8 * (XERR(IM,J) -XERR(1,J)) + AX(1,J) = AX(1,J) + FNAZ8 * (XERR(IM,J) -XERR(1,J)) + ELSE + ! WINDOW, assume zero error outside window + AX(1,J) = AX(1,J) - FNAZ8 * XERR(1,J) + AX(IM+1,J)= AX(IM+1,J) + FNAZ8 * XERR(IM,J) + ENDIF + ENDDO +!$OMP END PARALLEL DO + + !============================================================== + ! calculate BX = N-S filter, N-S wind between boxes [J-1] & [J] + !============================================================== +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, FNAZ8 ) + DO J = 3, JM-1 + FNAZ8 = 0.25D0 * AXY(J) / ( AXY(J-1) + AXY(J) ) + + DO I = 1, IM + BX(I,J) = BX(I,J) + FNAZ8 * ( XERR(I,J-1) - XERR(I,J) ) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! enhance the filtering by factor of 2 ONLY into/out-of polar caps + FNAZ8 = 0.5D0 * AXY(2) / ( AXY(1) + AXY(2) ) + + ! When LSP=TRUE then J=1 is SOUTH POLE + IF ( LSP ) THEN + DO I = 1, IM + BX(I,2) = BX(I,2) + FNAZ8 * (XERR(I,1) -XERR(I,2)) + ENDDO + ELSE + DO I = 1, IM + BX(I,1)= BX(I,1) -0.5D0 *FNAZ8 * XERR(I,1) + BX(I,2)= BX(I,2) +0.5D0 *FNAZ8 * (XERR(I,1) - XERR(I,2)) + ENDDO + ENDIF + + FNAZ8 = 0.5D0 * AXY(JM) / ( AXY(JM-1) + AXY(JM) ) + + ! When LNP=TRUE, then J=JM is NORTH POLE + IF ( LNP ) THEN + DO I = 1, IM + BX(I,JM) = BX(I,JM) +FNAZ8 *(XERR(I,JM-1) -XERR(I,JM)) + ENDDO + ELSE + DO I = 1,IM + BX(I,JM+1)= BX(I,JM+1) + 0.5D0 *FNAZ8 * XERR(I,JM) + BX(I,JM) = BX(I,JM) + 0.5D0 *FNAZ8 * + & (XERR(I,JM-1) -XERR(I,JM)) + ENDDO + ENDIF + + !============================================================== + ! need N-S flux across boundaries if window calculation + ! (assume XERR=0 outside) + ! + ! JM for optimal matrix/looping, it would be best to + ! define XERR=0 for an oversized array XERR(0:IM+1,0:JM+1) + ! Update the mass error (XERR) + !============================================================== + DO J = 1, JM + DO I = 1, IM + XERR(I,J) = X0(I,J) + AX(I,J) - AX(I+1,J) + & + BX(I,J) - BX(I,J+1) + ENDDO + ENDDO + + ENDDO ! NFLTR + + ! Return to calling program + END SUBROUTINE LOCFLT + +!------------------------------------------------------------------------------ + + SUBROUTINE POLFLT( XERR, BX, AXY, COEF, ID, JD, IM, JM ) +! +!****************************************************************************** +! Subroutine POLFLT applies the pressure-filter to polar boxes. +! POLFLT is called from subroutine PFILTR above (bdf, bmy, 10/10/01) +! +! Arguments as Input: +! ============================================================================ +! (1 ) XERR(ID,JD) (REAL*8 ) : mass error +! (2 ) BX(ID,JD+1) (REAL*8 ) : perturbed BETA by XERR +! (3 ) AXY(ID,JD) (REAL*8 ) : area of grid box (I,J) in [m^2] +! (4 ) COEF (REAL*8 ) : Multiplicative coefficient ????? +! (5-6) ID, JD (INTEGER) : "Window" array dimensions for lon, lat +! (7-8) IM, JM (INTEGER) : "Global" array dimensions for lon, lat +! +! Arguments as Output: +! ============================================================================ +! (1 ) XERR(ID,JD) (REAL*8 ) : adjusted mass error +! (2 ) BX(ID,JD+1) (REAL*8 ) : adjusted BX +! +! NOTES: +! (1 ) Adapted from original code from LLNL. Added comments and F90 syntax +! for declarations. (bdf, bmy, 10/10/01) +! (2 ) For a global run (as we usually do in GEOS-CHEM) IM=ID=IIPAR and +! JM=JD=JJPAR. (bmy, 10/20/01) +!****************************************************************************** +! + IMPLICIT NONE + + ! Arguments + INTEGER, INTENT(IN) :: ID, JD, IM, JM + REAL*8, INTENT(IN) :: AXY(JD) + REAL*8, INTENT(IN) :: COEF + REAL*8, INTENT(INOUT) :: XERR(ID,JD) + REAL*8, INTENT(INOUT) :: BX(ID,JD+1) + + ! Local variables + INTEGER :: I, J + REAL*8 :: ERAV, BXJ(JD+1), TOTAL + + !================================================================= + ! POLFLT begins here! + ! + ! Initialize corrective column mass flows (kg): BXJ->beta + !================================================================= + DO I = 1, IM + + ! Initialize + ERAV = 0.D0 + TOTAL = 0.D0 + + ! Sum XERR in ERAV and sum AXY in TOTAL + DO J = 1, JM + ERAV = ERAV + XERR(I,J) + TOTAL = TOTAL + AXY(J) + ENDDO + + ! Compute area-weighted mass error total + ERAV = ERAV / TOTAL + + ! mass-error filter, make corrections in BX + BXJ(1) = 0.D0 + + DO J = 2, JM + BXJ(J) = BXJ(J-1) + XERR(I,J-1) - AXY(J-1) * ERAV + ENDDO + + DO J = 2, JM + BX(I,J) = BX(I,J) + COEF * BXJ(J) + ENDDO + + ENDDO ! I + + ! Update XERR + DO J = 1, JM + DO I = 1, IM + XERR(I,J) = XERR(I,J) + BX(I,J) - BX(I,J+1) + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE POLFLT + +!------------------------------------------------------------------------------ + + SUBROUTINE DIAG_FLUX( IC, FX, FX1_TP, FY, FY1_TP, + & FZ, FZ1_TP, NDT, ACOSP ) +! +!****************************************************************************** +! Subroutine DIAG_FLUX archives the mass fluxes in TPCORE version 7.1. +! (bey, bmy, 9/20/00, 7/21/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IC (INTEGER) : Current tracer # +! (2,3) FX,FX1_TP (REAL*8 ) : Flux into the west side of grid box (I,J,K) +! (4,5) FY,FY1_TP (REAL*8 ) : Flux into the south side of grid box (I,J,K) +! (6,7) FZ,FZ1_TP (REAL*8 ) : Flux into top of grid box (I,J,K) +! (8 ) NDT (INTEGER) : Dynamic timestep in seconds +! (9 ) ACOSP (INTEGER) : Inverse cosine at latitude (J) +! +! Included via header files: +! ============================================================================ +! (1 ) DXYP (REAL*8) : Surface area of grid box [m2] +! (2 ) g0_100 (REAL*8) : The value 100 / 9.8 +! +! Diagnostics archived: +! ============================================================================ +! (1 ) ND24 : Eastward flux of tracer in kg/s +! (2 ) ND25 : Westward flux of tracer in kg/s +! (3 ) ND26 : Upward flux of tracer in kg/s +! +! NOTES: +! (1 ) Original code & algorithm is from Isabelle Bey, as installed in +! TPCORE v. 4.1 (1998, 1999) +! (2 ) DXYP is of dimension JGLOB, so reference it by DXYP(JREF), +! where JREF = J + J0. (bmy, 9/28/00) +! (3 ) Add parallel processor directives to do-loops (bmy, 9/29/00) +! (4 ) Archive CO budget array TCO for CO-OH run (bnd, bmy, 10/16/00) +! (5 ) Also archive X-trop flux for CH4 simulation in TCH4 (bmy, 1/17/01) +! (6 ) Added to "tpcore_mod.f" (bmy, 7/16/01) +! (7 ) Now replace DXYP(JREF) with routine GET_AREA_M2 of "grid_mod.f". +! Also remove all references to JREF. (bmy, 2/11/03) +! (8 ) Now references TCVV and ITS_A_CH4_SIM from "tracer_mod.f" +! (bmy, 7/20/04) +! (9 ) Remove references obsolete to CO-OH param code (bmy, 6/24/05) +! (10) Bug fix: FX should be dimensioned with IIPAR+1 and FZ should be +! dimensioned with LLPAR+1 (bmy, 7/21/05) +!****************************************************************************** +! + ! References to F90 modules + USE DIAG_MOD, ONLY : MASSFLEW, MASSFLNS, MASSFLUP + USE GLOBAL_CH4_MOD, ONLY : XNUMOL_CH4, TCH4 + USE GRID_MOD, ONLY : GET_AREA_M2 + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM, TCVV + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic switches +# include "CMN_GCTM" ! g0_100 + + ! Arguments + INTEGER, INTENT(IN) :: IC, NDT + REAL*8, INTENT(IN) :: FX(IIPAR+1,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: FX1_TP(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: FY(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: FY1_TP(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: FZ(IIPAR,JJPAR,LLPAR+1) + REAL*8, INTENT(IN) :: FZ1_TP(IIPAR,JJPAR,LLPAR) + REAL*8, INTENT(IN) :: ACOSP(JJPAR) + + ! Local variables + INTEGER :: I, J, K, K2 + REAL*8 :: DTC, DTDYN, AREA_M2 + + !================================================================= + ! DIAG_FLUX begins here! + ! + ! FX, FX1_TP, FY, FY1_TP, FZ, FZ1_TP have units of [mb/timestep]. + ! + ! To get tracer fluxes in kg/s : + ! * (100./9.8) => kg/m2 + ! * DXYP(J)/(DTDYN * TCVV(IC)) => kg/s + ! + ! Direction of the fluxes : + ! ---------------------------------------------------------------- + ! FX(I,J,K) => flux coming into the west edge of the box I + ! (from I-1 to I). + ! => a positive flux goes from west to east. + ! + ! FY(I,J,K) => flux coming into the south edge of the box J + ! (from J to J-1). + ! => a positive flux goes from south to north + ! (from J-1 to J) + ! + ! FZ(I,J,K) => flux coming down into the box k. + ! => a positive flux goes down. + !================================================================= + + ! DTDYN = double precision value for NDT, the dynamic timestep + DTDYN = DBLE( NDT ) + + !================================================================= + ! ND24 Diagnostic: Eastward flux of tracer in [kg/s] + !================================================================= + IF ( ND24 > 0 ) THEN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K, K2, AREA_M2, DTC ) + DO K = 1, LLPAR + + ! K is the vertical index down from the atmosphere top downwards + ! K2 is the vertical index up from the surface + K2 = LLPAR - K + 1 + + DO J = 1, JJPAR + + ! Grid box surface area [m2] + AREA_M2 = GET_AREA_M2( J ) + + DO I = 1, IIPAR + DTC = ( FX(I,J,K) + FX1_TP(I,J,K) ) * + & ( g0_100 * AREA_M2 ) / + & ( TCVV(IC) * DTDYN ) + + MASSFLEW(I,J,K2,IC) = MASSFLEW(I,J,K2,IC) + DTC + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + !================================================================= + ! ND25 Diagnostic: Northward flux of tracer in [kg/s] + !================================================================= + IF ( ND25 > 0 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K, K2, AREA_M2, DTC ) + DO K = 1, LLPAR + + ! K is the vertical index down from the atmosphere top downwards + ! K2 is the vertical index up from the surface + K2 = LLPAR - K + 1 + + DO J = 1, JJPAR + + ! Grid box surface area [m2] + AREA_M2 = GET_AREA_M2( J ) + + DO I = 1, IIPAR + DTC = ( FY(I,J,K) + FY1_TP(I,J,K) ) * + & ( ACOSP(J) * g0_100 * AREA_M2 ) / + & ( TCVV(IC) * DTDYN ) + + ! Contribution for CH4 run (bmy, 1/17/01) + IF ( ITS_A_CH4_SIM() ) THEN + TCH4(I,J,K,10) = TCH4(I,J,K,10) + + & ( DTC * DTDYN * XNUMOL_CH4 ) + ENDIF + + MASSFLNS(I,J,K2,IC) = MASSFLNS(I,J,K2,IC) + DTC + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + !================================================================= + ! ND26 Diagnostic : Upward flux of tracer in [kg/s] + !================================================================= + IF ( ND26 > 0 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K, K2, DTC ) + DO K = 1, LLPAR + + ! K is the vertical index down from the atmosphere top downwards + ! K2 is the vertical index up from the surface + K2 = LLPAR - K + 1 + + DO J = 1, JJPAR + + ! Grid box surface area [m2] + AREA_M2 = GET_AREA_M2( J ) + + DO I = 1, IIPAR + DTC = ( FZ(I,J,K) + FZ1_TP(I,J,K) ) * + & ( g0_100 * AREA_M2 ) / + & ( TCVV(IC) * DTDYN ) + + MASSFLUP(I,J,K2,IC) = MASSFLUP(I,J,K2,IC) + DTC + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ENDIF + + ! Return to calling program + END SUBROUTINE DIAG_FLUX + +!------------------------------------------------------------------------------ + + END MODULE TPCORE_MOD diff --git a/code/tpcore_window_mod.f b/code/tpcore_window_mod.f new file mode 100644 index 0000000..34dc6d9 --- /dev/null +++ b/code/tpcore_window_mod.f @@ -0,0 +1,4838 @@ +! $Id: tpcore_window_mod.f,v 1.1 2009/06/09 21:51:53 daven Exp $ + MODULE TPCORE_WINDOW_MOD +! +!****************************************************************************** +! Module TPCORE_MOD contains the TPCORE transport subroutine package by +! S-J Lin, version 7.1. (yxw, bmy, 12/2/03, 11/5/08) +! +! Module routines: +! ============================================================================ +! (1 ) TPCORE_WINDOW : TPCORE driver routine for nested-grid simulation +! (2 ) COSA : TPCORE internal subroutine +! (3 ) COSC : TPCORE internal subroutine +! (4 ) FCT3D : TPCORE internal subroutine +! (5 ) FILEW : TPCORE internal subroutine +! (6 ) FILNS : TPCORE internal subroutine +! (7 ) FXPPM : TPCORE internal subroutine +! (8 ) FYPPM : TPCORE internal subroutine +! (9 ) FZPPM : TPCORE internal subroutine +! (10) HILO : TPCORE internal subroutine +! (11) HILO3D : TPCORE internal subroutine +! (12) QCKXYZ : TPCORE internal subroutine +! (13) LMTPPM_x : TPCORE internal subroutine +! (14) LMTPPM_y : TPCORE internal subroutine +! (15) LMTPPM_z : TPCORE internal subroutine +! (16) XADV : TPCORE internal subroutine +! (17) XMIST : TPCORE internal subroutine +! (18) XTP : TPCORE internal subroutine +! (19) YMIST : TPCORE internal subroutine +! (20) YTP : TPCORE internal subroutine +! (21) PRESS_FIX : TPCORE pressure-fixer driver routine +! (22) DYN0 : TPCORE pressure-fixer internal subroutine +! (23) PFILTR : TPCORE pressure-fixer internal subroutine +! (24) LOCFLT : TPCORE pressure-fixer internal subroutine +! (25) POLFLT : TPCORE pressure-fixer internal subroutine +! (26) DIAG_FLUX : Computes ND24, ND25, ND26 mass flux diagnostics +! (27) POSITION_WINDOW : TPCORE internal subroutine +! +! Reference Diagram: +! ============================================================================ +! +! <-------------------------------------- IGLOB ----------------------> +! +! +-------------------------------------------------------------------+ ^ +! | GLOBAL REGION | | +! | | | +! | <-------------- IIPAR -------------> | | +! | | | +! | +=================================[Y] ^ | | +! | | WINDOW REGION (met field size) | | | | +! | | | | | | +! | | <------- IM_W -------> | | | | +! | | +--------------------+ ^ | | | | +! | | | TPCORE REGION | | | | | | +! | | | (transport is | | | | | | +! |<------- I0 ---------->|<---->| done in this | JM_W | JJPAR | JGLOB +! | | I0_W | window!!!) | | | | | | +! | | | | | | | | | +! | | +--------------------+ V | | | | +! | | ^ | | | | +! | | | J0_W | | | | +! | | V | | | | +! | [X]=================================+ V | | +! | ^ | | +! | | J0 | | +! | V | | +! [1]------------------------------------------------------------------+ V +! +! DIAGRAM NOTES: +! (a) The outermost box ("Global Region") is the global grid size. This +! region has IGLOB boxes in longitude and JGLOB boxes in latitude. +! The origin of the "Global Region" is at the south pole, at the +! lower left-hand corner (point [1]). +! +! (b) The next innermost box ("Window Region") is the nested-grid window. +! This region has IIPAR boxes in longitude and JJPAR boxes in latitude. +! This is the size of the trimmed met fields that will be used for +! a 1 x 1 "nested-grid" simulation. +! +! (c) The innermost region ("TPCORE Region") is the actual area in which +! TPCORE transport will be performed. Note that this region is smaller +! than the "Window Region". It is set up this way since a cushion of +! grid boxes is needed TPCORE Region for boundary conditions. +! +! (d) I0 is the longitude offset (# of boxes) and J0 is the latitude offset +! (# of boxes) which translate between the "Global Region" and the +! "Window Region". +! +! (e) I0_W is the longitude offset (# of boxes), and J0_W is the latitude +! offset (# of boxes) which translate between the "Window Region" +! and the "TPCORE Region". +! +! (f) The lower left-hand corner of the "Window Region" (point [X]) has +! longitude and latitude indices (I1_W, J1_W). Similarly, the upper +! right-hand corner (point [Y]) has longitude and latitude indices +! (I2_W, J2_W). +! +! (g) Note that if I0=0, J0=0, I0_W=0, J0_W=0, IIPAR=IGLOB, JJPAR=JGLOB +! specifies a global simulation. In this case the "Window Region" +! totally coincides with the "Global Region". +! +! (h) In order for the nested-grid to work we must save out concentrations +! over the WINDOW REGION from a coarse model (e.g. 4x5) corresponding to +! the same WINDOW REGION at 1x1. These concentrations are copied along +! the edges of the 1x1 WINDOW REGION and are thus used as boundary +! conditions for TPCORE. We assume that we will save out concentrations +! from the 4x5 model since presently it takes too long to run at 2x25. +! +! NOTES: +! (1 ) Denote differences from "tpcore_mod.f" by !%%%. Also assume that the +! window region does not include the polar caps. Now assume all +! platforms other than CRAY use OPENMP parallelization commands +! (yxw, bmy, 3/10/03) +! (2 ) Updated information output depending on what type of machine it is. +! (bmy, 12/2/03) +! (3 ) Commented out call to FLUSH(6) (bmy, 1/26/04) +! (4 ) Simplify PRIVATE definitions. Also fixed bug in FZPPM which was +! preventing the nested grid run from working on Altix (bmy, 11/9/04) +! (5 ) Remove obsolete CO-OH code (bmy, 6/24/05) +! (6 ) Now print output for IFORT compiler in "tpcore_window" (bmy, 10/18/05) +! (7 ) Now do not parallelize DO loop 2500 in TPCORE_WINDOW. For some reason +! this results in NaN's. All other parallel loops may be left +! activated. Also, now place all parallel loops in all routines w/in +! an #if defined block. (bmy, 11/5/08) +!****************************************************************************** +! + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "tpcore_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except this routine + PUBLIC :: TPCORE_WINDOW + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE TPCORE_WINDOW( IGD, Q, PS1, PS2, U, V, + & W, NDT, IORD, JORD, KORD, NC, + & IM, JM, J1, I0, J0, I0_W, + & J0_W, I1_W, J1_W, I2_W, J2_W, IM_W, + & JM_W, IGZD, NL, AP, BP, PT, + & AE, FILL, MFCT, Umax ) + +C TransPort module for Goddard Chemistry Transport Model (G-CTM), Goddard +C Earth Observing System General Circulation Model (GEOS-GCM), and Data +C Assimilation System (GEOS-DAS). + +C Purpose: perform the transport of 3-D mixing ratio fields using +C externally specified winds on the hybrid Eta-coordinate. +C One call to tpcore updates the 3-D mixing ratio +C fields for one time step (NDT). [vertical mass flux is computed +C internally using a center differenced hydrostatic mass +C continuity equation]. + +C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) schemes +C (Lin and Rood 1996, MWR) with a modified MFCT option (Zalesak 1979). + +C Multitasking version: 7.1 +C Last modified: Sept 2, 1999 +C Changes from version 7.m: large-time-step bug in xtp fixed. +C Suggested compiler options: +C CRAY f77 compiler: cf77 -Zp -c -Wd'-dec' -Wf' -a stack -exm' +C CRAY f90 compiler: f90 -c -eZ -DCRAY -Dmultitask +C SGI Origin: f77 -c -DSGI -Dmultitask -r8 -64 -O3 -mips4 -mp +C loader: f77 -64 -mp +C +C Send comments/suggestions to +C +C S.-J. Lin +C Address: +C Code 910.3, NASA/GSFC, Greenbelt, MD 20771 +C Phone: 301-614-6161 +C E-mail: slin@dao.gsfc.nasa.gov +C +C The algorithm is based on the following papers: + +C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi- +C Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070. +C +C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of +C the van Leer-type transport schemes and its applications to the moist- +C ure transport in a General Circulation Model. Mon. Wea. Rev., 122, +C 1575-1593. +C +C 3. Lin, S.-J., and R. B. Rood, 1997: Multidimensional flux form semi- +C Lagrangian transport schemes- MFCT option. To be submitted. + +C ====== +C INPUT: +C ====== + +C IGD: (horizontal) grid type on which winds are defined. +C IGD = 0 A-Grid [all variables defined at the same point from south +C pole (j=1) to north pole (j=JM) ] + +C IGD = 1 GEOS-GCM C-Grid (Max Suarez's center difference dynamical core) + +C [North] + +C V(i,j) +C | +C | +C | +C [WEST] U(i-1,j)---Q(i,j)---U(i,j) [EAST] +C | +C | +C | +C V(i,j-1) + +C [South] + +C U(i, 1) is defined at South Pole. +C V(i, 1) is half grid north of the South Pole. +C V(i,JM-1) is half grid south of the North Pole. +C +C V must be defined at j=1 and j=JM-1 if IGD=1 +C V at JM need not be defined. + +C Q(IM,JM,NL,NC): mixing ratios at current time (t) +C NC: total # of constituents +C IM: first (E-W) dimension; # of Grid intervals in E-W is IM +C JM: 2nd (N-S) dimension; # of Grid intervals in N-S is JM-1 +C NL: 3rd dimension (# of layers); vertical index increases from 1 at +C the model top to NL near the surface (see fig. below). +C It is assumed that NL > 5. +C +C PS1(IM,JM): surface pressure at current time (t) +C PS2(IM,JM): surface pressure at mid-time-level (t+NDT/2) +C PS2 is replaced by the predicted PS (at t+NDT) on output. +C Note: surface pressure can have any unit or can be multiplied by any +C const. +C +C The hybrid ETA-coordinate: +C +C pressure at layer edges are defined as follows: +C +C p(i,j,k) = AP(k)*PT + BP(k)*PS(i,j) (1) +C +C Where PT is a constant having the same unit as PS. +C AP and BP are unitless constants given at layer edges. +C In all cases BP(1) = 0., BP(NL+1) = 1. +C The pressure at the model top is PTOP = AP(1)*PT +C +C ********************* +C For pure sigma system +C ********************* +C AP(k) = 1 for all k, PT = PTOP, +C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP, where Psfc +C is the true surface pressure. +C +C ///////////////////////////////// +C / \ ------ Model top P=PTOP --------- AP(1), BP(1) +C | +C delp(1) | ........... Q(i,j,1) ............ +C | +C W(k=1) \ / --------------------------------- AP(2), BP(2) +C +C +C +C W(k-1) / \ --------------------------------- AP(k), BP(k) +C | +C delp(K) | ........... Q(i,j,k) ............ +C | +C W(k) \ / --------------------------------- AP(k+1), BP(k+1) +C +C +C +C / \ --------------------------------- AP(NL), BP(NL) +C | +C delp(NL) | ........... Q(i,j,NL) ......... +C | +C W(NL)=0 \ / -----Earth's surface P=Psfc ------ AP(NL+1), BP(NL+1) +C ////////////////////////////////// + +C U(IM,JM,NL) & V(IM,JM,NL):winds (m/s) at mid-time-level (t+NDT/2) +C Note that on return U and V are destroyed. + +C NDT (integer): time step in seconds (need not be constant during the course of +C the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5 +C (Lat-Lon) resolution. Smaller values maybe needed if the model +C has a well-resolved stratosphere and Max(V) > 225 m/s +C +C J1 determines the size of the polar cap: +C South polar cap edge is located at -90 + (j1-1.5)*180/(JM-1) deg. +C North polar cap edge is located at 90 - (j1-1.5)*180/(JM-1) deg. +C There are currently only two choices (j1=2 or 3). +C IM must be an even integer if j1 = 2. Recommended value: J1=3. +C +C IORD, JORD, and KORD are integers controlling various options in E-W, N-S, +C and vertical transport, respectively. +C +C +C _ORD= +C 1: 1st order upstream scheme (too diffusive, not a REAL*8 option; it +C can be used for debugging purposes; this is THE only known "linear" +C monotonic advection scheme.). +C 2: 2nd order van Leer (full monotonicity constraint; +C see Lin et al 1994, MWR) +C 3: monotonic PPM* (Collela & Woodward 1984) +C 4: semi-monotonic PPM (same as 3, but overshoots are allowed) +C 5: positive-definite PPM (constraint on the subgrid distribution is +C only strong enough to prevent generation of negative values; +C both overshoots & undershootes are possible). +C 6: un-constrained PPM (nearly diffusion free; faster but +C positivity of the subgrid distribution is not quaranteed. Use +C this option only when the fields and winds are very smooth or +C when MFCT=.true.) +C 7: Huynh/Van Leer/Lin full monotonicity constraint +C Only KORD can be set to 7 to enable the use of Huynh's 2nd monotonicity +C constraint for piece-wise parabolic distribution. +C +C *PPM: Piece-wise Parabolic Method +C +C Recommended values: +C IORD=JORD=3 for high horizontal resolution. +C KORD=6 or 7 if MFCT=.true. +C KORD=3 or 7 if MFCT=.false. +C +C The implicit numerical diffusion decreases as _ORD increases. +C DO not use option 4 or 5 for non-positive definite scalars +C (such as Ertel Potential Vorticity). +C +C If numerical diffusion is a problem (particularly at low horizontal +C resolution) then the following setup is recommended: +C IORD=JORD=KORD=6 and MFCT=.true. +C +C AE: Radius of the sphere (meters). +C Recommended value for the planet earth: 6.371E6 +C +C FILL (logical): flag to do filling for negatives (see note below). +C MFCT (logical): flag to do a Zalesak-type Multidimensional Flux +C correction. It shouldn't be necessary to call the +C filling routine when MFCT is true. +C +C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s). +C (225 m/s is a good value for troposphere model; 300 m/s otherwise) +C +C ***************************************************************** +C **Input added for window calculation (2x2.5) (yxw, 8/21/01)****** +C ***************************************************************** +C +C I0_W, J0_W: window index offset +C (I1_W, J1_W): left-low corner index of the window +C (I2_W, J2_W); right-high corner index of the window +C IM_W, JM_W: maximum index of the window (in coarse grid) +C +C +C ====== +C Output +C ====== +C +C Q: the updated mixing ratios at t+NDT (original values are over-written) +C W(;;NL): large-scale vertical mass flux as diagnosed from the hydrostatic +C relationship. W will have the same unit as PS1 and PS2 (eg, mb). +C W must be divided by NDT to get the correct mass-flux unit. +C The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND +C is the pressure thickness in the "upwind" direction. For example, +C C(k) = W(k)/delp(k) if W(k) > 0; +C C(k) = W(k)/delp(k+1) if W(k) < 0. +C ( W > 0 is downward, ie, toward surface) +C PS2: predicted PS at t+NDT (original values are over-written) +C +C Memory usage: +C This code is optimized for speed. it requres 18 dynamically allocated +C 3D work arrays (IM,JM,NL) regardless of the value of NC. +C Older versions (version 4 or 4.5) use less memory if NC is small. + +C ===== +C NOTES: +C ===== +C +C This forward-in-time upstream-biased transport scheme degenerates to +C the 2nd order center-in-time center-in-space mass continuity eqn. +C if Q = 1 (constant fields will remain constant). This degeneracy ensures +C that the computed vertical velocity to be identical to GEOS-1 GCM +C for on-line transport. +C +C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when +C winds are noisy near poles). +C +C The user needs to change the parameter Jmax or Kmax if the resolution +C is greater than 0.25 deg in N-S or 500 layers in the vertical direction. +C (this TransPort Core is otherwise resolution independent and can be used +C as a library routine). + +C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd +C order accurate for non-uniform grid (vertical sigma coord.). + +C Time step is limitted only by transport in the meridional direction. +C (the FFSL scheme is not implemented in the meridional direction). + +C Since only 1-D limiters are applied, negative values could +C potentially be generated when large time step is used and when the +C initial fields contain discontinuities. +C This does not necessarily imply the integration is unstable. +C These negatives are typically very small. A filling algorithm is +C activated if the user set "fill" to be true. +C Alternatively, one can use the MFCT option to enforce monotonicity. + + ! Added to pass C-preprocessor switches (bmy, 3/9/01) +# include "define.h" + +C ****6***0*********0*********0*********0*********0*********0**********72 + PARAMETER (Jmax = 721, kmax = 200 ) +C add ghost zone depth here (yxw, 08/23/01) +C ****6***0*********0*********0*********0*********0*********0**********72 + +C Input-Output arrays + + REAL*8 Q(IM,JM,NL,NC),PS1(IM,JM),PS2(IM,JM),W(IM,JM,NL), + & U(IM,JM,NL),V(IM,JM,NL),AP(NL+1),BP(NL+1) + LOGICAL ZCROSS, FILL, MFCT, deform + +C Local dynamic arrays + +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite array dimension limits and rename with _W suffix +!%%% + REAL*8 CRX_W(1-IGZD:IM_W+IGZD+1,1-IGZD:JM_W+IGZD,NL), + & CRY_W(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD+1,NL), + & DELP_W(IM_W,JM_W,NL), + & XMASS_W(IM_W+1,JM_W,NL),YMASS_W(IM_W,JM_W+1,NL), + & DELP2_W(0:IM_W+1,0:JM_W+1,NL), + & DG1_W(IM_W),DG2_W(IM_W,0:JM_W+1),DPI_W(IM_W,JM_W,NL), + & QLOW_W(0:IM_W+1,0:JM_W+1,NL), DG3_W(JM_W, IM_W), + & WK_W(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD,NL), + & PU_W(IM_W+1,JM_W,NL), + & DQ_W(IM_W,JM_W,NL), + & DELP1_W(IM_W,JM_W,NL), + & FX_W(IM_W+1,JM_W,NL),FY_W(IM_W,JM_W+1,NL), + & FZ_W(IM_W,JM_W,NL+1), + & QZ_W(IM_W,JM_W,NL),QMAX_W(IM,JM,NL),QMIN_W(IM,JM,NL), + & U_W(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD,NL), + & V_W(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD,NL), + & W_W(IM_W,JM_W,NL) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Add new logical variable OUT +!%%% + LOGICAL OUT + +! bey, 6/20/00. for mass-flux diagnostic + REAL*8 fx1_tp_w(IM_w,JM_w,NL), fy1_tp_w(IM_w,JM_w,NL), + & fz1_tp_w(IM_w,JM_w,NL) + + INTEGER JS_w(NL),JN_w(NL),j1_in,j2_in + +C Local static arrays + + REAL*8 DTDX_w(-10:Jmax), DTDX5_w(-10:Jmax), + & acosp_w(-10:Jmax), + & cosp_w(-10:Jmax), cose_w(-10:Jmax), + & DAP(kmax), DBK(kmax) + + DATA NDT0, NSTEP /0, 0/ + DATA ZCROSS /.true./ + +C Saved internal variables: + SAVE DTDY_w, DTDY5_w, JS0, JN0, DTDX_w, out, j1_in,j2_in, + & DTDX5_w, acosp_w, COSP_w, COSE_w, DAP,DBK + +! New variables for TPCORE pressure fixer (bdf, bmy, 10/11/01) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Modify array dimension limits +!%%% + REAL*8 YMASS_PF_W(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD+1,NL), + & XMASS_PF_W(1-IGZD:IM_W+IGZD+1,1-IGZD:JM_W+IGZD,NL), + & TEMP_W(IM,JM,NL) + + ! Other new variables for window TPCORE pressure fixer (yxw) + REAL*8 DELP2_P(-IGZD:IM_W+IGZD+1, -IGZD:JM_W+IGZD+1, NL), + & PU_P(1-IGZD: IM_W+IGZD+1, 1-IGZD:JM_W+IGZD+1, NL) + + LOGICAL :: PRESSURE_FIX + PRESSURE_FIX = .TRUE. + +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + deform = .false. + JM1 = 181 -1 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Comment out variables below +!%%% IMH = IM/2 +!%%% j2= JM - j1 + 1 +!%%% + NSTEP = NSTEP + 1 + +C****6***0*********0*********0*********0*********0*********0**********72 +C Initialization +C****6***0*********0*********0*********0*********0*********0**********72 + + ! For mass flux diagnostics (bey, 6/20/00) + fx1_tp_w(:,:,:) = 0d0 + fy1_tp_w(:,:,:) = 0d0 + fz1_tp_w(:,:,:) = 0d0 + + ! Also need to initialize these arrays, so that the flux diagnostics + ! will be identical for single or multi processor (bmy, 9/29/00) + fx_w(:,:,:) = 0d0 + fy_w(:,:,:) = 0d0 + fz_w(:,:,:) = 0d0 + + ! Need to initialize these arrays in order to avoid + ! floating-point exceptions on Alpha (lyj, bmy, 4/19/02) + YMASS_PF_w(:,:,:) = 0d0 + XMASS_PF_w(:,:,:) = 0d0 + + if(NSTEP.eq.1) then + + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'TPCORE_WINDOW -- FFSL TransPort Core v. 7.1' + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) 'Originally written by S-J Lin' + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) + & 'Window version created for GEOS-CHEM by Yuxuan Wang and' + WRITE( 6, '(a)' ) + & 'Bob Yantosca, with the addition of flux diagnostics and the' + WRITE( 6, '(a)' ) 'DYN0 pressure fixer from M. Prather' + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) 'Last Modification Date: 3/13/03' + WRITE( 6, '(a)' ) + +#if ( multitask ) + WRITE( 6, '(a)' ) 'TPCORE_WINDOW was compiled for multitasking' +#if defined( CRAY ) + WRITE( 6, '(a)' ) 'for CRAY' +#elif defined( SGI_MIPS ) + WRITE( 6, '(a)' ) 'for SGI Origin/Power Challenge machines' +#elif defined( COMPAQ ) + WRITE( 6, '(a)' ) 'for COMPAQ/HP RISC Alpha machines' +#elif defined( LINUX_PGI ) + WRITE( 6, '(a)' ) 'for Linux environment w/ PGI compiler' +#elif defined( LINUX_IFORT ) + WRITE( 6, '(a)' ) 'for Linux environment w/ Intel IFORT compiler' +#elif defined( SPARC ) + WRITE( 6, '(a)' ) 'for SUN/Sparc machines' +#elif defined( IBM_AIX ) + WRITE( 6, '(a)' ) 'for IBM/AIX machines' +#endif +#endif + + ! Added output on the first time TPCORE is called (bmy, 10/11/01) + IF ( PRESSURE_FIX ) THEN + WRITE( 6, '(a)' ) 'TPCORE PRESSURE FIXER is turned ON!' + ENDIF + + if( MFCT ) then + write(6,*) ' MFCT option is on' + endif + + WRITE(6,*) 'IM=',IM,' JM=',JM,' NL=',NL,' j1=',j1 + WRITE(6,*) 'I0=',I0,' J0=',J0 +C +C write window size information (yxw, 8/21/2001) + + WRITE(6,*) 'IM_W=', IM_W, ' JM_W=', JM_W + WRITE(6,*) 'I1_W=', I1_W, ' I2_W=', I2_W + WRITE(6,*) 'J1_W=', J1_W, ' J2_W=', J2_W + WRITE(6,*) 'I0_W=', I0_W, ' J0_W=', J0_W + WRITE(6,*) NC, IORD,JORD,KORD,NDT + + if(NL.LT.6) then + write(6,*) 'stop in module tpcore' + write(6,*) 'NL must be >=6' + stop + endif + + if(Jmax.lt.JM .or. Kmax.lt.NL) then + write(6,*) 'stop in module tpcore' + write(6,*) 'Jmax or Kmax is too small; see documentation' + stop + endif + + DO k=1,NL + DAP(k) = (AP(k+1) - AP(k))*PT + DBK(k) = BP(k+1) - BP(k) + ENDDO + + PI = 4. * ATAN(1.) + DL = 2.*PI / float(360) + DP = PI / float(JM1) +C +C for window calculation, we have to redefine DL and DP. But since it's for +C 2x2.5, we skip this step for simplicity. (yxw, 8/21/2001) +C + IF(IGD.EQ.0) THEN +C Compute analytic cosine at cell edges +C +C also need to change cosa for window calculation (yxw, 8/21/2001) +C + CALL COSA(COSP_W,COSE_W,JM_W,J0_W,PI,DP,IGZD,J0,JMAX) + ELSE +C Define cosine consistent with GEOS-GCM (using dycore2.0 or later) + CALL COSC(COSP_W,COSE_W,JM_W,J1_W,J2_W,PI,DP,IGZD,JMAX) + ENDIF + + DO J=-IGZD,JM_W+IGZD+1 + ACOSP_W(J) = 1./COSP_W(J) + ENDDO +c15 write (6,*) 'cosp(',j+j0_w+j0,')=',cosp_w(j) + +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% We don't need this code, it's for the polar cap +!%%% ! Inverse of the Scaled polar cap area. +!%%% agle = (float(j1)-1.5)*DP +!%%% RCAP = DP / ( float(IM)*(1.-COS(agle)) ) +!%%% acosp(1) = RCAP +!%%% acosp(JM) = RCAP +!%%% + ENDIF + + if(NDT0 .ne. NDT) then + DT = NDT + NDT0 = NDT + + CR1 = abs(Umax*DT)/(DL*AE) + MaxDT = DP*AE / abs(Umax) + 0.5 + write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT + + if(MaxDT .lt. abs(NDT)) then + write(6,*) 'Warning!!! NDT maybe too large!' + endif + + if(CR1.ge.0.95) then + JS0 = J1_w-igzd + JN0 = J2_w+igzd !(yxw,eulerian) + IML = IM-2 + ZTC = 0. + else + ZTC = acos(CR1) * (180./PI) + JS0 = float(JM1)*(90.-ZTC)/180. + 2 + JS0 = max(JS0, J1+1) + IML = min(6*JS0/(J1-1)+2, 4*360/5) + JN0 = 181-JS0+1 + endif + + WRITE(6,*) 'IGZD = ', IGZD + write(6,*) 'ZTC= ',ZTC,' JS= ',JS0,' JN= ',JN0,' IML= ',IML +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% determine the relationship of (JS0,JN0) and (J1_W, J2_W) +!%%% (ji_in,j2_in) are the part of the window inside the region (JS0,JN0) +!%%% + CALL POSITION_WINDOW( JS0, JN0, J1_W-IGZD, + & J2_W+IGZD, OUT, J1_IN, J2_IN ) + + WRITE(6,*) 'J1_IN=', J1_IN,' ', 'J2_IN=', J2_IN + + DO J = 1-IGZD, JM_W+IGZD + DTDX_W(J) = DT / ( DL*AE*COSP_W(J) ) + DTDX5_W(J) = 0.5 * DTDX_W(J) + ENDDO + + DTDY_w = DT /(AE*DP) + DTDY5_w = 0.5*DTDY_w + + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + ENDIF ! END INITIALIZATION. + +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute Courant number +C****6***0*********0*********0*********0*********0*********0**********72 + + if(IGD.eq.0) then + +C Convert winds on A-Grid to Courant # on C-Grid. + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all shared(NL,im,jm1,jm,U,V,dtdx5_w,dtdy5_w,CRX_w,CRY_w,im_w,jm_w) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + do 900 k=1,NL + DO J=1-IGZD,JM_W+IGZD + DO I=1-IGZD,IM_W+1+IGZD +C calculate Courant # at grid edge, using offsetted wind (yxw 08/23/01) +C + CRX_w(i,j,k) = dtdx5_w(j)*(U(i+i0_w,j+j0_w,k)+ + & U(i-1+i0_w,j+j0_w,k)) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Comment out +!%%% if (CRX_w(i,j,k) .gt. 1) then +!%%% write(6,555) i,j,k, CRX_w(i,j,k) +!%%%555 format('CRX is larger than 1 at grid ', 3(I3,1x), F12.5) +!%%% endif +!%%% + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Replace w/ code below +!%%% ! for i=1 +!%%% do 48 j=2,JM1 +!%%% 48 CRX(1,j,k) = dtdx5(j)*(U(1,j,k)+U(IM,j,k)) +!%%% + DO J = 1-IGZD, JM_W+1+IGZD + DO I = 1-IGZD, IM_W+IGZD + CRY_w(i,j,k) = DTDY5_w*(V(i+i0_w,j+j0_w,k)+V(i+i0_w,j-1+j0_w,k)) + ENDDO + ENDDO + +900 continue + + else + +C Convert winds on C-grid to Courant # +C Beware of the index shifting!! (GEOS-GCM) + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all shared(NL,im,jm1,jm,U,V,dtdx_w,dtdy_w,CRX_w,CRY_w,jm_w,im_w) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + +C calculte Courant # using offsetted wind (yxw,08/23/01) +C + DO 65 k=1,NL + + DO J =1-IGZD, JM_W+IGZD + DO I =1-IGZD, IM_W+1+IGZD + CRX_W(I,J,K) = DTDX_W(J) * U( I-1+I0_W, J+J0_W, K ) + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Replace w/ code below +!%%% do 55 j=2,JM1 +!%%% 55 CRX(1,j,k) = dtdx(j)*U(IM,j,k) +!%%% + DO J = 1-IGZD, JM_W+1+IGZD + DO I = 1-IGZD, IM_W+IGZD + CRY_W(I,J,K) = DTDY_W * V( I+I0_W, J+1-J0_W, K ) + ENDDO + ENDDO + + 65 continue + endif + + !================================================================= + ! ***** T P C O R E P R E S S U R E F I X E R ***** + ! + ! Run pressure fixer to fix mass conservation problem. Pressure + ! fixer routines PRESS_FIX, DYN0, PFILTR, LOCFLT, and POLFLT + ! change the mass fluxes so they become consistant with met field + ! pressures. (bdf, bmy, 10/11/01) + ! + ! NOTE: The pressure fixer is not 100% perfect; tracer mass will + ! increase on the order of 0.5%/yr. However, this is much + ! better than w/o the pressure fixer, where the mass may + ! increase by as much as 40%/yr. (bdf, bmy, 10/22/01) + !================================================================= + IF ( PRESSURE_FIX ) THEN + + ! Loop over vertical levels -- + ! added parallel loop #if statements (bmy, 10/11/01) +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all shared(NL,IM,JM,JM1,COSE,XMASS_PF,YMASS_PF,DELP2,CRX,CRY) +CMIC$* private(I,J,K,D5) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, D5 ) +#endif +#endif + DO K = 1, NL + + ! DELP = pressure thickness: + ! the pseudo-density in a hydrostatic system. +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% DO J = 1, JM +!%%% DO I = 1, IM +!%%% + DO J = -IGZD, JM_W+IGZD+1 + DO I = -IGZD, IM_W+IGZD+1 + DELP2_P(I,J,K) = DAP(K) + DBK(K)*PS2(I+I0_W,J+J0_W) + ENDDO + ENDDO + + ! calculate mass fluxes for pressure fixer. + + ! N-S component +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% DO J = J1, J2+1 +!%%% + DO J=1-IGZD, JM_W+IGZD+1 + D5 = 0.5 * COSE_W(J) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% DO I = 1, IM +!%%% + DO I= 1-igzd, IM_W+igzd + YMASS_PF_w(I,J,K) = + & CRY_w(I,J,K) * D5 * (DELP2_p(I,J,K)+ + & DELP2_p(I,J-1,K)) + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff is useless for nested simulation +!%%% ! Enlarged polar cap. +!%%% IF(J1.NE.2) THEN +!%%% DO I=1,IM +!%%% YMASS_PF(I,1,K) = 0 +!%%% YMASS_PF(I,JM1+1,K) = 0 +!%%% ENDDO +!%%% ENDIF +!%%% + ! E-W component +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% DO J = J1, J2 +!%%% DO I = 2, IM +!%%% + DO J = 1-IGZD, JM_W+IGZD+1 + DO I = 1-IGZD, IM_W+IGZD+1 + PU_P(I,J,K) = 0.5 * (DELP2_P(I,J,K) + DELP2_P(I-1,J,K)) + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap is useless for nested simulation +!%%% DO J = J1, J2 +!%%% PU(1,J,K) = 0.5 * (DELP2(1,J,K) + DELP2(IM,J,K)) +!%%% ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% DO J = J1, J2 +!%%% + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD+1 + XMASS_PF_W(I,J,K) = PU_P(I,J,K) * CRX_W(I,J,K) + ENDDO + ENDDO + + ENDDO + + !============================================================== + ! Call PRESS_FIX to apply the pressure fix to the mass fluxes + ! XMASS_PF, YMASS_PF. PRESS_FIX will call routine DYN0, etc. + !============================================================== + CALL PRESS_FIX( XMASS_PF_w, YMASS_PF_w, NDT, ACOSP_w, Jmax, + & I0_W, J0_W, IM_W, JM_W, IGZD ) + + ! Loop over vertical levels -- + ! added parallel loop #if statements (bmy, 10/11/01) +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all shared(NL,IM,JM,XMASS_PF,PU,YMASS_PF,DELP2,COSE,CRX,CRY) +CMIC$* private(I,J,K,D5) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, D5 ) +#endif +#endif + DO K = 1, NL + + ! Recreate the CRX variable with the new values + ! of XMASS_PF, which has been adjusted by DYN0 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% DO J = J1, J2 +!%%% DO I = 1, IM +!%%% + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD+1 + CRX_w(I,J,K) = XMASS_PF_w(I,J,K) / PU_p(I,J,K) + ENDDO + ENDDO + + ! Recreate the CRY variable with the new values + ! of YMASS_PF, which has been adjusted by DYN0 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% DO J = J1, J2+1 +!%%% + DO J = 1-IGZD, JM_W+IGZD+1 + D5 = 0.5 * COSE_W(J) + + DO I = 1-IGZD, IM_W+IGZD + CRY_W(I,J,K) = YMASS_PF_W(I,J,K) / + & ( D5 * ( DELP2_P(I,J,K) + DELP2_P(I,J-1,K) ) ) + ENDDO + ENDDO + ENDDO + ENDIF + + !================================================================= + ! End of TPCORE PRESSURE FIXER -- continue as usual + !================================================================= + + +C********************************************************************** +C Check whether CRY_w is larger than one (yxw, eulerian) +C********************************************************************** + IF ( maxval(CRY_w) .gt. 1.0) THEN + write (6,*) 'CRY is larger than one!!' + write (6,*) 'Decrease timestep NTDT!!' + STOP + ENDIF + +C****6***0*********0*********0*********0*********0*********0**********72 +C Find JN and JS +C****6***0*********0*********0*********0*********0*********0**********72 + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope shared(JS_w,JN_w,CRX_w,CRY_w,PS2,U,V,DPI_w,ymass_w,delp2_w,PU_W) +CMIC$* shared(xmass_w) +CMIC$* private(i,j,k,sum1,sum2,D5) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, SUM1, SUM2, D5 ) +#endif +#endif + +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Find JS_w and JN_w, using CRX_w as criterion +!%%% here, j1_in and j2_in have been calculated in the initialization part +!%%% + do 1000 k=1,NL + if (.not. out) then + JS_w(k) = j1_w-igzd-1 + JN_w(k) = j2_w+igzd+1 + + DO J = J1_IN, J1_W-IGZD,-1 + DO I = 1, IM_W + IF(ABS(CRX_W(I,J-J0_W-J0,K)) .GT. 1.) THEN + JS_W(K) = J + GO TO 112 + ENDIF + ENDDO + ENDDO + +112 continue + + DO J = J2_IN, J2_W+IGZD + DO I = 1, IM_W + IF(ABS(CRX_W(I,J-J0_W-J0,K)) .GT. 1.) THEN + JN_W(K) = J + GO TO 133 + ENDIF + ENDDO + ENDDO + +133 continue + + else + js_w(k)=-1 + jn_w(k)=-1 + + DO J = J1_W, J2_W + DO I = 1, IM_W + IF (ABS(CRX_W(I,J-J0_W-J0,K)) .LT. 1.) THEN + JS_W(K)=J + GO TO 134 + ENDIF + ENDDO + ENDDO + +134 continue + + IF (JS_W(K) .NE. -1) THEN + + DO J = JS_W(K), J2_W + DO I = 1, IM_W + IF (ABS(CRX_W(I,J-J0_W-J0,K)) .GT. 1.) THEN + JN_W(K)=J + GO TO 146 + ENDIF + ENDDO + ENDDO + +146 continue + endif + endif + +C****6***0*********0*********0*********0*********0*********0**********72 +C ***** Compute horizontal mass fluxes ***** +C****6***0*********0*********0*********0*********0*********0**********72 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% now it is the window version,using offsetted pressure fields +!%%% Rewrite DO-loop limits as necessary +!%%% +C delp = pressure thickness: the psudo-density in a hydrostatic system. + DO J = 0, JM_W+1 + DO I = 0, IM_W+1 + DELP2_W(I,J,K) = DAP(K) + DBK(K)*PS2(I+I0_W,J+J0_W) + ENDDO + ENDDO + +C N-S componenet + + do j=1,jm_w+1 + D5 = 0.5 * COSE_w(j) + do i=1,IM_w + ymass_w(i,j,k) = CRY_w(i,j,k)*D5*(delp2_w(i,j,k) + + & delp2_w(i,j-1,k)) + enddo + enddo + + DO J = 1, JM_W + DO I = 1, IM_W + DPI_W(I,J,K) = (YMASS_W(I,J,K)-YMASS_W(I,J+1,K)) * ACOSP_W(J) + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%% if(j1.ne.2) then ! Enlarged polar cap. +!%%% do 95 i=1,IM +!%%% DPI(i, 2,k) = 0. +!%%% 95 DPI(i,JM1,k) = 0. +!%%% endif +!%%% +!%%% Poles +!%%% sum1 = ymass(IM,j1 ,k) +!%%% sum2 = ymass(IM,j2+1,k) +!%%% do 98 i=1,IM-1 +!%%% sum1 = sum1 + ymass(i,j1 ,k) +!%%% 98 sum2 = sum2 + ymass(i,j2+1,k) +!%%% +!%%% sum1 = - sum1 * RCAP +!%%% sum2 = sum2 * RCAP +!%%% do 100 i=1,IM +!%%% DPI(i, 1,k) = sum1 +!%%% 100 DPI(i,JM,k) = sum2 + +C E-W component + do J = 1, JM_W + DO I = 1, IM_W+1 + PU_W(I,J,K) = 0.5 * (DELP2_W(I,J,K) + DELP2_W(I-1,J,K)) + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%% do j=j1,j2 +!%%% PU(1,j,k) = 0.5 * (delp2(1,j,k) + delp2(IM,j,k)) +!%%% enddo +!%%% + DO j = 1, jm_w + DO i = 1, IM_w+1 + xmass_w(i,j,k) = PU_w(i,j,k)*CRX_w(i,j,k) + ENDDO + ENDDO + + DO j = 1, jm_w + DO i = 1, IM_w + DPI_w(i,j,k) = DPI_w(i,j,k) + xmass_w(i,j,k) - xmass_w(i+1,j,k) + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%% +!%%% DO 130 j=j1,j2 +!%%% 130 DPI(IM,j,k) = DPI(IM,j,k) + xmass(IM,j,k) - xmass(1,j,k) +!%%% +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute Courant number at cell center +C****6***0*********0*********0*********0*********0*********0**********72 + + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD + IF(CRX_W(I,J,K)*CRX_W(I+1,J,K) .GT. 0.) THEN + IF(CRX_W(I,J,K) .GT. 0.) THEN + U_W(I,J,K) = CRX_W(I,J,K) + ELSE + U_W(I,J,K) = CRX_W(I+1,J,K) + ENDIF + ELSE + U_W(I,J,K) = 0. + ENDIF + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%% i=IM +!%%% DO 136 j=2,JM1 +!%%% if(CRX(i,j,k)*CRX(1,j,k) .gt. 0.) then +!%%% if(CRX(i,j,k) .gt. 0.) then +!%%% U(i,j,k) = CRX(i,j,k) +!%%% else +!%%% U(i,j,k) = CRX(1,j,k) +!%%% endif +!%%% else +!%%% U(i,j,k) = 0. +!%%% endif +!%%% 136 continue +!%%% + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD + IF(CRY_W(I,J,K)*CRY_W(I,J+1,K) .GT. 0.) THEN + IF(CRY_W(I,J,K) .GT. 0.) THEN + V_W(I,J,K) = CRY_W(I,J,K) + ELSE + V_W(I,J,K) = CRY_W(I,J+1,K) + ENDIF + ELSE + V_W(I,J,K) = 0. + ENDIF + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%% do 139 i=1,IMH +!%%% V(i, 1,k) = 0.5*(CRY(i,2,k)-CRY(i+IMH,2,k)) +!%%% V(i+IMH, 1,k) = -V(i,1,k) +!%%% V(i, JM,k) = 0.5*(CRY(i,JM,k)-CRY(i+IMH,JM1,k)) +!%%% 139 V(i+IMH,JM,k) = -V(i,JM,k) +!%%% +1000 continue +!C****6***0*********0*********0*********0*********0*********0**********72 +!C Compute vertical mass flux (same dimensional unit as PS) +!C****6***0*********0*********0*********0*********0*********0**********72 + +C compute total column mass CONVERGENCE. + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope shared(im,jm,DPI_w,PS1,PS2,W_w,DBK,jm_w,im_w) +CMIC$* shared(DPI_w,PS1,PS2,W_w,DBK) +CMIC$* private(i,j,k,DG1_w) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, DG1_w ) +#endif +#endif + +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits as necessary +!%%% + do 395 j=1,jm_w + + do i=1,IM_w + DG1_w(i) = DPI_w(i,j,1) + ENDDO + + do k=2, NL + do i=1, IM_w + DG1_w(i) = DG1_w(i) + DPI_w(i,j,k) + ENDDO + ENDDO + + do 360 i=1,IM_w + +C Compute PS2 (PS at n+1) using the hydrostatic assumption. +C Changes (increases) to surface pressure = total column mass convergence + PS2(i+i0_w,j+j0_w) = PS1(i+i0_w,j+j0_w) + DG1_w(i) + +C compute vertical mass flux from mass conservation principle. + W_w(i,j,1) = DPI_w(i,j,1) - DBK(1)*DG1_w(i) + W_w(i,j,NL) = 0. +360 continue + + DO K = 2, NL-1 + DO I = 1, IM_W + W_W(I,J,K) = W_W(I,J,K-1) + DPI_W(I,J,K) - DBK(K)*DG1_W(I) + ENDDO + ENDDO + +395 continue + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all +CMIC$* shared(deform,NL,im,jm,delp_w,delp1_w,delp2_w,DPI_w,DAP,DBK,PS1,PS2) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + DO 390 k=1,NL + + DO J =1, JM_W + DO I =1, IM_W + DELP1_W(I,J,K) = DAP(K) + DBK(K)*PS1(I+I0_W,J+J0_W) + DELP2_W(I,J,K) = DAP(K) + DBK(K)*PS2(I+I0_W,J+J0_W) + DELP_W (I,J,K) = DELP1_W(I,J,K) + DPI_W(I,J,K) + ENDDO + ENDDO + +C Check deformation of the flow fields + if(deform) then + +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Don't need this part +!%%% DO j=1,JM_w +!%%% DO i=1,IM_w +!%%% if(delp_w(i,j,k) .le. 0.) then +!%%% write(6,*) k,'Noisy wind fields -> delp* is negative!' +!%%% write(6,*) ' *** Smooth the wind fields or reduce NDT' +!%%% stop +!%%% endif +!%%% ENDDO +!%%% ENDDO + + endif +390 continue + +C****6***0*********0*********0*********0*********0*********0**********72 +C Do transport one tracer at a time. +C****6***0*********0*********0*********0*********0*********0**********72 + + DO 5000 IC=1,NC + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!%%% MODIFICATIONS FOR NESTED GRID (bmy, 11/5/08) +!%%% Comment out the parallel loop statements for DO loop 2500, because +!%%% for some reason this causes NaN's. We can leave all the other parallel +!%%% loops activated. (bmy, 11/5/08) +!%%% +!%%%#if defined( multitask ) +!%%%#if defined( CRAY ) +!%%%!CMIC$ do all autoscope +!%%%!CMIC$* shared(q,DQ_w,delp1_w,U_w,V_w,j1,JS_w,JN_w,im,jm,IML,IC,IORD,JORD,jm_w,im_w) +!%%%!CMIC$* shared(CRX_w,CRY_w,PU_w,xmass_w,ymass_w,fx_w,fy_w,acosp_w,qz_w) +!%%%!CMIC$* shared(fx1_tp_w, fy1_tp_w) +!%%%!CMIC$* private(i,j,k,jt,wk_w,DG2_w) +!%%%#else +!%%%!$OMP PARALLEL DO PRIVATE( I, J, K, JT, WK_w, DG2_w ) +!%%%#endif +!%%%#endif +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + do 2500 k=1,NL +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%% +!%%% if(j1.ne.2) then +!%%% DO 405 I=1,IM +!%%% q(I, 2,k,IC) = q(I, 1,k,IC) +!%%% 405 q(I,JM1,k,IC) = q(I,JM,k,IC) +!%%% endif +!%%% + +C Initialize DQ +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% use offsetted tracer concentration Q, and save into DQ_W +!%%% + !print *, "IC, K:", IC, K + DO J = 1, JM_W + DO I = 1, IM_W + DQ_W(I,J,K) = Q(I+I0_W,J+J0_W,K,IC)*DELP1_W(I,J,K) + ENDDO + ENDDO + +C E-W advective cross term +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Pass new arguments as necessary (e.g. IM_W, JM_W, etc) +!%%% + CALL XADV( IM_W, JM_W, Q(:,:,K,IC), U_W(:,:,K), + & JS_W(K), JN_W(K), WK_W(:,:,1), IGZD, + & IM, JM, I0_W, J0_W, + & I0, J0 ) + + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD + WK_W(I,J,1) = Q(I+I0_W,J+J0_W,K,IC) + 0.5*WK_W(I,J,1) + ENDDO + ENDDO + +C N-S advective cross term +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits as necessary +!%%% + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD + JT = FLOAT(J+J0_W) - V_W(I,J,K) + IF (JT .GT. JM-1) THEN + JT=JM-1 + ELSE IF (JT .LT. 1) THEN + JT=1 + ENDIF + WK_W(I,J,2) = V_W(I,J,K) * + & (Q(I+I0_W,JT,K,IC) - Q(I+I0_W,JT+1,K,IC)) + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits as necessary +!%%% + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD + WK_W(I,J,2) = Q(I+I0_W,J+J0_W,K,IC) + 0.5*WK_W(I,J,2) + ENDDO + ENDDO + +C****6***0*********0*********0*********0*********0*********0**********72 +C compute flux in E-W direction +C Return flux contribution from TPCORE in FX1_TP array (bey, 9/28/00) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Call XTP, with window arrays etc. +!%%% + call xtp(im_w,jm_w,igzd,JN_w(k),JS_w(k),PU_w(:,:,k),DQ_w(:,:,k), + & wk_w(:,:,2),CRX_w(:,:,k),fx_w(:,:,k),xmass_w(:,:,k),IORD, + & fx1_tp_w(:,:,k),i0_w,j0_w,i0,J0) + +C compute flux in N-S direction +C Return flux contribution from TPCORE in FY1_TP array (bey, 9/28/00) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Call YTP with window arrays etc. +!%%% + call ytp(IM_w,JM_w,acosp_w(:),DQ_w(:,:,k),wk_w(:,:,1), + & CRY_w(:,:,k),ymass_w(:,:,k),fy_w(:,:,k),JORD, + & fy1_tp_w(:,:,k),igzd, Jmax) +!C****6***0*********0*********0*********0*********0*********0**********72 + + if(ZCROSS) then + +C qz is the horizontal advection modified value for input to th=1,5 +C vertical transport operator FZPPM +C Note: DQ contains only first order upwind contribution. + + DO J = 1, JM_W + DO I = 1, IM_W + QZ_W(I,J,K) = DQ_W(I,J,K) / DELP_W(I,J,K) + ENDDO + ENDDO + + ELSE + + DO J = 1, JM_W + DO I = 1, IM_W + QZ_W(I,J,K) = Q(I+I0_W,J+J0_W,K,IC) + ENDDO + ENDDO + + ENDIF + +2500 continue ! k-loop +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute fluxes in the vertical direction +C Return flux contribution from FZPPM in FZ1_TP for ND26 (bey, 9/28/00) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Call FZPPM with window arrays +!%%% + call FZPPM(qz_w,fz_w,IM_w,JM_w,NL,DQ_w, + & W_w,delp_w,KORD,fz1_tp_w) + +!C****6***0*********0*********0*********0*********0*********0**********72 + +C Final update + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* private(i,j,k,sum1,sum2) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, SUM1, SUM2 ) +#endif +#endif + + DO 101 K = 1, NL + + DO J = 1, JM_W + DO I = 1, IM_W + DQ_W(I,J,K) = DQ_W(I,J,K) + & + FX_W(I,J,K) - FX_W(I+1,J,K) + & + ( FY_W(I,J,K) - FY_W(I,J+1,K) ) * ACOSP_W(J) + & + FZ_W(I,J,K) - FZ_W(I,J,K+1) + ENDDO + ENDDO + +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%% sum1 = fy(IM,j1 ,k) +!%%% sum2 = fy(IM,J2+1,k) +!%%% +!%%% do i=1,IM-1 +!%%% sum1 = sum1 + fy(i,j1 ,k) +!%%% sum2 = sum2 + fy(i,J2+1,k) +!%%% enddo +!%%% +!%%% DQ(1, 1,k) = DQ(1, 1,k) - sum1*RCAP + fz(1, 1,k) - fz(1, 1,k+1) +!%%% DQ(1,JM,k) = DQ(1,JM,k) + sum2*RCAP + fz(1,JM,k) - fz(1,JM,k+1) +!%%% +!%%% do i=2,IM +!%%% DQ(i, 1,k) = DQ(1, 1,k) +!%%% DQ(i,JM,k) = DQ(1,JM,k) +!%%% enddo +!%%% +101 continue +C****6***0*********0*********0*********0*********0*********0**********72 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Call QCKXYZ w/ window arrays, etc. +!%%% + if(FILL) call qckxyz(DQ_w,DG3_w,IM_w,JM_w,NL,cosp_w, + & acosp_w,IC,NSTEP,DP,igzd, Jmax,fx_w, fy_w, fz_w ) + + !================================================================= + ! bey, 6/20/00. for mass-flux diagnostic + ! NOTE: DIAG_FLUX is not called within a parallel loop, + ! so parallelization can be done within the subroutine + !================================================================= + CALL DIAG_FLUX( IC, FX_w, FX1_TP_w, FY_w, FY1_TP_w, + & FZ_w, FZ1_TP_w, NDT, ACOSP_w, Jmax, + & I0_W, J0_W, IM_W, JM_W, IGZD ) + +!C****6***0*********0*********0*********0*********0*********0**********72 + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all +CMIC$* shared(q,IC,NL,j1,im,jm,jm1,DQ_w,delp2_w) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + DO 920 k=1,NL + + DO J = 1, JM_W + DO I = 1, IM_W + Q(I+I0_W,J+J0_W,K,IC) = DQ_W(I,J,K) / DELP2_W(I,J,K) + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%% +!%%% don't need the following polar part (yxw,08/28/01) +!%%% if(j1.ne.2) then +!%%% DO 450 I=1,IM +!%%% Q(I, 2,k,IC) = Q(I, 1,k,IC) +!%%% Q(I,JM1,k,IC) = Q(I,JM,k,IC) +!%%% 450 CONTINUE +!%%% endif +!%%% + 920 CONTINUE + 5000 CONTINUE + + ! Return to calling program + END SUBROUTINE TPCORE_WINDOW + +!------------------------------------------------------------------------------ + + subroutine cosa(cosp,cose,jm_w,j0_w,PI,DP,igzd,j0,Jmax) +!cosa_w (yxw, 8/23/2001) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL*8 cosp(-10:Jmax),cose(-10:Jmax), + & sine(-10:jm_w+igzd+2) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop boundaries +!%%% + DO J = -IGZD, JM_W+2+IGZD + PH5 = -0.5*PI + (FLOAT(J+J0_W+J0-1)-0.5)*DP + SINE(J) = SIN(PH5) + ENDDO + + DO J = -IGZD, JM_W+IGZD+1 + COSP(J) = (SINE(J+1)-SINE(J))/DP + ENDDO + +C Define cosine at edges.. + + DO J = 1-IGZD, JM_W+IGZD+1 + COSE(J) = 0.5 * (COSP(J-1)+COSP(J)) + ENDDO + + ! Return to TPCORE + END SUBROUTINE COSA + +!------------------------------------------------------------------------------ + + subroutine cosc(cosp,cose,jm_w,J1_w,j2_w,PI,DP,igzd,Jmax) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL*8 cosp(-10:Jmax),cose(-10:Jmax) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop boundaries +!%%% + PHI = -0.5*PI+(J1_W-IGZD-3)*DP + + DO J = -IGZD, JM_W+1+IGZD + PHI = PHI + DP + COSP(J) = COS(PHI) + ENDDO + + DO J = 1-IGZD, JM_W+IGZD+1 + COSE(J) = 0.5*(COSP(J)+COSP(J-1)) + ENDDO + + DO J = 1-IGZD, JM_W+IGZD + COSP(J) = 0.5*(COSE(J)+COSE(J+1)) + ENDDO + + ! Return to TPCORE + END SUBROUTINE COSC + +!------------------------------------------------------------------------------ + + subroutine filew(q,qtmp,IMR,JNP,ipx,tiny, fx) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL*8 q(IMR,*),qtmp(JNP,IMR), fx(IMR+1,JNP) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + ipx = 0 +C Copy & swap direction for vectorization. + do i=1,imr + do j=1,jnp + qtmp(j,i) = q(i,j) + ENDDO + ENDDO + + DO I = 2, IMR-1 + DO J = 1, JNP + IF(QTMP(J,I).LT.0.) THEN + IPX = 1 +! WEST + D0 = MAX(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 + FX(I,J) = FX(I,J)+D1 !(yxw,02/09/2003) +! EAST + D0 = MAX(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 + TINY + FX(I+1,J) = FX(I+1,J) - D2 !(yxw,02/09/2003) + ENDIF + ENDDO + ENDDO + + I=1 + do 65 j=1,JNP + if(qtmp(j,i).lt.0.) then + ipx = 1 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (bmy, 3/10/03) +!%%% Comment this out +!%%%c west +!%%% d0 = max(0.,qtmp(j,imr)) +!%%% d1 = min(-qtmp(j,i),d0) +!%%% qtmp(j,imr) = qtmp(j,imr) - d1 +!%%% qtmp(j,i) = qtmp(j,i) + d1 +!%%% +c east + d0 = max(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 + tiny + fx(i+1, j) = fx(i+1,j) - d2 !(yxw,02/09/2003) + endif +65 continue + i=IMR + do 75 j=1,JNP + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(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+tiny + fx(i,j) = fx(i,j) + d1 !(yxw,02/09/2003) +c east +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (bmy, 3/10/03) +!%%% Comment this out +!%%% d0 = max(0.,qtmp(j,1)) +!%%% d2 = min(-qtmp(j,i),d0) +!%%% qtmp(j,1) = qtmp(j,1) - d2 +!%%% +!%%% qtmp(j,i) = qtmp(j,i) + d2 + tiny +!%%% + endif +75 continue +C + if(ipx.ne.0) then + do 85 j=1,jnp + do 85 i=1,imr +85 q(i,j) = qtmp(j,i) +C else +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%%C Pole +!%%% if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1 +!%%% + endif + return + end subroutine filew + +!------------------------------------------------------------------------------ + + subroutine filns(q,IMR,JNP,cosp,acosp,ipy,tiny,DP,fy,Jmax) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL*8 q(IMR,*),cosp(-10:Jmax),acosp(-10:Jmax), fy(IMR,JNP+1) + LOGICAL first + DATA first /.true./ +C SAVE cap1 +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + if(first) then +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%% DP = 4.*ATAN(1.)/float(JNP-1) +!%%% cap1 = IMR*(1.-COS((j1-1.5)*DP))/DP +!%%% + first = .false. + endif +C + ipy = 0 + do 55 j=2,jNP-1 + DO 55 i=1,IMR + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C North + dn = q(i,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j+1) = (dn - d1)*acosp(j+1) + fy(i,j+1) = fy(i,j+1)-d1 !(yxw,02/09/2003) + dq = dq - d1 +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + fy(i,j)= fy(i,j) + d2 !(yxw,02/09/2003) + + endif +55 continue +C + + do i=1,imr + IF(q(i,1).LT.0.) THEN + ipy = 1 + dq = - q(i,1)*cosp(1) +C North + dn = q(i,1+1)*cosp(1+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,1+1) = (dn - d1)*acosp(1+1) + q(i,1) = (d1 - dq)*acosp(1) + tiny + fy(i,1+1) = fy(i,1) - d1 !(yxw,02/09/2003) + endif + + enddo + + j = JNP + do i=1,imr + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + fy(i,j) = fy(i,j) + d2 !(yxw,02/09/2003) + endif + + enddo ! (yxw,09/26/01) + +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%%C Check Poles. +!%%% if(q(1,1).lt.0.) then +!%%% dq = q(1,1)*cap1/float(IMR)*acosp(j1) +!%%% do i=1,imr +!%%% q(i,1) = 0. +!%%% q(i,j1) = q(i,j1) + dq +!%%% if(q(i,j1).lt.0.) ipy = 1 +!%%% enddo +!%%% endif +!%%% +!%%% if(q(1,JNP).lt.0.) then +!%%% dq = q(1,JNP)*cap1/float(IMR)*acosp(j2) +!%%% do i=1,imr +!%%% q(i,JNP) = 0. +!%%% q(i,j2) = q(i,j2) + dq +!%%% if(q(i,j2).lt.0.) ipy = 1 +!%%% enddo +!%%% endif +!%%% + return + end subroutine filns + +!------------------------------------------------------------------------------ + + subroutine fxppm(IMR,UT,P,DC,fx1,fx2,IORD,igzd) +C****6***0*********0*********0*********0*********0*********0**********72 + PARAMETER ( R3 = 1./3., R23 = 2./3. ) + REAL*8 UT(1-igzd:imr+igzd+1),fx1(IMR+1),P(1-igzd:imr+igzd), + & DC(1-igzd:imr+igzd) + REAL*8 AR(0:IMR+1),AL(0:IMR+1),A6(0:IMR+1),fx2(IMR+1) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + LMT = IORD - 3 + + DO i=0,IMR+1 + AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3 + ENDDO + + DO I=0,IMR + AR(i) = AL(i+1) + ENDDO + + AR(IMR+1)=0.5*(p(IMR+1)+p(IMR+2))+(DC(IMR+1)-DC(IMR+2))*R3 + + DO I=0,IMR+1 + A6(I) = 3.*(P(I)+P(I) - (AL(I)+AR(I))) + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Now call LMTPM_X instead of LMTPPM +!%%% + IF(LMT.LE.2) CALL LMTPPM_X(DC(:),A6(:),AR(:), + & AL(:),P(:),IMR,IGZD,LMT) + +C Abs(UT(i)) < 1 + DO I=1,IMR+1 + IF(UT(I).GT.0.) THEN + FX1(I) = P(I-1) + FX2(I) = AR(I-1) + 0.5*UT(I)*(AL(I-1) - AR(I-1) + + & A6(I-1)*(1.-R23*UT(I)) ) + ELSE + FX1(I) = P(I) + FX2(I) = AL(I) - 0.5*UT(I)*(AR(I) - AL(I) + + & A6(I)*(1.+R23*UT(I))) + ENDIF + ENDDO +C + DO I=1,IMR+1 + FX2(I) = FX2(I) - FX1(I) + ENDDO + + ! Return to TPCORE + END SUBROUTINE FXPPM + +!------------------------------------------------------------------------------ + + SUBROUTINE fyppm(C,P,DC,fy1,fy2,IMR,JNP,A6,AR,AL,JORD,igzd) +C****6***0*********0*********0*********0*********0*********0**********72 + PARAMETER ( R3 = 1./3., R23 = 2./3. ) + REAL*8 C(IMR,JNP+1),fy1(IMR,JNP+1), + & DC(IMR,-1:JNP+2) ,fy2(IMR,JNP+1), + & P(IMR,-2:JNP+3) + REAL*8 AR(IMR,0:JNP+1), AL(IMR,0:JNP+1),A6(IMR,0:JNP+1) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + + IMH = IMR / 2 + JMR = JNP - 1 + LMT = JORD - 3 + + DO i=1,IMR*(JNP+1) + AL(i,1) = 0.5*(p(i,0)+p(i,1)) + (DC(i,0) - DC(i,1))*R3 + AR(i,0) = AL(i,1) + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Add the following DO-loop +!%%% + do i=1,IMR + AL(i,0)=0.5*(p(i,-1)+p(i,0))+ + & (DC(i,-1)-DC(i,0))*R3 + AR(i,JNP+1)=0.5*(p(i,JNP+1)+p(i,JNP+2))+ + & (DC(i,JNP+1)-DC(i,JNP+2))*R3 + enddo +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%%C Poles: +!%%% +!%%% DO i=1,IMH +!%%% AL(i,1) = AL(i+IMH,2) +!%%% AL(i+IMH,1) = AL(i,2) +!%%% +!%%% AR(i,JNP) = AR(i+IMH,JMR) +!%%% AR(i+IMH,JNP) = AR(i,JMR) +!%%% enddo +!%%% +!%%% + DO I=1,IMR*(JNP+2) + A6(I,0) = 3.*(P(I,0)+P(I,0) - (AL(I,0)+AR(I,0))) + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Now call new routine LMTPPM_Y +!%%% + IF(LMT.le.2) call LMTPPM_Y( DC(:,:), A6(:,:), AR(:,:), + & AL(:,:), P(:,:), IMR, JNP, LMT ) + + DO I = 1, IMR*(JNP+1) + IF(C(I,1).GT.0.) THEN + FY1(I,1) = P(I,0) + FY2(I,1) = AR(I,0) + 0.5*C(I,1)*(AL(I,0) - AR(I,0) + + & A6(I,0)*(1.-R23*C(I,1)) ) + ELSE + FY1(I,1) = P(I,1) + FY2(I,1) = AL(I,1) - 0.5*C(I,1)*(AR(I,1) - AL(I,1) + + & A6(I,1)*(1.+R23*C(I,1))) + ENDIF + ENDDO + + DO I = 1, IMR*(JNP+1) + FY2(I,1) = FY2(I,1) - FY1(I,1) + ENDDO + + ! Return to TPCORE + END SUBROUTINE FYPPM + +!------------------------------------------------------------------------------ + + SUBROUTINE FZPPM(P,fz,IMR,JNP,NL,DQ,WZ,delp,KORD,fz1_tp) +C****6***0*********0*********0*********0*********0*********0**********72 + + ! Added to pass C-preprocessor switches (bmy, 3/9/01) +# include "define.h" + + PARAMETER ( R23 = 2./3., R3 = 1./3.) + REAL*8 WZ(IMR,JNP,NL), + & P(IMR,JNP,NL), + & DQ(IMR,JNP,NL), + & fz(IMR,JNP,NL+1),delp(IMR,JNP,NL) +C local 2d arrays + REAL*8 AR(IMR,NL),AL(IMR,NL),A6(IMR,NL),delq(IMR,NL),DC(IMR,NL) + +! bey, 6/20/00. for mass-flux diagnostic + REAL*8 fz1_tp(IMR,JNP,NL) + + REAL*8 lac +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Comment this out +!%%% REAL*8 x, y, z +!%%% REAL*8 median +!%%% median(x,y,z) = min(max(x,y), max(y,z), max(z,x)) +!%%% +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + km = NL + km1 = NL-1 + LMT = max(KORD - 3, 0) + +C find global min/max + + ! VMAX1D causes bus errors on SGI. Replace with F90 intrinsic + ! functions "MAXVAL" and "MINVAL". These functions produced + ! identical results as vmax1d in testing. "MAXVAL" and "MINVAL" + ! should also execute more efficiently as well. (bmy, 4/24/00) + Tmax = MAXVAL( P(:,:,1) ) + Tmin = MINVAL( P(:,:,1) ) + Bmax = MAXVAL( P(:,:,NL) ) + Bmin = MINVAL( P(:,:,NL) ) + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(LMT,Tmax,Tmin,Bmax,Bmin,JNP,IMR) +CMIC$* shared(fz,DQ,WZ,fz1_tp) +CMIC$* private(i,j,k,c1,c2,tmp,qmax,qmin,A1,A2,d1,d2,qm,dp,c3) +CMIC$* private(cmax,cmin,DC,delq,AR,AL,A6,CM,CP, qmp, lac) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K, C1, C2, TMP, QMAX, QMIN, A1, A2, +!$OMP+ D1, D2, QM, DP, C3, CMAX, CMIN, DC, DELQ, +!$OMP+ AR, AL, A6, CM, CP, QMP, LAC ) +#endif +#endif + + do 4000 j=1,JNP + + DO K = 2, KM + DO I = 1, IMR + A6(I,K) = DELP(I,J,K-1) + DELP(I,J,K) + ENDDO + ENDDO + + DO K = 1, KM1 + DO I = 1, IMR + DELQ(I,K) = P(I,J,K+1) - P(I,J,K) + ENDDO + ENDDO + + DO K = 2, KM1 + DO I = 1, IMR + C1 = (DELP(I,J,K-1)+0.5*DELP(I,J,K))/A6(I,K+1) + C2 = (DELP(I,J,K+1)+0.5*DELP(I,J,K))/A6(I,K) + TMP = DELP(I,J,K)*(C1*DELQ(I,K) + C2*DELQ(I,K-1)) + & / (A6(I,K)+DELP(I,J,K+1)) + QMAX = MAX(P(I,J,K-1),P(I,J,K),P(I,J,K+1)) - P(I,J,K) + QMIN = P(I,J,K) - MIN(P(I,J,K-1),P(I,J,K),P(I,J,K+1)) + DC(I,K) = SIGN(MIN(ABS(TMP),QMAX,QMIN), TMP) + ENDDO + ENDDO + +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute the first guess at cell interface +C First guesses are required to be continuous. +C****6***0*********0*********0*********0*********0*********0**********72 + +C Interior. + + DO K = 3, KM1 + DO I = 1, IMR + C1 = DELQ(I,K-1)*DELP(I,J,K-1) / A6(I,K) + A1 = A6(I,K-1) / (A6(I,K) + DELP(I,J,K-1)) + A2 = A6(I,K+1) / (A6(I,K) + DELP(I,J,K)) + AL(I,K) = P(I,J,K-1) + C1 + 2./(A6(I,K-1)+A6(I,K+1)) * + & ( DELP(I,J,K )*(C1*(A1 - A2)+A2*DC(I,K-1)) - + & DELP(I,J,K-1)*A1*DC(I,K ) ) + ENDDO + ENDDO + +C Area preserving cubic with 2nd deriv. = 0 at the boundaries +C Top + DO 10 I=1,IMR + D1 = DELP(I,J,1) + D2 = DELP(I,J,2) + QM = (D2*P(I,J,1)+D1*P(I,J,2)) / (D1+D2) + DP = 2.*(P(I,J,2)-P(I,J,1)) / (D1+D2) + C1 = 4.*(AL(I,3)-QM-D2*DP) / ( D2*(2.*D2*D2+D1*(D2+3.*D1)) ) + C3 = DP - 0.5*C1*(D2*(5.*D1+D2)-3.*D1**2) + AL(I,2) = QM - 0.25*C1*D1*D2*(D2+3.*D1) + AL(I,1) = D1*(2.*C1*D1**2-C3) + AL(I,2) + DC(I,1) = P(I,J,1) - AL(I,1) +C No over- and undershoot condition + AL(I,1) = MAX(TMIN,AL(I,1)) + AL(I,1) = MIN(TMAX,AL(I,1)) + CMAX = MAX(P(I,J,1), P(I,J,2)) + CMIN = MIN(P(I,J,1), P(I,J,2)) + AL(I,2) = MAX(CMIN,AL(I,2)) + AL(I,2) = MIN(CMAX,AL(I,2)) +10 CONTINUE + +C Bottom + DO 15 I=1,IMR + D1 = DELP(I,J,KM ) + D2 = DELP(I,J,KM1) + QM = (D2*P(I,J,KM)+D1*P(I,J,KM1)) / (D1+D2) + DP = 2.*(P(I,J,KM1)-P(I,J,KM)) / (D1+D2) + C1 = 4.*(AL(I,KM1)-QM-D2*DP) / (D2*(2.*D2*D2+D1*(D2+3.*D1))) + C3 = DP - 0.5*C1*(D2*(5.*D1+D2)-3.*D1**2) + AL(I,KM) = QM - 0.25*C1*D1*D2*(D2+3.*D1) + AR(I,KM) = D1*(2.*C1*D1**2-C3) + AL(I,KM) + DC(I,KM) = AR(I,KM) - P(I,J,KM) +C No over- and undershoot condition + CMAX = MAX(P(I,J,KM), P(I,J,KM1)) + CMIN = MIN(P(I,J,KM), P(I,J,KM1)) + AL(I,KM) = MAX(CMIN,AL(I,KM)) + AL(I,KM) = MIN(CMAX,AL(I,KM)) + AR(I,KM) = MAX(BMIN,AR(I,KM)) + AR(I,KM) = MIN(BMAX,AR(I,KM)) + 15 CONTINUE + + DO K=1,KM1 + DO I=1,IMR + AR(I,K) = AL(I,K+1) + ENDDO + ENDDO + +C f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 ) +C Top 2 layers + DO K=1,2 + DO I=1,IMR + A6(I,K) = 3.*(P(I,J,K)+P(I,J,K) - (AL(I,K)+AR(I,K))) + ENDDO +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Now call new routine LMTPPM_Z +!%%% + CALL LMTPPM_Z(DC(1,K),A6(1,K),AR(1,K),AL(1,K),P(1,J,K), + & IMR,0) + ENDDO + +C Interior. + IF(LMT.LE.2) THEN + DO K=3,NL-2 + DO I=1,IMR + A6(I,K) = 3.*(P(I,J,K)+P(I,J,K) - (AL(I,K)+AR(I,K))) + ENDDO +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Now call new routine LMTPPM_Z +!%%% + CALL LMTPPM_Z(DC(1,K),A6(1,K),AR(1,K),AL(1,K),P(1,J,K), + & IMR,LMT) + ENDDO + + ELSEIF(LMT .EQ. 4) THEN + +c****6***0*********0*********0*********0*********0*********0**********72 +C Huynh's 2nd constraint +c****6***0*********0*********0*********0*********0*********0**********72 + + DO K=2, NL-1 + DO I=1,IMR + DC(I,K) = DELQ(I,K) - DELQ(I,K-1) + ENDDO + ENDDO + + DO K=3, NL-2 + DO I=1, IMR +C Right edges + QMP = P(I,J,K) + 2.0*DELQ(I,K-1) + LAC = P(I,J,K) + 1.5*DC(I,K-1) + 0.5*DELQ(I,K-1) + QMIN = MIN(P(I,J,K), QMP, LAC) + QMAX = MAX(P(I,J,K), QMP, LAC) +C AR(I,K) = MEDIAN(AR(I,K), QMIN, QMAX) + AR(I,K) = MIN(MAX(AR(I,K), QMIN), QMAX) +C Left edges + QMP = P(I,J,K) - 2.0*DELQ(I,K) + LAC = P(I,J,K) + 1.5*DC(I,K+1) - 0.5*DELQ(I,K) + QMIN = MIN(P(I,J,K), QMP, LAC) + QMAX = MAX(P(I,J,K), QMP, LAC) +c AL(i,k) = median(AL(i,k), qmin, qmax) + AL(I,K) = MIN(MAX(AL(I,K), QMIN), QMAX) +C Recompute A6 + A6(I,K) = 3.*(2.*P(I,J,K) - (AR(I,K)+AL(I,K))) + ENDDO + ENDDO + ENDIF + +C Bottom 2 layers + DO K=NL-1,NL + DO I=1,IMR + A6(I,K) = 3.*(P(I,J,K)+P(I,J,K) - (AL(I,K)+AR(I,K))) + ENDDO +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Now call new routine LMTPPM_Z +!%%% + CALL LMTPPM_Z(DC(1,K),A6(1,K),AR(1,K),AL(1,K),P(1,J,K), + & IMR,0) + enddo + + DO K = 2, NL + DO I = 1, IMR + IF(WZ(I,J,K-1).GT.0.) THEN + CM = WZ(I,J,K-1) / DELP(I,J,K-1) + DC(I,K) = P(I,J,K-1) + FZ(I,J,K) = AR(I,K-1)+0.5*CM*(AL(I,K-1)-AR(I,K-1)+ + & A6(I,K-1)*(1.-R23*CM)) + ELSE + CP = WZ(I,J,K-1) / DELP(I,J,K) + DC(I,K) = P(I,J,K) + FZ(I,J,K) = AL(I,K)+0.5*CP*(AL(I,K)-AR(I,K)- + & A6(I,K)*(1.+R23*CP)) + ENDIF + ENDDO + ENDDO + + DO K = 2, NL + DO I = 1, IMR + FZ(I,J,K) = WZ(I,J,K-1) * (FZ(I,J,K) - DC(I,K)) + DC(I,K) = WZ(I,J,K-1) * DC(I,K) + ENDDO + ENDDO + + DO 350 I=1,IMR + FZ(I,J, 1) = 0. + FZ(I,J,NL+1) = 0. + DQ(I,J, 1) = DQ(I,J, 1) - DC(I, 2) + DQ(I,J,NL) = DQ(I,J,NL) + DC(I,NL) + FZ1_TP(I,J,NL) = DC(I,NL) !(yxw, 01/21/2003) + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !%%% ERROR! FZ1_TP is only declared with NL layers. This line + !%%% causes an out-of-bounds error which causes the run to die + !%%% when running on the ALTIX platform. Comment out. (bmy, 11/9/04) + !%%%FZ1_TP(I,J,NL+1) = 0 !(yxw, 02/09/2003) + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + FZ1_TP(I,J,1) = 0. !(yxw, 01/21/2003) + 350 CONTINUE + +!----------------------------------------------------------------------------- +! bey, 6/20/00. for mass-flux diagnostic, loop had to be extended +! do 360 k=2,km1 +! do 360 i=1,IMR +!360 DQ(i,j,k) = DQ(i,j,k) + DC(i,k) - DC(i,k+1) +!----------------------------------------------------------------------------- + DO K=2,KM1 + DO I=1,IMR + DQ(I,J,K) = DQ(I,J,K) + DC(I,K) - DC(I,K+1) + + ! bey, 6/20/00. for mass-flux diagnostic + FZ1_TP(I,J,K) = DC(I,K) + ENDDO + ENDDO + +4000 CONTINUE + + ! Return to TPCORE + END SUBROUTINE FZPPM + +!------------------------------------------------------------------------------ + + SUBROUTINE HILO(Q,IM,JM,QMAX,QMIN,BT,BD) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL*8 q(IM,JM),Qmax(IM,JM),Qmin(IM,JM),bt(IM,*),bd(IM,*) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C y-sweep + DO J = 1, JM + DO I = 0, IM+1 + BT(I,J) = MAX(Q(I,J-1),Q(I,J),Q(I,J+1)) + BD(I,J) = MIN(Q(I,J-1),Q(I,J),Q(I,J+1)) + ENDDO + ENDDO +C +C x-sweep +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Comment this line out +!%%% IM1 = IM-1 +!%%% + DO J = 1, JM + DO I = 1, IM + QMAX(I,J) = MAX(BT(I-1,J),BT(I,J),BT(I+1,J)) + QMIN(I,J) = MIN(BD(I-1,J),BD(I,J),BD(I+1,J)) + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%% +!%%% +!%%% don't need the following part (yxw,08/27/01) +!%%% +!%%% DO j=j1,j2 +!%%% i = 1 +!%%% Qmax(1,j) = max(bt(IM,j),bt(1,j),bt(2,j)) +!%%% Qmin(1,j) = min(bd(IM,j),bd(1,j),bd(2,j)) +!%%% i = IM +!%%% Qmax(IM,j) = max(bt(IM1,j),bt(IM,j),bt(1,j)) +!%%% Qmin(IM,j) = min(bd(IM1,j),bd(IM,j),bd(1,j)) +!%%% enddo +!%%% +!%%%C N. Pole: +!%%% Pmax = q(1,JM) +!%%% Pmin = q(1,JM) +!%%% do i=1,IM +!%%% if(q(i,j2) .gt. Pmax) then +!%%% Pmax = q(i,j2) +!%%% elseif(q(i,j2) .lt. Pmin) then +!%%% Pmin = q(i,j2) +!%%% endif +!%%% enddo +!%%% +!%%% do i=1,IM +!%%% Qmax(i,JM) = Pmax +!%%% Qmin(i,JM) = Pmin +!%%% enddo +!%%% +!%%%C S. Pole: +!%%% Pmax = q(1,1) +!%%% Pmin = q(1,1) +!%%% do i=1,IM +!%%% if(q(i,j1) .gt. Pmax) then +!%%% Pmax = q(i,j1) +!%%% elseif(q(i,j1) .lt. Pmin) then +!%%% Pmin = q(i,j1) +!%%% endif +!%%% enddo +!%%% +!%%% do i=1,IM +!%%% Qmax(i,1) = Pmax +!%%% Qmin(i,1) = Pmin +!%%% enddo +!%%% +!%%% if(j1 .ne. 2) then +!%%% JM1 = JM-1 +!%%% do i=1,IM +!%%% Qmax(i,2) = Qmax(i,1) +!%%% Qmin(i,2) = Qmin(i,1) +!%%% +!%%% Qmax(i,JM1) = Qmax(i,JM) +!%%% Qmin(i,JM1) = Qmin(i,JM) +!%%% enddo +!%%% endif + + ! Return to TPCORE + END SUBROUTINE HILO + +!------------------------------------------------------------------------------ + + SUBROUTINE HILO3D(P,IM,JM,KM,PMAX,PMIN,QMAX,QMIN,BT,BD) +C****6***0*********0*********0*********0*********0*********0**********72 + + ! Added to pass C-preprocessor switches (bmy, 3/9/01) +# include "define.h" + + REAL*8 P(IM+2,JM+2,km),Pmax(IM,JM,km),Pmin(IM,JM,km), + & Qmax(IM,JM,km),Qmin(IM,JM,km),bt(im,jm),bd(im,jm) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(P,Qmax,Qmin,im,jm,j1,j2) +CMIC$* private(k,bt,bd) +#else +!$OMP PARALLEL DO PRIVATE( K, BT, BD ) +#endif +#endif + + DO 1000 K=1,KM + CALL HILO(P(1,1,K),IM,JM,QMAX(1,1,K),QMIN(1,1,K),BT,BD) +1000 CONTINUE + + KM1 = KM-1 + KM2 = KM-2 + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(Pmax,Pmin,Qmax,Qmin,im,jm,km,km1,km2) +CMIC$* private(i,j) +#else +!$OMP PARALLEL DO PRIVATE( I, J ) +#endif +#endif + + DO J = 1, JM + DO I = 1, IM +C k=1 and k=km + PMAX(I,J, 1) = MAX(QMAX(I,J, 2),QMAX(I,J, 1)) + PMIN(I,J, 1) = MIN(QMIN(I,J, 2),QMIN(I,J, 1)) + PMAX(I,J,KM) = MAX(QMAX(I,J,KM1),QMAX(I,J,KM)) + PMIN(I,J,KM) = MIN(QMIN(I,J,KM1),QMIN(I,J,KM)) +C k=2 and k=km1 + PMAX(I,J, 2) = MAX(QMAX(I,J, 3),PMAX(I,J, 1)) + PMIN(I,J, 2) = MIN(QMIN(I,J, 3),PMIN(I,J, 1)) + PMAX(I,J,KM1) = MAX(QMAX(I,J,KM2),PMAX(I,J,KM)) + PMIN(I,J,KM1) = MIN(QMIN(I,J,KM2),PMIN(I,J,KM)) + ENDDO + ENDDO + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* shared(Pmax,Pmin,Qmax,Qmin,im,jm,km,km1,km2) +CMIC$* private(i,j,k) +#else +!$OMP PARALLEL DO PRIVATE( I, J, K ) +#endif +#endif + + DO K = 3, KM2 + DO J = 1, JM + DO I = 1, IM + PMAX(I,J,K) = MAX(QMAX(I,J,K-1),QMAX(I,J,K),QMAX(I,J,K+1)) + PMIN(I,J,K) = MIN(QMIN(I,J,K-1),QMIN(I,J,K),QMIN(I,J,K+1)) + ENDDO + ENDDO + ENDDO + + ! Return to TPCORE + END SUBROUTINE HILO3D + +!------------------------------------------------------------------------------ + + SUBROUTINE LMTPPM_X(DC,A6,AR,AL,P,IM,IGZD,LMT) +C****6***0*********0*********0*********0*********0*********0**********72 +C +C A6 = CURVATURE OF THE TEST PARABOLA +C AR = RIGHT EDGE VALUE OF THE TEST PARABOLA +C AL = LEFT EDGE VALUE OF THE TEST PARABOLA +C DC = 0.5 * MISMATCH +C P = CELL-AVERAGED VALUE +C IM = VECTOR LENGTH +C +C OPTIONS: +C +C LMT = 0: FULL MONOTONICITY +C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS) +C LMT = 2: POSITIVE-DEFINITE CONSTRAINT +C + PARAMETER ( R12 = 1./12. ) + REAL*8 A6(0:IM+1),AR(0:IM+1),AL(0:IM+1), + & P(1-igzd:im+igzd),DC(1-igzd:im+igzd) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + IF(LMT.EQ.0) THEN +C FULL CONSTRAINT + DO 100 I=0,IM+1 + IF(DC(I).EQ.0.) THEN + AR(I) = P(I) + AL(I) = P(I) + A6(I) = 0. + ELSE + DA1 = AR(I) - AL(I) + DA2 = DA1**2 + A6DA = A6(I)*DA1 + IF(A6DA .LT. -DA2) THEN + A6(I) = 3.*(AL(I)-P(I)) + AR(I) = AL(I) - A6(I) + ELSEIF(A6DA .GT. DA2) THEN + A6(I) = 3.*(AR(I)-P(I)) + AL(I) = AR(I) - A6(I) + ENDIF + ENDIF + 100 CONTINUE + ELSEIF(LMT.EQ.1) THEN +C SEMI-MONOTONIC CONSTRAINT + DO 150 I=0,IM+1 + IF(ABS(AR(I)-AL(I)) .GE. -A6(I)) GO TO 150 + IF(P(I).LT.AR(I) .AND. P(I).LT.AL(I)) THEN + AR(I) = P(I) + AL(I) = P(I) + A6(I) = 0. + ELSEIF(AR(I) .GT. AL(I)) THEN + A6(I) = 3.*(AL(I)-P(I)) + AR(I) = AL(I) - A6(I) + ELSE + A6(I) = 3.*(AR(I)-P(I)) + AL(I) = AR(I) - A6(I) + ENDIF + 150 CONTINUE + ELSEIF(LMT.EQ.2) THEN + DO 250 I=0,IM+1 + IF(ABS(AR(I)-AL(I)) .GE. -A6(I)) GO TO 250 + FMIN = P(I) + 0.25*(AR(I)-AL(I))**2/A6(I) + A6(I)*R12 + IF(FMIN.GE.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) = 0. + ELSEIF(AR(I) .GT. AL(I)) THEN + A6(I) = 3.*(AL(I)-P(I)) + AR(I) = AL(I) - A6(I) + ELSE + A6(I) = 3.*(AR(I)-P(I)) + AL(I) = AR(I) - A6(I) + ENDIF + 250 CONTINUE + ENDIF + + ! Return to TPCORE + END SUBROUTINE LMTPPM_X + +!------------------------------------------------------------------------------ + + SUBROUTINE LMTPPM_Y(DC,A6,AR,AL,P,IM,JNP,LMT) +C****6***0*********0*********0*********0*********0*********0**********72 +C +C A6 = CURVATURE OF THE TEST PARABOLA +C AR = RIGHT EDGE VALUE OF THE TEST PARABOLA +C AL = LEFT EDGE VALUE OF THE TEST PARABOLA +C DC = 0.5 * MISMATCH +C P = CELL-AVERAGED VALUE +C IM = VECTOR LENGTH +C +C OPTIONS: +C +C LMT = 0: FULL MONOTONICITY +C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS) +C LMT = 2: POSITIVE-DEFINITE CONSTRAINT +C + PARAMETER ( R12 = 1./12. ) + REAL*8 A6(IM,0:JNP+1),AR(IM,0:JNP+1),AL(IM,0:JNP+1), + & P(IM,-2:JNP+3),DC(IM,-1:JNP+2) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + IF(LMT.EQ.0) THEN +C FULL CONSTRAINT + DO 100 I=1,IM*(JNP+2) + IF(DC(I,0).EQ.0.) THEN + AR(I,0) = P(I,0) + AL(I,0) = P(I,0) + A6(I,0) = 0. + ELSE + DA1 = AR(I,0) - AL(I,0) + DA2 = DA1**2 + A6DA = A6(I,0)*DA1 + IF(A6DA .LT. -DA2) THEN + A6(I,0) = 3.*(AL(I,0)-P(I,0)) + AR(I,0) = AL(I,0) - A6(I,0) + ELSEIF(A6DA .GT. DA2) THEN + A6(I,0) = 3.*(AR(I,0)-P(I,0)) + AL(I,0) = AR(I,0) - A6(I,0) + ENDIF + ENDIF + 100 CONTINUE + ELSEIF(LMT.EQ.1) THEN +C SEMI-MONOTONIC CONSTRAINT + DO 150 I=1,IM*(JNP+2) + IF(ABS(AR(I,0)-AL(I,0)) .GE. -A6(I,0)) GO TO 150 + IF(P(I,0).LT.AR(I,0) .AND. P(I,0).LT.AL(I,0)) THEN + AR(I,0) = P(I,0) + AL(I,0) = P(I,0) + A6(I,0) = 0. + ELSEIF(AR(I,0) .GT. AL(I,0)) THEN + A6(I,0) = 3.*(AL(I,0)-P(I,0)) + AR(I,0) = AL(I,0) - A6(I,0) + ELSE + A6(I,0) = 3.*(AR(I,0)-P(I,0)) + AL(I,0) = AR(I,0) - A6(I,0) + ENDIF + 150 CONTINUE + ELSEIF(LMT.EQ.2) THEN + DO 250 I=1,IM*(JNP+2) + IF(ABS(AR(I,0)-AL(I,0)) .GE. -A6(I,0)) GO TO 250 + FMIN = P(I,0) + 0.25*(AR(I,0)-AL(I,0))**2/A6(I,0) + + & A6(I,0)*R12 + IF(FMIN.GE.0.) GO TO 250 + IF(P(I,0).LT.AR(I,0) .AND. P(I,0).LT.AL(I,0)) THEN + AR(I,0) = P(I,0) + AL(I,0) = P(I,0) + A6(I,0) = 0. + ELSEIF(AR(I,0) .GT. AL(I,0)) THEN + A6(I,0) = 3.*(AL(I,0)-P(I,0)) + AR(I,0) = AL(I,0) - A6(I,0) + ELSE + A6(I,0) = 3.*(AR(I,0)-P(I,0)) + AL(I,0) = AR(I,0) - A6(I,0) + ENDIF + 250 CONTINUE + ENDIF + + ! Return to TPCORE + END SUBROUTINE LMTPPM_Y + +!------------------------------------------------------------------------------ + + SUBROUTINE LMTPPM_Z(DC,A6,AR,AL,P,IM,LMT) +C****6***0*********0*********0*********0*********0*********0**********72 +C +C A6 = CURVATURE OF THE TEST PARABOLA +C AR = RIGHT EDGE VALUE OF THE TEST PARABOLA +C AL = LEFT EDGE VALUE OF THE TEST PARABOLA +C DC = 0.5 * MISMATCH +C P = CELL-AVERAGED VALUE +C IM = VECTOR LENGTH +C +C OPTIONS: +C +C LMT = 0: FULL MONOTONICITY +C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS) +C LMT = 2: POSITIVE-DEFINITE CONSTRAINT +C + PARAMETER ( R12 = 1./12. ) + REAL*8 A6(IM),AR(IM),AL(IM),P(IM),DC(IM) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + IF(LMT.EQ.0) THEN +C FULL CONSTRAINT + DO 100 I=1,IM + IF(DC(I).EQ.0.) THEN + AR(I) = P(I) + AL(I) = P(I) + A6(I) = 0. + ELSE + DA1 = AR(I) - AL(I) + DA2 = DA1**2 + A6DA = A6(I)*DA1 + IF(A6DA .LT. -DA2) THEN + A6(I) = 3.*(AL(I)-P(I)) + AR(I) = AL(I) - A6(I) + ELSEIF(A6DA .GT. DA2) THEN + A6(I) = 3.*(AR(I)-P(I)) + AL(I) = AR(I) - A6(I) + ENDIF + ENDIF + 100 CONTINUE + ELSEIF(LMT.EQ.1) THEN +C SEMI-MONOTONIC CONSTRAINT + DO 150 I=1,IM + IF(ABS(AR(I)-AL(I)) .GE. -A6(I)) GO TO 150 + IF(P(I).LT.AR(I) .AND. P(I).LT.AL(I)) THEN + AR(I) = P(I) + AL(I) = P(I) + A6(I) = 0. + ELSEIF(AR(I) .GT. AL(I)) THEN + A6(I) = 3.*(AL(I)-P(I)) + AR(I) = AL(I) - A6(I) + ELSE + A6(I) = 3.*(AR(I)-P(I)) + AL(I) = AR(I) - A6(I) + ENDIF + 150 CONTINUE + ELSEIF(LMT.EQ.2) THEN + DO 250 I=1,IM + IF(ABS(AR(I)-AL(I)) .GE. -A6(I)) GO TO 250 + FMIN = P(I) + 0.25*(AR(I)-AL(I))**2/A6(I) + A6(I)*R12 + IF(FMIN.GE.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) = 0. + ELSEIF(AR(I) .GT. AL(I)) THEN + A6(I) = 3.*(AL(I)-P(I)) + AR(I) = AL(I) - A6(I) + ELSE + A6(I) = 3.*(AR(I)-P(I)) + AL(I) = AR(I) - A6(I) + ENDIF + 250 CONTINUE + ENDIF + + ! Return to TPCORE + END SUBROUTINE LMTPPM_Z + +!------------------------------------------------------------------------------ + + SUBROUTINE QCKXYZ(Q,QTMP,IMR,JNP,NLAY,COSP,ACOSP,IC,NSTEP,DP, + & IGZD, JMAX,FX, FY, FZ) +C****6***0*********0*********0*********0*********0*********0**********72 + + ! Added to pass C-preprocessor switches (bmy, 3/9/01) +# include "define.h" + + PARAMETER ( tiny = 1.E-30 ) + PARAMETER ( kmax = 200 ) + REAL*8 Q(IMR,JNP,NLAY),qtmp(JNP, IMR),cosp(-10:Jmax), + & acosp(-10:Jmax) + REAL*8 fx(IMR+1, JNP, NLAY), fy(IMR, JNP+1, NLAY), + & fz(IMR, JNP, NLAY+1) !(yxw, 02/09/2003) + integer IP(kmax) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + NLM1 = NLAY-1 + +C Do horizontal filling. + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* private(i,j,L,qtmp) +#else +!$OMP PARALLEL DO PRIVATE( I, J, L, QTMP ) +#endif +#endif + + DO 1000 L=1,NLAY + CALL FILNS(Q(1,1,L),IMR,JNP,COSP,ACOSP,IP(L),TINY,DP, + & FY(1,1,L), JMAX) +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Call FILEW + IF(IP(L).NE.0) + & CALL FILEW(Q(1,1,L),QTMP,IMR,JNP,IP(L),TINY, FX(1,1,L)) + +1000 CONTINUE + + IPZ = 0 + DO L=1,NLAY + IF(IP(L) .NE. 0) THEN + IPZ = L + GO TO 111 + ENDIF + ENDDO + RETURN + + 111 CONTINUE + + IF(IPZ .EQ. 0) RETURN + + IF(IPZ .EQ. 1) THEN + LPZ = 2 + ELSE + LPZ = IPZ + ENDIF + +C Do vertical filling. + +#if defined( multitask ) +#if defined( CRAY ) +CMIC$ do all autoscope +CMIC$* private(i,j,L,qup,qly,dup) +#else +!$OMP PARALLEL DO PRIVATE( I, J, L, QUP, QLY, DUP ) +#endif +#endif + + DO 2000 J=1,JNP + + IF(IPZ .EQ. 1) THEN +C Top layer + DO I=1,IMR + IF(Q(I,J,1).LT.0.) THEN + Q(I,J,2) = Q(I,J,2) + Q(I,J,1) + FZ(I,J,2) = FZ(I,J,2) + Q(I,J,1) !(yxw,02/09/2003) + Q(I,J,1) = 0. + ENDIF + ENDDO + ENDIF + + DO 225 L = LPZ,NLM1 + DO I=1,IMR + IF( Q(I,J,L).LT.0.) THEN +C From above + QUP = Q(I,J,L-1) + QLY = -Q(I,J,L) + DUP = MIN(QLY,QUP) + Q(I,J,L-1) = QUP - DUP + Q(I,J,L ) = DUP-QLY + FZ(I,J,L)= FZ(I,J,L-1) + DUP +C Below + Q(I,J,L+1) = Q(I,J,L+1) + Q(I,J,L) + FZ(I,J,L+1)= FZ(I,J,L+1)+ Q(I,J,L) !(yxw, 02/09/2003) + Q(I,J,L) = 0. + ENDIF + ENDDO + 225 CONTINUE + +C BOTTOM LAYER + L = NLAY + DO I=1,IMR + IF( Q(I,J,L).LT.0.) THEN +C From above + QUP = Q(I,J,NLM1) + QLY = -Q(I,J,L) + DUP = MIN(QLY,QUP) + Q(I,J,NLM1) = QUP - DUP + FZ(I,J,L) = FZ(I,J,L) + DUP !(yxw,02/09/2003) +C From "below" the surface. + Q(I,J,L) = 0. + FZ(I,J,L+1) = FZ(I,J,L+1) + DUP - QLY + ENDIF + ENDDO + 2000 CONTINUE + + ! Return to TPCORE + END SUBROUTINE qckxyz + +!------------------------------------------------------------------------------ + + SUBROUTINE XADV( IM_W, JM_W, P, UA, JS, JN, ADX_W, + & IGZD, IMR, JNP, I0_W, J0_W, I0, J0 ) !( yxw,08/23/01) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL*8 p(IMR,JNP),adx_w(1-igzd:im_w+igzd,1-igzd:jm_w+igzd), + & qtmp(1-igzd:im_w+igzd),UA(1-igzd:im_w+igzd,1-igzd:jm_w+igzd) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C + do 1309 j=1-igzd,jm_w+igzd + if((J+j0_w+j0) .GT.JS .and.(J+j0_w+j0).LT.JN) GO TO 1309 + + do i=1-igzd,IM_w+igzd + qtmp(i) = p(i+i0_w,j+j0_w) + enddo + +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Comment this out +!%%% do i=-IML,0 +!%%% qtmp(i) = p(IMR+i,j) +!%%% qtmp(IMR+1-i) = p(1-i,j) +!%%% enddo +!%%% +!%%% + DO I=1-IGZD,IM_W+IGZD + IU = UA(I,J) + RU = UA(I,J) - IU + IIU = I+I0_W-IU + IF(UA(I,J).GE.0.) THEN + IF (IIU .LT. 2) THEN + IIU=2 + ELSEIF (IIU .GT. IMR) THEN + IIU=IMR + ENDIF + ADX_W(I,J) = P(IIU,J+J0_W)+RU*(P(IIU-1,J+J0_W) + & -P(IIU,J+J0_W)) + ELSE + IF (IIU .LT. 1) THEN + IIU=1 + ELSEIF (IIU .GT. IMR-1) THEN + IIU=IMR-1 + ENDIF + ADX_W(I,J) = P(IIU,J+J0_W)+RU*(P(IIU,J+J0_W)- + & P(IIU+1,J+J0_W)) + ENDIF + ENDDO + + DO I=1-IGZD,IM_W+IGZD + ADX_W(I,J) = ADX_W(I,J) - P(I+I0_W,J+J0_W) + ENDDO + 1309 CONTINUE + +C Eulerian upwind + + DO J=JS+1-J0_W-J0,JN-1-J0_W-J0 +C + + DO I=1-IGZD,IM_W+IGZD + QTMP(I) = P(I+I0_W,J+J0_W) + ENDDO + + DO I=1-IGZD,IM_W+IGZD + IP = FLOAT(I+I0_W) - UA(I,J) + IF (IP .GT. IMR-1) THEN + IP=IMR-1 + ELSE IF(IP .LT. 1) THEN + IP=1 + ENDIF + ADX_W(I,J) = UA(I,J)*(P(IP,J+J0_W)-P(IP+1,J+J0_W)) + ENDDO + + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/030 +!%%% Polar cap stuff, useless for nested simulation +!%%%C don't need the following polar part (yxw, 08/23/01) +!%%% if(j1.ne.2) then +!%%% do i=1,IMR +!%%% adx(i, 2) = 0. +!%%% adx(i,JMR) = 0. +!%%% enddo +!%%% endif +!%%% +!%%%C set cross term due to x-adv at the poles to zero. +!%%% do i=1,IMR +!%%% adx(i, 1) = 0. +!%%% adx(i,JNP) = 0. +!%%% enddo +!%%% + + ! Return to TPCORE + END SUBROUTINE XADV + +!------------------------------------------------------------------------------ + + SUBROUTINE XMIST(IMR,P,DC,igzd) +C****6***0*********0*********0*********0*********0*********0**********72 + REAL*8 P(1-igzd:IMR+igzd),DC(1-igzd:IMR+igzd) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C +C 2nd order version. +C + DC(:)=0d0 ! initialization (yxw,09/28/01) + + DO I=2-IGZD,IMR+IGZD-1 + TMP = 0.25*(P(I+1) - P(I-1)) + PMAX = MAX(P(I-1), P(I), P(I+1)) - P(I) + PMIN = P(I) - MIN(P(I-1), P(I), P(I+1)) + DC(I) = SIGN(MIN(ABS(TMP),PMAX,PMIN), TMP) + ENDDO + + ! Return to TPCORE + END SUBROUTINE XMIST + +!------------------------------------------------------------------------------ + + SUBROUTINE XTP(IM_W,JM_W,IGZD,JN,JS,PU,DQ,Q,C,FX2,XMASS,IORD, + & FX1_TP,I0_W,J0_W,I0,J0) +C****6***0*********0*********0*********0*********0*********0**********72 + + REAL*8 C(1-IGZD:IM_W+1+IGZD,1-IGZD:JM_W+IGZD), + & FX1(IM_W+1), DC(1-IGZD:IM_W+IGZD), + & DQ(IM_W,JM_W),QTMP(1-IGZD:IM_W+IGZD),XMASS(IM_W+1,JM_W) + REAL*8 PU(IM_W+1,JM_W),Q(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD) + REAL*8 FX2(IM_W+1,JM_W) + INTEGER ISAVE(IM_W) +! bey, 6/20/00. for mass-flux diagnostic + REAL*8 FX1_TP(IM_W,JM_W) + +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + IMP = im_w + 1 +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%%C van Leer at high latitudes +!%%% jvan = max(1,jm/20) +!%%% j1vl = j1+jvan +!%%% j2vl = j2-jvan +!%%% + do 1310 j=1,jm_w +C + do i=1-igzd,im_w+igzd + qtmp(i) = q(i,j) + enddo +C + if(j .ge.(JN-j0_w-J0) .or. j .le. (JS-j0_w-J0)) goto 2222 +C****6***0*********0*********0*********0*********0*********0**********72 +C *** Eulerian *** +C****6***0*********0*********0*********0*********0*********0**********72 + +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%%C don't need the following. (yxw,08/23/01) +!%%% qtmp(0) = q(im,J) +!%%% qtmp(-1) = q(im-1,J) +!%%% qtmp(IMP) = q(1,J) +!%%% qtmp(IMP+1) = q(2,J) +!%%% + IF(IORD.EQ.1) THEN + DO I=1,IM_W+1 + IU = FLOAT(I) - C(I,J) + FX1(I) = QTMP(IU) + ENDDO + +C Zero high order contribution + DO I=1,IM_W+1 + FX2(I,J) = 0. + ENDDO + ELSE + CALL XMIST(IM_W,QTMP,DC,IGZD) + DC(1-IGZD)=DC(2-IGZD) + DC(IM_W+IGZD)=DC(IM_W+IGZD-1) +C + IF(IORD.EQ.2) THEN + DO I=1,IM_W+1 + IU = FLOAT(I) - C(I,J) + FX1(I ) = QTMP(IU) + FX2(I,J) = DC(IU)*(SIGN(1.d0,C(I,J))-C(I,J)) + ENDDO + ELSE + CALL FXPPM(IM_W,C(:,J),QTMP(:),DC(:),FX1(:),FX2(:,J),IORD,IGZD) + ENDIF +C + ENDIF +C + DO I=1,IM_W+1 + FX1(I ) = FX1(I )*XMASS(I,J) + FX2(I,J) = FX2(I,J)*XMASS(I,J) + ENDDO +C + GOTO 1309 +C +C****6***0*********0*********0*********0*********0*********0**********72 +C *** Conservative (flux-form) Semi-Lagrangian transport *** +C****6***0*********0*********0*********0*********0*********0**********72 + + 2222 CONTINUE +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Don't need ghost zones +!%%%C ghost zone for the western edge: +!%%% iuw = -c(1,j) +!%%% iuw = min(0, iuw) +!%%% +!%%% do i=iuw, 0 +!%%% qtmp(i) = q(im+i,j) +!%%% enddo +!%%% +!%%%C ghost zone for the eastern edge: +!%%% iue = imp - c(im,j) +!%%% iue = max(imp, iue) +!%%% +!%%% do i=imp, iue +!%%% qtmp(i) = q(i-im,j) +!%%% enddo +!%%% + IF(IORD.EQ.1) THEN + DO I=1,IM_W+1 + IU = C(I,J) + IF(C(I,J) .LE. 0.) THEN + ITMP = I+I0_W - IU + ISAVE(I) = ITMP - 1 + ELSE + ITMP = I+I0_W - IU - 1 + ISAVE(I) = ITMP + 1 + ENDIF + IF (ITMP .GT. IM_W+IGZD+I0_W) THEN + ITMP=IM_W+IGZD+I0_W + ELSE IF (ITMP .LT. 1-IGZD+I0_W) THEN + ITMP=1-IGZD+I0_W + ENDIF + FX1(I) = (C(I,J)-IU) * QTMP(ITMP-I0_W) + ENDDO + +C Zero high order contribution + DO I=1,IM_W+1 + FX2(I,J) = 0. + ENDDO + + ELSE + CALL XMIST(IM_W,QTMP,DC,IGZD) + DC(1-IGZD) = DC(2-IGZD) + DC(IM_W+IGZD)=DC(IM_W+IGZD-1) +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Don't need ghost zones +!%%% do i=iuw, 0 +!%%% dc(i) = dc(im+i) +!%%% enddo +!%%% +!%%% do i=imp, iue +!%%% dc(i) = dc(i-im) +!%%% enddo +!%%% + DO I=1,IM_W+1 + IU = C(I,J) + RUT = C(I,J) - IU + IF(C(I,J) .LE. 0.) THEN + ITMP = I+I0_W+I0 - IU + ISAVE(I) = ITMP - 1 + IF (ITMP .GT. IM_W+IGZD+I0_W+I0) THEN + ITMP=IM_W+IGZD+I0_W+I0 + ELSE IF (ITMP .LT. 1-IGZD+I0_W+I0) THEN + ITMP=1-IGZD+I0_W+I0 + ENDIF + ITMP=ITMP-I0_W-I0 + FX2(I,J) = -RUT*DC(ITMP)*(1.+RUT) + ELSE + ITMP = I+I0_W+I0 - IU - 1 + ISAVE(I) = ITMP + 1 + IF (ITMP .GT. IM_W+IGZD+I0_W+I0) THEN + ITMP=IM_W+IGZD+I0_W+I0 + ELSE IF (ITMP .LT. 1-IGZD+I0_W+I0) THEN + ITMP=1-IGZD+I0_W+I0 + ENDIF + ITMP=ITMP-I0_W-I0 + FX2(I,J) = RUT*DC(ITMP)*(1.-RUT) + ENDIF + FX1(I) = RUT*QTMP(ITMP) + ENDDO + + ENDIF + + DO I=1,IM_W+1 + IF (ISAVE(I) .GT. IM_W+IGZD+I0_W+I0) THEN + ISAVE(I)=IM_W+IGZD+I0_W+I0 + ELSE IF (ISAVE(I) .LT. 1-IGZD+I0_W+I0) THEN + ISAVE(I)=1-IGZD+I0_W+I0 + ENDIF + ISAVE(I)=ISAVE(I)-I0-I0_W + IF(C(I,J).GT.1.) THEN +CDIR$ NOVECTOR + DO IST =ISAVE(I),I-1 + FX1(I) = FX1(I) + QTMP(IST) + ENDDO + ELSEIF(C(I,J).LT.-1.) THEN +CDIR$ NOVECTOR + DO IST = I,ISAVE(I) + FX1(I) = FX1(I) - QTMP(IST) + ENDDO + ENDIF + ENDDO +CDIR$ VECTOR + DO I=1,IM_W+1 + FX1(I) = PU(I,J)*FX1(I) + FX2(I,J) = PU(I,J)*FX2(I,J) + ENDDO + +C use extrapolation to calculate fx1 and fx2 at grid IMP (yxw, 08/24/01) + + 1309 CONTINUE + +C Update using low order fluxes. + DO I=1,IM_W + + DQ(I,J) = DQ(I,J) + FX1(I)-FX1(I+1) + +! bey, 6/20/00. for mass-flux diagnostic + FX1_TP(I,J) = FX1(I) + ENDDO + + 1310 CONTINUE + + ! Return to TPCORE + END SUBROUTINE XTP + +!------------------------------------------------------------------------------ + + SUBROUTINE YMIST(IMR,JNP,P,DC,IGZD) +C****6***0*********0*********0*********0*********0*********0**********72 + PARAMETER ( R24 = 1./24. ) + REAL*8 P(IMR,-2:JNP+3),DC(IMR,-1:JNP+2) +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ +C +C 2nd order version for scalars +C + DO I=1,IMR*(JNP+4) + TMP = 0.25*(P(I,0) - P(I,-2)) + PMAX = MAX(P(I,0),P(I,-1),P(I,-2))-P(I,-1) + PMIN = P(I,-1) - MIN(P(I,-1),P(I,-2),P(I,0)) + DC(I,-1) = SIGN(MIN(ABS(TMP),PMIN,PMAX),TMP) + ENDDO +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%%C Poles: +!%%% +!%%% if(j1.ne.2) then +!%%% do i=1,IMR +!%%% DC(i,1) = 0. +!%%% DC(i,JNP) = 0. +!%%% enddo +!%%% else +!%%%C Determine slopes in polar caps for scalars! +!%%% +!%%% do 20 i=1,IMH +!%%%C South +!%%% tmp = 0.25*(p(i,2) - p(i+imh,2)) +!%%% Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1) +!%%% Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2)) +!%%% DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp) +!%%%C North. +!%%% tmp = 0.25*(p(i+imh,JMR) - p(i,JMR)) +!%%% Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP) +!%%% Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR)) +!%%% DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp) +!%%% 20 continue +!%%% +!%%%C Scalars: +!%%% do 25 i=imh+1,IMR +!%%% DC(i, 1) = - DC(i-imh, 1) +!%%% DC(i,JNP) = - DC(i-imh,JNP) +!%%% 25 continue +!%%% endif +!%%% + ! Return to TPCORE + END SUBROUTINE YMIST + +!------------------------------------------------------------------------------ + + SUBROUTINE YTP(IMR,JNP,ACOSP,DQ,Q,CRY,YMASS,FY2,JORD,FY1_TP,IGZD, + & JMAX) +C****6***0*********0*********0*********0*********0*********0**********72 + + REAL*8 Q(1-IGZD:IMR+IGZD,1-IGZD:JNP+IGZD), + & CRY(1-IGZD:IMR+IGZD,1-IGZD:JNP+IGZD+1), + & YMASS(IMR,JNP+1), FY2(IMR,JNP+1), + & ACOSP(-10:JMAX),DQ(IMR,JNP) + +! bey, 6/20/00. for mass-flux diagnostic + REAL*8 fy1_tp(IMR,JNP) + +C============================================================================ +C Cray NOBOUNDS directive will turn off all subscript bounds checking. +C This directive is also legal on SGI compilers (bmy, 4/24/00) +CDIR$ NOBOUNDS +C============================================================================ + +C Work array + REAL*8 fy1(IMR,JNP+1),P(IMR,-2:JNP+3),C(IMR,JNP+1), + & AR(IMR,0:JNP+1), + & AL(IMR,0:JNP+1), + & A6(IMR,0:JNP+1),DC2(IMR,-1:JNP+2) +C + LEN = IMR*(JNP+1) + P(:,:)=0D0 + + DO J = -2, JNP+3 + DO I = 1, IMR + P(I,J)=Q(I,J) + ENDDO + ENDDO + + DO J = 1, JNP+1 + DO I = 1, IMR + C(I,J)=CRY(I,J) + ENDDO + ENDDO + + IF(JORD.EQ.1) THEN + + DO I=1,LEN + JT = 1. - C(I,1) + FY1(I,1) = P(I,JT) + ENDDO + + DO I=1,LEN + FY2(I,1) = 0. + ENDDO + + ELSE + CALL YMIST(IMR,JNP,P(:,:),DC2(:,:),IGZD) + + IF(JORD.LE.0 .OR. JORD.GE.3) THEN + CALL FYPPM(C(:,:),P(:,:),DC2(:,:),FY1(:,:),FY2(:,:), + & IMR,JNP,A6(:,:),AR(:,:),AL(:,:),JORD,IGZD) + ELSE + DO I=1,LEN + JT = FLOAT(1) - C(I,1) + FY1(I,1) = P(I,JT) + FY2(I,1) = (SIGN(1d0,C(I,1))-C(I,1))*DC2(I,JT) + ENDDO + ENDIF + ENDIF +C + DO I=1,LEN + FY1(I,1) = FY1(I,1)*YMASS(I,1) + FY2(I,1) = FY2(I,1)*YMASS(I,1) + ENDDO +C +!============================================================================= +! This loop had to be extended for the mass-flux diagnostics (bmy, 4/26/00) +! DO 1400 j=j1,j2 +! DO 1400 i=1,IMR +!1400 DQ(i,j) = DQ(i,j) + (fy1(i,j) - fy1(i,j+1)) * acosp(j) +!============================================================================= +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% use extrapolation to calculate fy1 and fy2 at grid JNP+1 +!%%% do i=1,IMR +!%%% fy1(i,JNP+1)=2*fy1(i,JNP)-fy1(i,JNP-1) +!%%% fy2(i,JNP+1)=2*fy2(i,JNP)-fy2(i,JNP-1) +!%%% enddo +!%%% + DO J = 1, JNP + DO I = 1, IMR + DQ(I,J) = DQ(I,J) + (FY1(I,J) - FY1(I,J+1)) * ACOSP(J) + + ! bey, 6/20/00. for mass-flux diagnostic + FY1_TP(I,J) = FY1(I,J) + ENDDO + ENDDO +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested simulation +!%%%C Poles +!%%% sum1 = fy1(IMR,j1 ) +!%%% sum2 = fy1(IMR,J2+1) +!%%% do i=1,IMR-1 +!%%% sum1 = sum1 + fy1(i,j1 ) +!%%% sum2 = sum2 + fy1(i,J2+1) +!%%% enddo +!%%% +!%%% sum1 = DQ(1, 1) - sum1 * RCAP +!%%% sum2 = DQ(1,JNP) + sum2 * RCAP +!%%% do i=1,IMR +!%%% DQ(i, 1) = sum1 +!%%% DQ(i,JNP) = sum2 +!%%% enddo +!%%% +!%%% if(j1.ne.2) then +!%%% do i=1,IMR +!%%% DQ(i, 2) = sum1 +!%%% DQ(i,JMR) = sum2 +!%%% enddo +!%%% endif +!%%% + ! Return to TPCORE + END SUBROUTINE YTP + +!------------------------------------------------------------------------------ + + SUBROUTINE PRESS_FIX( FX, FY, NDT, ACOSP, Jmax, + & I0_W, J0_W, IM_W, JM_W, IGZD ) +! +!****************************************************************************** +! Subroutine PRESS_FIX is a wrapper for the Pressure fixer DYN0. PRESS_FIX +! takes the mass fluxes in pressure units and converts them to [kg air/s] +! using the correct geometry for TPCORE. (bdf, bmy, 3/10/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FX (REAL*8 ) : E-W flux passed from TPCORE [mb/timestep] +! (2 ) FY (REAL*8 ) : N-S flux passed from TPCORE [mb/timestep] +! (3 ) NDT (INTEGER) : Dynamic timestep for TPCORE [s] +! (4 ) ACOSP (REAL*8 ) : Array of inverse cosines [unitless] +! (5 ) J1 (INTEGER) : TPCORE polar cap extent [# of boxes] +! (6 ) I0_W (INTEGER) : TPCORE REGION longitude offset [# boxes] +! (7 ) J0_W (INTEGER) : TPCORE REGION latitude offset [# boxes] +! (8 ) IM_W (INTEGER) : TPCORE REGION longitude extent [# boxes] +! (9 ) JM_W (INTEGER) : TPCORE REGION latitude extent [# boxes] +! (10) IGZD (INTEGER) : Variable equal to 1-I0_W or 1-J0_W +! +! NOTES: +! (1 ) Differences from "tpcore_mod" denoted by !%%% (bmy, 3/10/03) +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_AREA_M2 + USE TIME_MOD, ONLY : GET_TS_DYN + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic switches +# include "CMN_GCTM" ! g0_100 + + ! Arguments +!%%% +!%%% MODIFICATIONS FOR NESTED GRID +!%%% Modify array boundarys accordingly +!%%% + INTEGER, INTENT(IN) :: NDT, Jmax, I0_W, J0_W, IM_W, JM_W, IGZD + REAL*8, INTENT(IN) :: ACOSP(-10:Jmax) + + REAL*8, INTENT(INOUT) :: FX(1-IGZD:IM_W+IGZD+1, + & 1-IGZD:JM_W+IGZD,LLPAR) + + REAL*8, INTENT(INOUT) :: FY(1-IGZD:IM_W+IGZD, + & 1-IGZD:JM_W+IGZD+1,LLPAR) + + ! Local variables + INTEGER :: I, J, K, K2, L + REAL*8 :: DTC, DTDYN, NSDYN, SUM1, SUM2 +!%%% +!%%% MODIFICATION FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% REAL*8 :: NP_FLUX(IIPAR,LLPAR) +!%%% REAL*8 :: SP_FLUX(IIPAR,LLPAR) +!%%% + REAL*8 :: ALFA( 1-IGZD:IM_W+IGZD+1, 1-IGZD:JM_W+IGZD, LLPAR ) + REAL*8 :: BETA( 1-IGZD:IM_W+IGZD, 1-IGZD:JM_W+IGZD+1, LLPAR ) + REAL*8 :: GAMA( 1-IGZD:IM_W+IGZD, 1-IGZD:JM_W+IGZD, LLPAR+1 ) + REAL*8 :: UMFLX(1-IGZD:IM_W+IGZD+1, 1-IGZD:JM_W+IGZD, LLPAR ) + REAL*8 :: VMFLX(1-IGZD:IM_W+IGZD, 1-IGZD:JM_W+IGZD+1, LLPAR ) + + ! Local SAVEd variables + LOGICAL, SAVE :: FIRST = .TRUE. + REAL*8, SAVE :: DXYP(JJPAR) + + !================================================================= + ! PRESS_FIX begins here! + ! + ! K is the vertical index down from the atmosphere top downwards + ! K2 is the vertical index up from the surface + !================================================================= + + ! Initialize arrays + ALFA = 0d0 + BETA = 0d0 + GAMA = 0d0 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Now use function GET_TS_DYN to get the dynamic timestep +!%%% ! NSDYN is the dynamic time step in seconds +!%%% NSDYN = NDYN * 60d0 + ! Dynamic timestep [s] + NSDYN = GET_TS_DYN() * 60d0 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% ! J2 is the south polar edge +!%%% J2 = JJPAR - J1 + 1 +!%%% +!%%% + ! DTDYN = double precision value for NDT, the dynamic timestep + DTDYN = DBLE( NDT ) + + ! Save grid box surface areas [m2] into the local DXYP array + IF ( FIRST ) THEN + DO J = 1, JJPAR + DXYP(J) = GET_AREA_M2( J ) + ENDDO + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + !================================================================= + ! FX is the E-W mass flux from TPCORE in [mb/timestep]. + ! UMFLX is the mass flux in [kg air/s], which is what DYN0 needs. + ! + ! FY is the E-W mass flux from TPCORE in [mb/timestep]. + ! VMFLX is the mass flux in [kg air/s], which is what DYN0 needs. + ! + ! The unit conversion from [mb/timestep] to [kg air/s] is: + ! + ! mb | 100 Pa | 1 kg air | s^2 | step | DXYP m^2 kg air + ! ------+--------+----------+-------+--------+---------- = ------- + ! step | mb | Pa m s^2 | 9.8 m | DTDYN s| s s + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K, K2, DTC ) +#endif + DO K = 1, LLPAR + K2 = LLPAR - K + 1 + + ! Compute UMFLX from FX +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% DO J = 1, JJPAR +!%%% DO I = 1, IIPAR +!%%% + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD+1 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Now use DXYP(J+J0_w) instead of DXYP(J) +!%%% UMFLX(I,J,K2) = FX(I,J,K) * ( G0_100 * DXYP(J) ) / DTDYN +!%%% + UMFLX(I,J,K2) = FX(I,J,K) * ( G0_100 * DXYP(J+J0_w))/ DTDYN + ENDDO + ENDDO + + ! Compute VMFLX from FY + DO I = 1-IGZD, IM_W+IGZD + DO J = 1-IGZD, JM_W+IGZD+1 + IF ( FY(I,J,K) .GE. 0 ) THEN + DTC = FY(I,J,K) * G0_100 * ACOSP(J) * DXYP(J+J0_w)/DTDYN + ELSE + DTC = FY(I,J,K) * G0_100 * ACOSP(J-1)* DXYP(J-1+J0_w)/DTDYN + ENDIF + + VMFLX(I,J,K2) = DTC + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% !================================================================= +!%%% ! TREATMENT OF THE POLES: 1 +!%%% ! copy ymass values strait into vmflx at poles for pressure fixer +!%%% !================================================================= +!%%% DO I = 1, IIPAR +!%%% VMFLX(I,1,K2) = FY(I,1,K) +!%%% VMFLX(I,J1-1,K2) = FY(I,J1-1,K) +!%%% VMFLX(I,JJPAR,K2) = FY(I,JJPAR,K) +!%%% ENDDO +!%%% + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% DO K = 1, LLPAR +!%%% +!%%% !================================================================= +!%%% ! TREATMENT OF THE POLES: 2 +!%%% ! North polar cap: J=1 +!%%% !================================================================= +!%%% SUM1 = FY(IIPAR,J1,K) +!%%% DO I = 1, IIPAR-1 +!%%% SUM1 = SUM1 + FY(I,J1,K) +!%%% ENDDO +!%%% +!%%% ! NORTH POLE FLUX IN KG. +!%%% DO I = 1, IIPAR +!%%% NP_FLUX(I,K) = SUM1 * G0_100 * ACOSP(1) * DXYP(1) +!%%% ENDDO +!%%% +!%%% !================================================================= +!%%% ! TREATMENT OF THE POLES: 3 +!%%% ! South polar cap: J=JJPAR +!%%% !================================================================= +!%%% SUM2 = FY(IIPAR,J2+1,K) +!%%% DO I = 1, IIPAR-1 +!%%% SUM2 = SUM2 + FY(I,J2+1,K) +!%%% ENDDO +!%%% +!%%% DO I = 1, IIPAR +!%%% SP_FLUX(I,K) = SUM2 * G0_100 * ACOSP(JJPAR) * DXYP(JJPAR) +!%%% ENDDO +!%%% ENDDO + + !================================================================= + ! Call DYN0 to fix the pressures + !================================================================= +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Remove J1, NP_FLUX, SP_FLUX from call to DYN0 +!%%% + CALL DYN0( NSDYN, UMFLX, VMFLX, ALFA, BETA, GAMA, + & I0_W, J0_W, IM_W, JM_W, IGZD ) + + !================================================================= + ! ALFA is the E-W mass flux adjusted by DYN0 in [kg air/s] + ! FX is the E-W mass flux for TPCORE in [mb/timestep]. + ! + ! BETA is the N-S mass flux adjusted by DYN0 in [kg air/s] + ! FY is the E-W mass flux for TPCORE in [mb/timestep]. + ! + ! The unit conversion from to [kg air/s] to [mb/timestep] is: + ! + ! kg air | Pa m s^2 | 9.8 m | 1 | DTDYN s | mb mb + ! --------+----------+-------+----------+---------+------- = ---- + ! s | 1 kg air | s^2 | DXYP m^2 | step | 100 Pa step + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K, K2 ) +#endif + DO K = 1, LLPAR + K2 = LLPAR - K + 1 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits for nested grid +!%%% Now use DXYP(J+J0_W) instead of DXYP(J) in several DO-loops below +!%%% + + ! Update FX from ALFA + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+1+IGZD + FX(I,J,K) = ALFA(I,J,K2) * DTDYN /(G0_100 * DXYP(J+J0_W) ) + ENDDO + ENDDO + + ! Update FY from BETA + DO I = 1-IGZD, IM_W+IGZD + DO J = 1-IGZD, JM_W+1+IGZD + IF ( BETA(I,J,K) .GE. 0 ) THEN + FY(I,J,K) = BETA(I,J,K2) * DTDYN / + & ( G0_100 * ACOSP(J) * DXYP(J+J0_w) ) + ELSE + FY(I,J,K) = BETA(I,J,K2) * DTDYN / + & ( G0_100 * ACOSP(J-1) * DXYP(J-1+J0_w) ) + ENDIF + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% ! Special treatment of BETA at the poles +!%%% DO I = 1, IIPAR +!%%% FY(I,1,K) = BETA(I,1,K2) +!%%% FY(I,J1-1,K) = BETA(I,J1-1,K2) +!%%% FY(I,JJPAR,K) = BETA(I,JJPAR,K2) +!%%% ENDDO +!%%% + ENDDO + + ! Return to calling program + END SUBROUTINE PRESS_FIX + +!------------------------------------------------------------------------------ + + SUBROUTINE DYN0( DTWIND, UMFLX, VMFLX, ALFA, BETA, GAMA, + & I0_W, J0_W, IM_W, JM_W, IGZD ) +! +!****************************************************************************** +! Subroutine DYN0 is the pressure fixer for TPCORE. DYN0 readjusts the +! mass fluxes ALFA, BETA, GAMA, so that they are consistent with the +! met fields. (bdf, bmy, 3/10/03, 7/20/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) DTWIND (REAL*8 ) : Time step between wind intervals [s] +! (2 ) UMFLX (REAL*8 ) : Wet air mass flux in E-W direction [kg air/s] +! (3 ) VMFLX (REAL*8 ) : Wet air mass flux in N-S direction [kg air/s] +! (4 ) ALFA (REAL*8 ) : Dry air mass flux in E-W direction [kg air/s] +! (5 ) BETA (REAL*8 ) : Dry air mass flux in N-S direction [kg air/s] +! (6 ) GAMA (REAL*8 ) : Dry air mass flux in up/down direction [kg air/s] +! (7 ) I0_W (INTEGER) : TPCORE REGION longitude offset [# boxes] +! (8 ) J0_W (INTEGER) : TPCORE REGION latitude offset [# boxes] +! (9 ) IM_W (INTEGER) : TPCORE REGION longitude extent [# boxes] +! (10) JM_W (INTEGER) : TPCORE REGION latitude extent [# boxes] +! (11) IGZD (INTEGER) : Variable equal to 1-I0_W or 1-J0_W +! +! Arguments as Output: +! ============================================================================ +! (8 ) ALFA (REAL*8 ) : ALFA air mass, after pressure fix is applied +! (9 ) BETA (REAL*8 ) : BETA air mass, after pressure fix is applied +! (10) GAMA (REAL*8 ) : GAMA air mass, after pressure fix is applied +! +! NOTES: +! (1 ) Differences from "tpcore_mod.f" denoted by !%%% (bmy, 3/10/03) +! (2 ) Removed reference to CMN (bmy, 7/20/04) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : SPHU, PSC2, AIRDEN, AIRVOL + USE GRID_MOD, ONLY : GET_AREA_M2 + USE PRESSURE_MOD, ONLY : GET_BP + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters + + ! Arguments +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% INTEGER, INTENT(IN) :: J1 +!%%% REAL*8, INTENT(IN) :: NP_FLUX(IIPAR,LLPAR) +!%%% REAL*8, INTENT(IN) :: SP_FLUX(IIPAR,LLPAR) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Change array limits accordingly +!%%% + INTEGER, INTENT(IN) :: I0_W, J0_W, IM_W, JM_W, IGZD + REAL*8, INTENT(IN) :: DTWIND + + REAL*8, INTENT(IN) :: UMFLX(1-IGZD:IM_W+IGZD+1, + & 1-IGZD:JM_W+IGZD,LLPAR) + + REAL*8, INTENT(IN) :: VMFLX(1-IGZD:IM_W+IGZD, + & 1-IGZD:JM_W+IGZD+1,LLPAR) + + REAL*8, INTENT(INOUT) :: ALFA(1-IGZD:IM_W+IGZD+1, + & 1-IGZD:JM_W+IGZD,LLPAR) + + REAL*8, INTENT(INOUT) :: BETA(1-IGZD:IM_W+IGZD, + & 1-IGZD:JM_W+IGZD+1,LLPAR) + + REAL*8, INTENT(INOUT) :: GAMA(1-IGZD:IM_W+IGZD, + & 1-IGZD:JM_W+IGZD,LLPAR+1) + + ! Local variables + LOGICAL :: LSP, LNP, LEW + INTEGER :: IIX, JJX, KM, JB, JE, IEPZ, IMZ + INTEGER :: I, J, J2, K, L + REAL*8 :: ALFAX, UFILT, VFILT, PCTM8, G100 + REAL*8 :: AIRQAV, AWE, SUMAD0, SUMAW0, AIRWET + REAL*8 :: AIRH2O, AIRQKG ,SUM1, SUMA, SUMP, SUMQ + REAL*8 :: SUMU, SUMV, SUMW, ZIMZ, ZDTW, G0 + REAL*8 :: AD_L(IIPAR,JJPAR,LLPAR) + REAL*8 :: AIRD(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD,LLPAR) + REAL*8 :: AIRNEW(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD,LLPAR) + REAL*8 :: AIRX(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD,LLPAR) + REAL*8 :: AX(1-IGZD:IM_W+IGZD+1,1-IGZD:JM_W+IGZD) + REAL*8 :: BX(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD+1) + REAL*8 :: MERR(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD) + REAL*8 :: PCTM(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD) + REAL*8 :: PERR(1-IGZD:IM_W+IGZD,1-IGZD:JM_W+IGZD) + REAL*8 :: SPHU_KG(IIPAR,JJPAR,LLPAR) + REAL*8 :: SUMAQ(1-IGZD:IM_W+IGZD+1,1-IGZD:JM_W+IGZD+1) + REAL*8 :: XYB(IIPAR,JJPAR) + REAL*8 :: XYZB(IIPAR,JJPAR,LLPAR) + + ! Local saved variables + LOGICAL, SAVE :: FIRST = .TRUE. + REAL*8, SAVE :: DXYP(JJPAR) + REAL*8, SAVE :: DSIG(LLPAR) + + !================================================================= + ! DYN0 begins here! + ! + ! UNITS OF AIR MASS AND TRACER = (kg) + ! + ! Air mass (kg) is given by: + ! area (m^2) * pressure thickness (Pa) / g0 + ! + ! DXYP(I,J) = area of [I,J] [m^2] + ! + ! PSC2(I,J) = surf pressure [Pa] averaged in extended zone. + ! + ! SPHU_KG(I,J,K) = specific humidity of grid box + ! [kg H2O/kg wet air] averaged in extended zone. + ! + ! AIRQKG(I,J) = Mass of H2O [kg] at each level + ! = PSC2(I,J)) * SPHU_KG(I,J,K) + ! + ! AIRD(I,J,K) = dry-air mass [kg] in each box as calculated + ! in CTM at the beginning of each time step, + ! updated at end of DYN0. + ! + ! PCTM(I,J) = inferred wet-air (total) surf press [Pa] calc. + ! in CTM (using SUMAQ & AIRD-X-NEW) + ! + ! AIRNEW(I,J,K) = new dry-air mass in each CTM box after + ! horizontal divergence (ALFA+BETA) over time + ! step DTWIND (sec) + ! + ! AIRX(I,J,K) = expected dry-air mass in each CTM box after + ! calculating the vertical divergence (GAMA) + ! (also used for GCM dry mass) + ! = XYZA(I,J,K) + XYZB(I,J,K)*PCTM(I,J) - AIRQKG + ! + ! DTWIND = time step [s] that applies to the averaged + ! wind fields (i.e., the time between successive + ! pressures. + ! + !----------------------------------------------------------------- + ! + ! Assume that we have "wet-air" mass fluxes across each boundary + ! + ! UMFLX(I,J,K) ==> [I,J,K] ==> UMFLX(I+1,J,K) [kg air/s] + ! VMFLX(I,J,K) ==> [I,J,K] ==> VMFLX(I,J+1,K) [kg air/s] + ! + ! Convert to "dry-air" mass flux in/out of box using + ! average Q at boundary + ! + ! ALFA(I,J,K) ==> [I,J,K] ==> ALFA(I+1,J,K) [kg air/s] + ! BETA(I,J,K) ==> [I,J,K] ==> BETA(I,J+1,K) [kg air/s] + ! + ! Calculate convergence in each layer of dry air, compare with + ! expected dry air mass (AIRX) and then calculate vertical + ! dry-mass fluxes + ! + ! GAMA(I,J,K) ==> [I,J,K] ==> GAMA(I,J,K+1) [kg air/s] + ! + ! Horizontal pressure filter adjusts UMFLX & VMFLX to reduce + ! error in [PCTM - PSC2] + ! + ! UMFLX + pressure filter ==> UMFLX#, + ! VMFLX + filter ==> VMFLX# (temporary) + ! + ! The pressure filter does nearest neighbor flux + ! (adjusting ALFA/BETA) + ! + !----------------------------------------------------------------- + ! + ! Note that K->K+1 is downward (increasing pressure) and + ! that boundaries: + ! GAMA(I,J,1) = GAMA(I,J,KM+1) = 0 no flux across + ! upper/lower boundaries + ! + ! BETA(I,1,K) = BETA(I,JJPAR+1,K) = 0 no flux at S & N poles + ! + ! ALFA(1,J,K) = ALFA(IIPAR+1,J,K) is NOT ZERO, but cyclic + ! + ! Dimensions for ALFA, BETA, GAMA are extended by +1 beyond grid + ! to allow simple formulation of fluxes in/out of final grid box. + ! + ! GCM input UMFLX,VMFLX,PSG is ALWAYS of GLOBAL dimensions + ! (IIPAR x JJPAR x LLPAR) + ! + ! Indices of ALFA, BETA, GAMA, SPHU_KG & PS are always LOCAL + ! (IIPAR x JJPAR x KM): FOR GEOS-CHEM, KM = LLPAR (bmy + ! + ! Indices of tracer (STT), and diagnostics are local + ! (w.r.t. WINDOW. WINDOW calculations are defined by an + ! offset and size + ! + ! I0 .ge.0 and IIPAR+I0 .le. IIPAR + ! J0 .ge.0 and JJPAR+J0 .le. JJPAR + ! K0 .ge.0 and KM+K0 .le. LLPAR + ! + ! The WINDOW calculation must allow for a boundary layer + ! of grid boxes: + ! + ! IG(abs. coords) = IW(in window) + I0 + ! JG(abs. coords) = JW(in window) + J0 + ! KG(abs. coords) = KW(in window) + K0 + ! + ! vertical window (NEW) allows for an upper boundary with flow + ! across it and specified mixing ratio b.c.'s at KG = K0 + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + + ! Surface area [m2] + DO J = 1, JJPAR + DXYP(J) = GET_AREA_M2( J ) + ENDDO + + ! Sigma-level thickness [unitless] + ! Assumes we are using a pure-sigma grid + DO L = 1, LLPAR + DSIG(L) = GET_BP(L) - GET_BP(L+1) + ENDDO + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%%! for tpcore poles. +!%%% J2 = JJPAR - J1 + 1 +!%%% + ! geos code + G0 = 9.8d0 + + !================================================================= + ! XYZB is the factor needed to get mass in kg of gridbox + ! mass (kg) = XYZB (kg/mb) * P (mb) + ! + ! AD_L is the dry air mass in the grid box + ! + ! SPHU_KG is the water vapor [kg H2O/kg air] + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) +#endif + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + XYZB(I,J,L) = DSIG(L) * DXYP(J) * 1.d2 / G0 + AD_L(I,J,L) = AIRDEN(L,I,J) * AIRVOL(I,J,L) + SPHU_KG(I,J,L) = SPHU(I,J,L) / 1000d0 + ENDDO + ENDDO + ENDDO + + !================================================================= + ! XYB is the factor needed to get mass in kg of column + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) +#endif + DO J = 1, JJPAR + DO I = 1, IIPAR + XYB(I,J) = SUM( XYZB(I,J,1:LLPAR) ) + ENDDO + ENDDO + + !================================================================= + ! Define other variables + !================================================================= + G100 = 100.D0 / G0 + ZDTW = 1.D0 / DTWIND +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% LSP = ( J0 .EQ. 0 ) +!%%% LNP = ( JJPAR+J0 .EQ. JJPAR ) +!%%% LEW = ( IIPAR .EQ. IIPAR ) +!%%% + !================================================================= + ! Initialize ALFA with UMFLX and BETA with VMFLX + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) +#endif + DO L = 1, LLPAR + DO J = 1-IGZD, IGZD+JM_W + DO I = 1-IGZD,IM_W+IGZD+1 + ALFA(I,J,L) = UMFLX(I,J,L) + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% don't need easternmost edge +!%%% ALFA(IIPAR+1,J,L) = ALFA(1,J,L) + ENDDO + +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% DO J = 2, JJPAR +!%%% DO I = 1, IIPAR +!%%% + DO J = 1-IGZD, JM_W+IGZD+1 + DO I = 1-IGZD, IM_W+IGZD + BETA(I,J,L) = VMFLX(I,J,L) + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% don't need southernmost edge +!%%% DO I = 1, IIPAR +!%%% BETA(I,1,L) = 0.D0 +!%%% BETA(I,JJPAR+1,L) = 0.D0 +!%%% ENDDO +!%%% + ENDDO + ENDDO + + !================================================================= + ! SUMAQ(I,J): column integral of water (kg) + ! Check on air mass + !================================================================= + SUMAD0 = 0.D0 + SUMAW0 = 0.D0 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits for nested-grid +!%%% Also use I+I0_W, J+J0_W to reference several arrays below +!%%% + DO J = 1-IGZD, JM_W+IGZD+1 + DO I = 1-IGZD, IM_W+IGZD+1 + SUMAQ(I,J) = 0.D0 + + DO K = 1, LLPAR + AIRWET = PSC2(I+I0_w,J+J0_w) * XYZB(I+I0_w,J+J0_w,K) + AIRH2O = SPHU_KG(I+I0_w,J+J0_w,K) * AIRWET + SUMAQ(I,J) = SUMAQ(I,J) + AIRH2O + SUMAD0 = SUMAD0 + AIRWET + SUMAW0 = SUMAW0 + AIRH2O + ENDDO + ENDDO + ENDDO + + SUMAD0 = SUMAD0 - SUMAW0 + + !================================================================= + ! Initialize AIRD, the dry-air mass [kg] in each box as calculated + ! in CTM at the start of each time step, updated at end of DYN0. + ! + ! Compute AIRNEW, the new dry-air mass in each CTM box after + ! horizontal divergence (ALFA+BETA) over time step DTWIND (sec) + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K ) +#endif + DO K = 1, LLPAR +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits and +!%%% Also reference AD with (I+I0_W, J+J0_W, K) instead of (I,J,K) +!%%% DO J = J1, J2 +!%%% + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD + AIRD(I,J,K) = AD_L(I+I0_W,J+J0_W,K) + AIRNEW(I,J,K) = AIRD(I,J,K) + DTWIND * + & ( ALFA(I,J,K) - ALFA(I+1,J,K) + + & BETA(I,J,K) - BETA(I,J+1,K) ) + ENDDO + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/11/03) +!%%% Polar-cap stuff, useless for nested grid +!%%% +!%%% !================================================================= +!%%% ! treatment of the poles for tpcore. +!%%% ! j=2 and j=jjpar-1 don't have any airmass change. +!%%% !================================================================= +!%%%!$OMP PARALLEL DO +!%%%!$OMP+DEFAULT( SHARED ) +!%%%!$OMP+PRIVATE( I, K ) +!%%% DO K = 1, LLPAR +!%%% +!%%% ! J=1 +!%%% DO I = 1, IIPAR +!%%% AIRNEW(I,1,K) = AD_L(I,1,K) - NP_FLUX(I,K) +!%%% ENDDO +!%%% +!%%% ! J=JJPAR +!%%% DO I = 1, IIPAR +!%%% AIRNEW(I,JJPAR,K) = AD_L(I,JJPAR,K) + SP_FLUX(I,K) +!%%% ENDDO +!%%% ENDDO +!%%%!$OMP END PARALLEL DO +!%%% +!%%% !================================================================= +!%%% ! Average AIRNEW at the South pole +!%%% !================================================================= +!%%% ZIMZ = 1.D0 / DBLE( IIPAR ) +!%%% +!%%% IF ( LSP ) THEN +!%%% JB = 2 +!%%% +!%%%!$OMP PARALLEL DO +!%%%!$OMP+DEFAULT( SHARED ) +!%%%!$OMP+PRIVATE( I, K, SUMA ) +!%%% DO K = 1, LLPAR +!%%% SUMA = SUM( AIRNEW(1:IIPAR,1,K) ) * ZIMZ +!%%% +!%%% DO I = 1, IIPAR +!%%% AIRNEW(I,1,K) = SUMA +!%%% ENDDO +!%%% ENDDO +!%%%!$OMP END PARALLEL DO +!%%% ELSE +!%%% JB = 1 +!%%% ENDIF +!%%% !================================================================= +!%%% ! Average AIRNEW at the North pole +!%%% !================================================================= +!%%% IF ( LNP ) THEN +!%%% JE = JJPAR - 1 +!%%% +!%%% ! poles, just average AIRNEW +!%%%!$OMP PARALLEL DO +!%%%!$OMP+DEFAULT( SHARED ) +!%%%!$OMP+PRIVATE( I, K, SUMA ) +!%%% DO K = 1, LLPAR +!%%% SUMA = SUM( AIRNEW(1:IIPAR,JJPAR,K) ) * ZIMZ +!%%% +!%%% DO I = 1, IIPAR +!%%% AIRNEW(I,JJPAR,K) = SUMA +!%%% ENDDO +!%%% ENDDO +!%%%!$OMP END PARALLEL DO +!%%% ELSE +!%%% JE = JJPAR +!%%% ENDIF +!%%% + !================================================================ + ! BEGIN FILTER of PRESSURE ERRORS + ! + ! Define the error in surface pressure PERR expected at end of + ! time step filter by error in adjacent boxes, weight by areas, + ! adjust ALFA & BETA + ! + ! PCTM(I,J) = new CTM wet-air column based on + ! dry-air convergence (Pascals) + ! PERR(I,J) = pressure-error between CTM-GCM at new time + ! (before filter) + !================================================================ +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) +#endif + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IGZD+IM_W + PCTM(I,J) = SUM( AIRNEW(I,J,:) ) / XYB(I+I0_w,J+J0_w) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% ! special case for j=2, jjpar-1 for tpcore pole configuration. +!%%% IF ( J .eq. 2 .OR. J .eq. JJPAR-1 ) THEN +!%%% PCTM(I,J) = PSC2(I,J) +!%%% ENDIF +!%%% + PERR(I,J) = PCTM(I,J) - PSC2(I+I0_w,J+J0_w) + MERR(I,J) = PERR(I,J) * DXYP(J+J0_w) * G100 + ENDDO + ENDDO + + !### Debug + !write(6,*) 'before PFILTR' + !write(6,*) 'sum MERR is ', sum(MERR) + !write(6,*) 'sum AX is ', sum(AX) + !write(6,*) 'sum BX is ', sum(BX) + + ! Call pressure filter + CALL PFILTR( MERR, AX, BX, DXYP, IIPAR, JJPAR, + & IM_W, JM_W, 1, JGLOB, J0_w, IGZD ) + + !### Debug + !write(6,*) 'after PFILTR' + !write(6,*) 'sum MERR is ', sum(MERR) + !write(6,*) 'sum AX is ', sum(AX) + !write(6,*) 'sum BX is ', sum(BX) + + !================================================================= + ! Calculate corrections to ALFA from the filtered AX + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, IIX, J, K, UFILT ) +#endif + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+1+IGZD +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% We don't have to worry about wrapping around the world +!%%% IIX = MIN(I+I0_w,IM_W+I0_w) +!%%% + IIX = I+I0_w + UFILT = AX(I,J) / ( XYB(IIX,J+J0_w) * DTWIND ) + + DO K = 1, LLPAR + ALFA(I,J,K) = ALFA(I,J,K) + UFILT * XYZB(IIX,J+J0_w,K) + ENDDO + ENDDO + ENDDO + + !================================================================= + ! Calculate corrections to BETA from the filtered BX + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, JJX, K, VFILT ) +#endif + DO J = 1-IGZD, JM_W+IGZD+1 + JJX = J+J0_W + IF ( J+J+79+79 .GT. 181 ) JJX =J+J0_W- 1 !(YXW_1X1) + + DO I = 1-IGZD, IM_W+IGZD + VFILT = BX(I,J) / ( XYB(I+I0_W,JJX) * DTWIND ) + + DO K = 1, LLPAR + BETA(I,J,K) = BETA(I,J,K) + VFILT * XYZB(I+I0_W,JJX,K) + ENDDO + ENDDO + ENDDO + + !================================================================= + ! Calculate the corrected AIRNEW's & PCTM after P-filter: + ! has changed ALFA+BETAs and ctm surface pressure (PCTM) + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K ) +#endif + DO K = 1, LLPAR + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD + AIRNEW(I,J,K) = AIRD(I,J,K) + DTWIND * + & ( ALFA(I,J,K) - ALFA(I+1,J,K) + + & BETA(I,J,K) - BETA(I,J+1,K) ) + ENDDO + ENDDO + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/11/03) +!%%% Polar-cap stuff, useless for nested grid +!%%% !================================================================= +!%%% ! Average the adjusted AIRNEW at the South pole +!%%% !================================================================= +!%%% ZIMZ = 1.D0 / DBLE( IIPAR ) +!%%% +!%%% IF ( LSP ) THEN +!%%% JB = 2 +!%%% +!%%%!$OMP PARALLEL DO +!%%%!$OMP+DEFAULT( SHARED ) +!%%%!$OMP+PRIVATE( I, K, SUMA ) +!%%% DO K = 1, LLPAR +!%%% SUMA = SUM( AIRNEW(1:IIPAR,1,K ) ) * ZIMZ +!%%% +!%%% DO I = 1, IIPAR +!%%% AIRNEW(I,1,K) = SUMA +!%%% ENDDO +!%%% ENDDO +!%%%!$OMP END PARALLEL DO +!%%% ELSE +!%%% JB = 1 +!%%% ENDIF +!%%% +!%%% !================================================================= +!%%% ! Average the adjusted AIRNEW at the North pole +!%%% !================================================================= +!%%% IF ( LNP ) THEN +!%%% JE = JJPAR -1 +!%%% +!%%%!$OMP PARALLEL DO +!%%%!$OMP+DEFAULT( SHARED ) +!%%%!$OMP+PRIVATE( I, K, SUMA ) +!%%% DO K = 1, LLPAR +!%%% SUMA = SUM( AIRNEW(1:IIPAR,JJPAR,K) ) * ZIMZ +!%%% +!%%% DO I = 1,IIPAR +!%%% AIRNEW(I,JJPAR,K) = SUMA +!%%% ENDDO +!%%% ENDDO +!%%%!$OMP END PARALLEL DO +!%%% ELSE +!%%% JE = JJPAR +!%%% ENDIF +!%%% + !================================================================= + ! END OF PRESSURE FILTER + ! + ! GAMA: redistribute the new dry-air mass consistent with the + ! new CTM surface pressure, rigid upper b.c., no change in PCTM + ! + ! AIRX(I,J,K) = dry-air mass expected, based on PCTM + ! PCTM(I,J) & PERR(I,J) + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K, PCTM8, AIRQKG ) +#endif + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD + PCTM8 = ( SUM( AIRNEW(I,J,:) ) + SUMAQ(I,J) ) / + & XYB(I+I0_W,J+J0_W) + PCTM(I,J) = PCTM8 + PERR(I,J) = PCTM8 - PSC2(I+I0_W,J+J0_W) + + DO K = 1, LLPAR + AIRQKG = SPHU_KG(I+I0_W,J+J0_W,K) * + & ( XYZB(I+I0_W,J+J0_W,K) * PSC2(I+I0_W,J+J0_W) ) + AIRX(I,J,K) = PCTM8 * XYZB(I+I0_W,J+J0_W,K) - AIRQKG + ENDDO + ENDDO + ENDDO + + !================================================================= + ! GAMA from top down to be consistent with AIRX, AIRNEW not reset! + !================================================================= +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, K ) +#endif + DO J = 1-IGZD, JM_W+IGZD + DO I = 1-IGZD, IM_W+IGZD + GAMA(I,J,LLPAR+1) = 0.D0 + + DO K = LLPAR, 2, -1 + GAMA(I,J,K) = GAMA(I,J,K+1) - (AIRNEW(I,J,K) - AIRX(I,J,K)) + ENDDO + + ! GAMA(I,J,1) will not be exactly ZERO, but it must be set so! + GAMA(I,J,1) = 0.D0 + + DO K = 2, LLPAR + GAMA(I,J,K) = GAMA(I,J,K) * ZDTW + ENDDO + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE DYN0 + +!------------------------------------------------------------------------------ + + SUBROUTINE PFILTR( MERR, ALFAX, BETAX, AXY, ID, JD, + & IM, JM, NITR, JGLOB, J0_W, IGZD ) +! +!****************************************************************************** +! Subroutine PFILTR applies the pressure-filter, the pressure +! between predicted Ps(CTM) and Ps(GCM). (bdf, yxw, bmy, 3/10/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) MERR(IM,JM) (REAL*8 ) : mass error +! (2 ) ALFAX(ID+1,JD) (REAL*8 ) : perturbed ALFA by MERR +! (3 ) BETAX(ID,JD+1) (REAL*8 ) : perturbed BETA by MERR +! (4 ) AXY(ID,JD) (REAL*8 ) : area of grid box (I,J) in [m^2] +! (5-6) ID, JD (INTEGER) : "Global" array dimensions for lon, lat +! (7-8) IM, JM (INTEGER) : "Window" array dimensions for lon, lat +! (9 ) NITR (INTEGER) : number of iterations (NITR .LE. 4) +! (10 ) JGLOB (INTEGER) : GLOBAL REGION latitude extent [# boxes] +! (11 ) J0_W (INTEGER) : TPCORE REGION latitude offset [# boxes] +! (12 ) IGZD (INTEGER) : Variable equal to 1-I0_W or 1-J0_W +! +! Arguments as Output: +! ============================================================================ +! (1 ) MERR(ID,JD) (REAL*8 ) : adjusted mass error +! (2 ) ALFAX(ID+1,JD) (REAL*8 ) : adjusted ALFAX +! (3 ) BETAX(ID,JD+1) (REAL*8 ) : adjusted BETAX +! +! NOTES: +! (1 ) Differences from "tpcore_mod.f" denoted by !%%% (bmy, 3/10/03) +!****************************************************************************** +! + IMPLICIT NONE + + ! Arguments +!%%% +!%%% MODIFICATIONS FOR NESTED GRID +!%%% Remove LSP, LNP, LEW from arg list (bmy, 3/10/03) +!%%% LOGICAL, INTENT(IN) :: LSP,LNP,LEW +!%%% + INTEGER,INTENT(IN):: ID, JD, IM, JM, NITR, JGLOB,J0_w,IGzd + REAL*8, INTENT(IN) :: AXY(JGLOB) + REAL*8, INTENT(INOUT) :: MERR(1-igzd:IM+igzd,1-igzd:JM+igzd) + REAL*8, INTENT(INOUT) :: ALFAX(1-igzd:IM+igzd+1,1-igzd:JM+igzd) + REAL*8, INTENT(INOUT) :: BETAX(1-igzd:IM+igzd,1-igzd:JM+igzd+1) + + ! Local variables + LOGICAL :: LPOLE + INTEGER :: I, J, K + REAL*8 :: X0(1-igzd:IM+igzd,1-igzd:JM+igzd) + + !================================================================= + ! PFILTR begins here! + !================================================================= + + ! LPOLE is true if J=1 is the SOUTH POLE and J=JM is the NORTH POLE + ! (this is the way GEOS-CHEM is set up, so LPOLE should be TRUE!) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID +!%%% Polar cap stuff, useless for nested-grid simulation +!%%% LPOLE = ( LSP .AND. LNP ) +!%%% + LPOLE = .FALSE. + + ! Zero ALFAX, BETAX, save MERR in X0 + DO J = 1-IGZD, JM+IGZD + DO I = 1-IGZD, IM+IGZD + ALFAX(I,J) = 0.D0 + BETAX(I,J) = 0.D0 + X0(I,J) = MERR(I,J) + ENDDO + + ALFAX(IM+IGZD+1,J) = 0.D0 + ENDDO + + DO I = 1-IGZD, IM+IGZD + BETAX(I,JM+IGZD+1) = 0.D0 + ENDDO + + !================================================================= + ! Call LOCFLT to do the local filtering + !================================================================= + !write(6,*) 'before LOCFLT' + !write(6,*) 'sum of MERR ', sum(MERR) + !write(6,*) 'sum of ALFAX ', sum(ALFAX) + !write(6,*) 'sum of BETAX ', sum(BETAX) + + CALL LOCFLT( MERR, ALFAX, BETAX, AXY, ID, JD, + & IM, JM, 5, JGLOB, J0_w,Igzd ) + + !write(6,*) 'After LOCFLT' + !write(6,*) 'sum of MERR ', sum(MERR) + !write(6,*) 'sum of ALFAX ', sum(ALFAX) + !write(6,*) 'sum of BETAX ', sum(BETAX) + + !================================================================= + ! Call POLFLT to do the pole filtering (if necessary) + !================================================================= + IF ( LPOLE ) THEN + CALL POLFLT( MERR, BETAX, AXY, 1.D0, ID, JD, IM, JM ) + ENDIF + + !================================================================= + ! Compute mass error MERR and return + ! MERR, ALFAX, and BETAX are now adjusted + !================================================================= + DO J = 1-IGZD, JM+IGZD + DO I = 1-IGZD, IM+IGZD + MERR(I,J) = X0(I,J) + ALFAX(I,J) - ALFAX(I+1,J) + & + BETAX(I,J) - BETAX(I,J+1) + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE PFILTR + +!------------------------------------------------------------------------------ + + SUBROUTINE LOCFLT( XERR, AX, BX, AXY, ID, JD, + & IM, JM, NITR, JGLOB, J0_W, IGZD ) +! +!****************************************************************************** +! Subroutine LOCFLT applies the pressure-filter to non-polar boxes. +! LOCFLT is called from subroutine PFILTR above (bdf, bmy, 3/10/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) XERR(ID,JD) (REAL*8 ) : mass error +! (2 ) AX(ID+1,JD) (REAL*8 ) : perturbed ALFA by XERR +! (3 ) BX(ID,JD+1) (REAL*8 ) : perturbed BETA by XERR +! (4 ) AXY(ID,JD) (REAL*8 ) : area of grid box (I,J) in [m^2] +! (5-6) ID, JD (INTEGER) : "Global" array dimensions for lon, lat +! (7-8) IM, JM (INTEGER) : "Window" array dimensions for lon, lat +! (9 ) NITR (INTEGER) : number of iterations (NITR .LE. 4) +! (10 ) JGLOB (INTEGER) : GLOBAL REGION latitude extent [# boxes] +! (11 ) J0_W (INTEGER) : TPCORE REGION latitude offset [# boxes] +! (12 ) IGZD (INTEGER) : Variable equal to 1-I0_W or 1-J0_W +! +! Arguments as Output: +! ============================================================================ +! (1 ) XERR(ID,JD) (REAL*8 ) : adjusted mass error +! (2 ) AX(ID+1,JD) (REAL*8 ) : adjusted AX +! (3 ) BX(ID,JD+1) (REAL*8 ) : adjusted BX +! +! NOTES: +! (1 ) Differences from "tpcore_mod.f" denoted by "!%%%" (bmy, 3/10/03) +!****************************************************************************** +! + IMPLICIT NONE +!%%% +!%%% MODIFICATIONS FOR NESTED GRID +!%%% Remove LSP, LNP, LEW from arg list (bmy, 3/10/03) +!%%% LOGICAL, INTENT(IN) :: LSP, LNP, LEW +!%%% + ! Arguments + INTEGER, INTENT(IN) :: IGZD, ID, JD, IM, JM, NITR, JGLOB, J0_W + REAL*8, INTENT(IN) :: AXY(JGLOB) + REAL*8, INTENT(INOUT) :: XERR(1-IGZD:IM+IGZD, 1-IGZD:JM+IGZD ) + REAL*8, INTENT(INOUT) :: AX( 1-IGZD:IM+IGZD+1,1-IGZD:JM+IGZD ) + REAL*8, INTENT(INOUT) :: BX( 1-IGZD:IM+IGZD, 1-IGZD:JM+IGZD+1 ) + + ! Local variables + INTEGER :: I, IA, NAZ, J, J1, J2, NFLTR + REAL*8 :: SUMA, FNAZ8 + REAL*8 :: X0( 1-IGZD:IM+IGZD, 1-IGZD:JM+IGZD ) + + !================================================================= + ! LOCFLT begins here! + ! + ! Initialize corrective column mass flows (kg): AX->alfa, BX->beta + !================================================================= + DO J = 1-IGZD, JM+IGZD + DO I = 1-IGZD, IM+IGZD + X0(I,J) = XERR(I,J) + ENDDO + ENDDO + + !================================================================= + ! Iterate over mass-error filter + ! accumulate corrections in AX & BX + !================================================================= + DO NFLTR = 1, NITR + + !============================================================== + ! calculate AX = E-W filter + !============================================================== + + ! Compute polar box limits + J1 = 1 - IGZD + J2 = JM + IGZD +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% IF ( LSP ) J1 = 2 +!%%% IF ( LNP ) J2 = JM - 1 + + ! Loop over non-polar latitudes +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, FNAZ8 ) +#endif + DO J = J1, J2 + + ! Calculate pressure-filter E-W wind between boxes [I-1] & [I]. + ! Enhance filtered wind by size of EPZ, will redistribute + ! later within + FNAZ8 = 0.125d0 + + DO I = 2-IGZD, IM+IGZD + AX(I,J) = AX(I,J) + FNAZ8 *(XERR(I-1,J) - XERR(I,J)) + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% We don't need to worry about wrapping around the date line +!%%% ! calculate pressure-filter E-W wind at edges I=1 & I=IM+1 +!%%% IF ( LEW ) THEN +!%%% AX(IM+1,J) = AX(IM+1,J) + FNAZ8 * (XERR(IM,J) -XERR(1,J)) +!%%% AX(1,J) = AX(1,J) + FNAZ8 * (XERR(IM,J) -XERR(1,J)) +!%%% ELSE +!%%% + ! WINDOW, assume zero error outside window + AX(1-IGZD,J) = AX(1-IGZD,J) - FNAZ8 * XERR(1-IGZD,J) + AX(IM+IGZD+1,J) = AX(IM+IGZD+1,J) + FNAZ8 * XERR(IM+IGZD,J) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% We don't need to worry about wrapping around the date line +!%%% ENDIF +!%%% + ENDDO + + !============================================================== + ! calculate BX = N-S filter, N-S wind between boxes [J-1] & [J] + !============================================================== +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, FNAZ8 ) +#endif + DO J = 2-IGZD, JM+IGZD + FNAZ8 = 0.25D0 * AXY(J+J0_W) / ( AXY(J+J0_W-1) + & + AXY(J+J0_W) ) + + DO I = 1-IGZD, IM+IGZD + BX(I,J) = BX(I,J) + FNAZ8 * ( XERR(I,J-1) - XERR(I,J) ) + ENDDO + ENDDO + + ! enhance the filtering by factor of 2 ONLY into/out-of polar caps + FNAZ8 = 0.5D0 * AXY(1-IGZD+J0_W) / ( AXY(IGZD+J0_W) + + & AXY(1-IGZD+J0_W) ) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% ! When LSP=TRUE then J=1 is SOUTH POLE +!%%% IF ( LSP ) THEN +!%%% DO I = 1, IM +!%%% BX(I,2) = BX(I,2) + FNAZ8 * (XERR(I,1) -XERR(I,2)) +!%%% ENDDO +!%%% ELSE +!%%% + DO I = 1-IGZD, IM+IGZD + BX(I,1-IGZD)= BX(I,1-IGZD) -0.5D0 *FNAZ8 * XERR(I,1-IGZD) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% BX(I,2)= BX(I,2) +0.5D0 *FNAZ8 * (XERR(I,1) - XERR(I,2)) +!%%% + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% !ENDIF +!%%% + FNAZ8 = 0.5D0 * AXY(JM+IGZD+J0_W+1) / ( AXY(JM+IGZD+J0_W) + & + AXY(JM+IGZD+J0_W+1) ) + +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% ! When LNP=TRUE, then J=JM is NORTH POLE +!%%% IF ( LNP ) THEN +!%%% DO I = 1, IM +!%%% BX(I,JM) = BX(I,JM) +FNAZ8 *(XERR(I,JM-1) -XERR(I,JM)) +!%%% ENDDO +!%%% ELSE +!%%% + DO I = 1-IGZD,IM+IGZD + BX(I,JM+IGZD+1)= BX(I,JM+IGZD+1)+0.5D0*FNAZ8*XERR(I,JM+IGZD) +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% BX(I,JM) = BX(I,JM) + 0.5D0 *FNAZ8 * +!%%% & (XERR(I,JM-1) -XERR(I,JM)) +!%%% + ENDDO +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Polar cap stuff, useless for nested grid +!%%% ENDIF +!%%% + !============================================================== + ! need N-S flux across boundaries if window calculation + ! (assume XERR=0 outside) + ! + ! JM for optimal matrix/looping, it would be best to + ! define XERR=0 for an oversized array XERR(0:IM+1,0:JM+1) + ! Update the mass error (XERR) + !============================================================== + DO J = 1-IGZD, JM+IGZD + DO I = 1-IGZD, IM+IGZD + XERR(I,J) = X0(I,J) + AX(I,J) - AX(I+1,J) + & + BX(I,J) - BX(I,J+1) + ENDDO + ENDDO + + ENDDO ! NFLTR + + ! Return to calling program + END SUBROUTINE LOCFLT + +!------------------------------------------------------------------------------ + + SUBROUTINE POLFLT( XERR, BX, AXY, COEF, ID, JD, IM, JM ) +! +!****************************************************************************** +! Subroutine POLFLT applies the pressure-filter to polar boxes. +! POLFLT is called from subroutine PFILTR above (bdf, bmy, 3/10/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) XERR(ID,JD) (REAL*8 ) : mass error +! (2 ) BX(ID,JD+1) (REAL*8 ) : perturbed BETA by XERR +! (3 ) AXY(ID,JD) (REAL*8 ) : area of grid box (I,J) in [m^2] +! (4 ) COEF (REAL*8 ) : Multiplicative coefficient ????? +! (5-6) ID, JD (INTEGER) : "Window" array dimensions for lon, lat +! (7-8) IM, JM (INTEGER) : "Global" array dimensions for lon, lat +! +! Arguments as Output: +! ============================================================================ +! (1 ) XERR(ID,JD) (REAL*8 ) : adjusted mass error +! (2 ) BX(ID,JD+1) (REAL*8 ) : adjusted BX +! +! NOTES: +! (1 ) Differences from "tpcore_mod" denoted by !%%% (bmy, 3/10/03) +!****************************************************************************** +! + IMPLICIT NONE + + ! Arguments + INTEGER, INTENT(IN) :: ID, JD, IM, JM + REAL*8, INTENT(IN) :: AXY(JD) + REAL*8, INTENT(IN) :: COEF + REAL*8, INTENT(INOUT) :: XERR(ID,JD) + REAL*8, INTENT(INOUT) :: BX(ID,JD+1) + + ! Local variables + INTEGER :: I, J + REAL*8 :: ERAV, BXJ(JD+1), TOTAL + + !================================================================= + ! POLFLT begins here! + ! + ! Initialize corrective column mass flows (kg): BXJ->beta + !================================================================= + DO I = 1, IM + + ! Initialize + ERAV = 0.D0 + TOTAL = 0.D0 + + ! Sum XERR in ERAV and sum AXY in TOTAL + DO J = 1, JM + ERAV = ERAV + XERR(I,J) + TOTAL = TOTAL + AXY(J) + ENDDO + + ! Compute area-weighted mass error total + ERAV = ERAV / TOTAL + + ! mass-error filter, make corrections in BX + BXJ(1) = 0.D0 + + DO J = 2, JM + BXJ(J) = BXJ(J-1) + XERR(I,J-1) - AXY(J-1) * ERAV + ENDDO + + DO J = 2, JM + BX(I,J) = BX(I,J) + COEF * BXJ(J) + ENDDO + + ENDDO ! I + + ! Update XERR + DO J = 1, JM + DO I = 1, IM + XERR(I,J) = XERR(I,J) + BX(I,J) - BX(I,J+1) + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE POLFLT + +!------------------------------------------------------------------------------ + + SUBROUTINE DIAG_FLUX( IC, FX, FX1_TP, FY, FY1_TP, + & FZ, FZ1_TP, NDT, ACOSP, Jmax, + & I0_W, J0_W, IM_W, JM_W, IGZD ) +! +!****************************************************************************** +! Subroutine DIAG_FLUX archives the mass fluxes in TPCORE version 7.1. +! (bey, bmy, 9/20/00, 6/20/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IC (INTEGER) : Current tracer # +! (2,3) FX,FX1_TP (REAL*8 ) : Flux into the west side of grid box (I,J,K) +! (4,5) FY,FY1_TP (REAL*8 ) : Flux into the south side of grid box (I,J,K) +! (6,7) FZ,FZ1_TP (REAL*8 ) : Flux into top of grid box (I,J,K) +! (8 ) NDT (INTEGER) : Dynamic timestep in seconds +! (9 ) ACOSP (INTEGER) : Inverse cosine at latitude (J) +! (10 ) Jmax (INTEGER) : Max dimension for TPCORE internal arrays +! (11 ) I0_W (INTEGER) : TPCORE REGION longitude offset [# boxes] +! (12 ) J0_W (INTEGER) : TPCORE REGION latitude offset [# boxes] +! (13 ) IM_W (INTEGER) : TPCORE REGION longitude extent [# boxes] +! (14 ) JM_W (INTEGER) : TPCORE REGION latitude extent [# boxes] +! (15 ) IGZD (INTEGER) : Variable equal to 1-I0_W or 1-J0_W +! +! Diagnostics archived: +! ============================================================================ +! (1 ) ND24 : Eastward flux of tracer in kg/s +! (2 ) ND25 : Westward flux of tracer in kg/s +! (3 ) ND26 : Upward flux of tracer in kg/s +! +! NOTES: +! (1 ) Differences from "tpcore_mod.f" denoted by !%%% (bmy, 3/10/03) +! (2 ) Now references TCVV & ITS_A_CH4_SIM from "tracer_mod.f" (bmy, 7/20/04) +! (3 ) Remove code for the CO-OH simulation (bmy, 6/24/05) +!****************************************************************************** +! + ! References to F90 modules + USE DIAG_MOD, ONLY : MASSFLEW, MASSFLNS, MASSFLUP + USE GLOBAL_CH4_MOD, ONLY : XNUMOL_CH4, TCH4 + USE GRID_MOD, ONLY : GET_AREA_M2 + USE TRACER_MOD, ONLY : TCVV, ITS_A_CH4_SIM + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic switches +# include "CMN_GCTM" ! g0_100 + + ! Arguments + INTEGER, INTENT(IN) :: IC, NDT, Jmax + INTEGER, INTENT(IN) :: I0_W, J0_W, IM_W, JM_W, IGZD + REAL*8, INTENT(IN) :: FX( IM_W+1, JM_W, LLPAR ) + REAL*8, INTENT(IN) :: FX1_TP( IM_W, JM_W, LLPAR ) + REAL*8, INTENT(IN) :: FY( IM_W, JM_W+1, LLPAR ) + REAL*8, INTENT(IN) :: FY1_TP( IM_W, JM_W, LLPAR ) + REAL*8, INTENT(IN) :: FZ( IM_W, JM_W, LLPAR+1 ) + REAL*8, INTENT(IN) :: FZ1_TP( IM_W, JM_W, LLPAR ) + REAL*8, INTENT(IN) :: ACOSP(-10:Jmax) + + ! Local variables + INTEGER :: I, J, JREF, K, K2 + REAL*8 :: DTC, DTDYN + + ! Local SAVEd variables + LOGICAL, SAVE :: FIRST = .TRUE. + REAL*8, SAVE :: DXYP(JJPAR) + + !================================================================= + ! DIAG_FLUX begins here! + ! + ! FX, FX1_TP, FY, FY1_TP, FZ, FZ1_TP have units of [mb/timestep]. + ! + ! To get tracer fluxes in kg/s : + ! * (100./9.8) => kg/m2 + ! * DXYP(J)/(DTDYN * TCVV(IC)) => kg/s + ! + ! Direction of the fluxes : + ! ---------------------------------------------------------------- + ! FX(I,J,K) => flux coming into the west edge of the box I + ! (from I-1 to I). + ! => a positive flux goes from west to east. + ! + ! FY(I,J,K) => flux coming into the south edge of the box J + ! (from J to J-1). + ! => a positive flux goes from south to north + ! (from J-1 to J) + ! + ! FZ(I,J,K) => flux coming down into the box k. + ! => a positive flux goes down. + !================================================================= + + ! DTDYN = double precision value for NDT, the dynamic timestep + DTDYN = DBLE( NDT ) + + ! First-time initialization + IF ( FIRST ) THEN + + ! Surface area [m2] + DO J = 1, JJPAR + DXYP(J) = GET_AREA_M2( J ) + ENDDO + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + !================================================================= + ! ND24 Diagnostic: Eastward flux of tracer in [kg/s] + !================================================================= + IF ( ND24 > 0 ) THEN + +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, JREF, K, K2, DTC ) +#endif + DO K = 1, LLPAR + + ! K is the vertical index down from the atmosphere top downwards + ! K2 is the vertical index up from the surface + K2 = LLPAR - K + 1 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% + DO J = 1,JM_W + JREF = J +J0_W + DO I = 1, IM_W + DTC = ( FX(I,J,K) + FX1_TP(I,J,K) ) * + & ( G0_100 * DXYP(JREF) ) / + & ( TCVV(IC) * DTDYN ) + + MASSFLEW(I+I0_W,J+J0_W,K2,IC) = + & MASSFLEW(I+I0_W,J+J0_W,K2,IC) + DTC + ENDDO + ENDDO + ENDDO + ENDIF + + !================================================================= + ! ND25 Diagnostic: Northward flux of tracer in [kg/s] + !================================================================= + IF ( ND25 > 0 ) THEN + +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, JREF, K, K2, DTC ) +#endif + DO K = 1, LLPAR + + ! K is the vertical index down from the atmosphere top downwards + ! K2 is the vertical index up from the surface + K2 = LLPAR - K + 1 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% + DO J = 1, JM_W + JREF = J +J0_W + DO I = 1, IM_W + DTC = ( FY(I,J,K) + FY1_TP(I,J,K) ) * + & ( ACOSP(J) * G0_100 * DXYP(JREF) ) / + & ( TCVV(IC) * DTDYN ) + + ! Contribution for CH4 run (bmy, 1/17/01) + IF ( ITS_A_CH4_SIM() ) THEN + TCH4(I+I0_W,J+J0_W,K,10)=TCH4(I+I0_W,J+J0_W,K,10)+ + & ( DTC * DTDYN * XNUMOL_CH4 ) + ENDIF + + MASSFLNS(I+I0_W,J+J0_W,K2,IC) = + & MASSFLNS(I+I0_W,J+J0_W,K2,IC) + DTC + ENDDO + ENDDO + ENDDO + ENDIF + + !================================================================= + ! ND26 Diagnostic : Upward flux of tracer in [kg/s] + !================================================================= + IF ( ND26 > 0 ) THEN + +#if defined( multitask ) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, JREF, K, K2, DTC ) +#endif + DO K = 1, LLPAR + + ! K is the vertical index down from the atmosphere top downwards + ! K2 is the vertical index up from the surface + ! flux through top of the atmosphere is always zero, so don't need + ! to archive it. While flux through the surface is not zero, + ! so move the array index downward a layer + ! DTC is the flux through the bottom of the box (yxw,02/09/2003) + K2 = LLPAR - K + 1 +!%%% +!%%% MODIFICATIONS FOR NESTED GRID (yxw, bmy, 3/10/03) +!%%% Rewrite DO-loop limits +!%%% + DO J = 1, JM_W + JREF = J +J0_W + DO I = 1, IM_W + DTC = ( FZ(I,J,K) + FZ1_TP(I,J,K) ) * + & ( G0_100 * DXYP(JREF) ) / + & ( TCVV(IC) * DTDYN ) + +!#IF DEFINED( LGEOSCO ) +! Not really the cross-tropopause flux - there is some horizontal +! transport across tropopause as well. +! IF ( K2 == LPAUSE(I,J) - 1 ) THEN +! TCO(I,J,1,10) = TCO(I,J,1,10) + +! & DTC * DTDYN * XNUMOL_CO +! ENDIF +!#endif + MASSFLUP(I+I0_W,J+J0_W,K2,IC) = + & MASSFLUP(I+I0_W,J+J0_W,K2,IC) + DTC + ENDDO + ENDDO + ENDDO + ENDIF + + ! Return to calling program + END SUBROUTINE DIAG_FLUX + +!------------------------------------------------------------------------------ + + SUBROUTINE POSITION_WINDOW( JS, JN, JL, JH, OUT, J1_IN, J2_IN ) + +C Determine the relationship of (JS0,JN0) and (J1_W, J2_W) (yxw, 08/23/01) +C (ji_in,j2_in) are the part of the window inside the region (JS0,JN0) + + INTEGER JS, JN,JL, JH, J1_IN, J2_IN + LOGICAL OUT + + IF (JH .GT. JS) THEN + IF (JL .GT. JN) THEN + OUT=.TRUE. + ELSE + OUT=.FALSE. + IF ((JH-JS) .GE. (JN-JS)) THEN + J2_IN=JN + ELSE + J2_IN=JH + ENDIF + IF (JL .GE. JS) THEN + J1_IN=JL + ELSE + J1_IN=JS + ENDIF + ENDIF + ELSE + OUT=.TRUE. + ENDIF + + ! Return to TPCORE + END SUBROUTINE POSITION_WINDOW + +!------------------------------------------------------------------------------ + END MODULE TPCORE_WINDOW_MOD diff --git a/code/tracerid_mod.f b/code/tracerid_mod.f new file mode 100644 index 0000000..c89bd6e --- /dev/null +++ b/code/tracerid_mod.f @@ -0,0 +1,1719 @@ +! $Id: tracerid_mod.f,v 1.1 2009/06/09 21:51:50 daven Exp $ + MODULE TRACERID_MOD +! +!****************************************************************************** +! Module TRACERID_MOD contains variables which point to SMVGEAR species, +! CTM Tracers, Biomass species, and biofuel species located within various +! GEOS-CHEM arrays. (bmy, 11/12/02, 2/14/08) +! +! Module Variables: +! ============================================================================ +! (1 ) NNNTRID (INTEGER) : Max # of tracers +! (2 ) MMMEMBER (INTEGER) : Max # of members per chemical family +! (3 ) NMEMBER (INTEGER) : Number of members per each family tracer +! (4 ) IDTRMB (INTEGER) : Species # for each component of family tracer +! (5 ) IDEMIS (INTEGER) : Emission array for SMVGEAR +! (6 ) CTRMB (REAL*8 ) : Array for # of moles member/moles tracer +! (7 ) IDO3 (INTEGER) : O3 index w/in CSPEC array ("comode_mod.f") +! (8 ) IDNO2 (INTEGER) : NO2 index w/in CSPEC array ("comode_mod.f") +! (9 ) IDNO3 (INTEGER) : NO3 index w/in CSPEC array ("comode_mod.f") +! (10 ) IDN2O5 (INTEGER) : N2O5 index w/in CSPEC array ("comode_mod.f") +! (11 ) IDHNO4 (INTEGER) : HNO4 index w/in CSPEC array ("comode_mod.f") +! (12 ) IDOX (INTEGER) : OX index w/in CSPEC array ("comode_mod.f") +! (13 ) IDNOX (INTEGER) : NOX index w/in CSPEC array ("comode_mod.f") +! (14 ) IDHC1 (INTEGER) : HC1 index w/in CSPEC array ("comode_mod.f") +! (15 ) IDNO (INTEGER) : NO index w/in CSPEC array ("comode_mod.f") +! (16 ) IDHNO2 (INTEGER) : HNO2 index w/in CSPEC array ("comode_mod.f") +! (17 ) IDCO (INTEGER) : CO index w/in CSPEC array ("comode_mod.f") +! (18 ) IDPRPE (INTEGER) : PRPE index w/in CSPEC array ("comode_mod.f") +! (19 ) IDISOP (INTEGER) : ISOP index w/in CSPEC array ("comode_mod.f") +! (20 ) IDALK4 (INTEGER) : ALK4 index w/in CSPEC array ("comode_mod.f") +! (21 ) IDC3H8 (INTEGER) : C3H8 index w/in CSPEC array ("comode_mod.f") +! (22 ) IDPAN (INTEGER) : PAN index w/in CSPEC array ("comode_mod.f") +! (23 ) IDGLPAN (INTEGER) : GLPAN index w/in CSPEC array ("comode_mod.f") +! (24 ) IDGPAN (INTEGER) : GPAN index w/in CSPEC array ("comode_mod.f") +! (25 ) IDPMN (INTEGER) : PMN index w/in CSPEC array ("comode_mod.f") +! (26 ) IDPPN (INTEGER) : PPN index w/in CSPEC array ("comode_mod.f") +! (27 ) IDHNO3 (INTEGER) : HNO3 index w/in CSPEC array ("comode_mod.f") +! (28 ) IDOH (INTEGER) : OH index w/in CSPEC array ("comode_mod.f") +! (29 ) IDHO2 (INTEGER) : HO2 index w/in CSPEC array ("comode_mod.f") +! (30 ) IDH2O2 (INTEGER) : H2O2 index w/in CSPEC array ("comode_mod.f") +! (31 ) IDACET (INTEGER) : ACET index w/in CSPEC array ("comode_mod.f") +! (32 ) IDMEK (INTEGER) : MEK index w/in CSPEC array ("comode_mod.f") +! (33 ) IDALD2 (INTEGER) : ALD2 index w/in CSPEC array ("comode_mod.f") +! (34 ) IDRCHO (INTEGER) : RCHO index w/in CSPEC array ("comode_mod.f") +! (35 ) IDMVK (INTEGER) : MVK index w/in CSPEC array ("comode_mod.f") +! (36 ) IDMACR (INTEGER) : MACR index w/in CSPEC array ("comode_mod.f") +! (37 ) IDISN2 (INTEGER) : ISN2 index w/in CSPEC array ("comode_mod.f") +! (38 ) IDR4N2 (INTEGER) : R4N2 index w/in CSPEC array ("comode_mod.f") +! (39 ) IDCH2O (INTEGER) : CH2O index w/in CSPEC array ("comode_mod.f") +! (40 ) IDC2H6 (INTEGER) : C2H6 index w/in CSPEC array ("comode_mod.f") +! (41 ) IDMP (INTEGER) : MP index w/in CSPEC array ("comode_mod.f") +! (42 ) IDDMS (INTEGER) : DMS index w/in CSPEC array ("comode_mod.f") +! (43 ) IDSO2 (INTEGER) : SO2 index w/in CSPEC array ("comode_mod.f") +! (44 ) IDSO4 (INTEGER) : SO4 index w/in CSPEC array ("comode_mod.f") +! (45 ) IDMSA (INTEGER) : MSA index w/in CSPEC array ("comode_mod.f") +! (46 ) IDDRYO3 (INTEGER) : DRYO3 index w/in CSPEC array ("comode_mod.f") +! (47 ) IDDRYPAN (INTEGER) : DRYPAN index w/in CSPEC array ("comode_mod.f") +! (48 ) IDDRYNO2 (INTEGER) : DRYNO2 index w/in CSPEC array ("comode_mod.f") +! (49 ) IDTNOX (INTEGER) : NOx index w/in STT array ("tracer_mod.f") +! (50 ) IDTOX (INTEGER) : Ox index w/in STT array ("CMN") +! (51 ) IDTPAN (INTEGER) : PAN index w/in STT array ("tracer_mod.f") +! (52 ) IDTCO (INTEGER) : CO index w/in STT array ("tracer_mod.f") +! (53 ) IDTALK4 (INTEGER) : ALK4 index w/in STT array ("tracer_mod.f") +! (54 ) IDTISOP (INTEGER) : ISOP index w/in STT array ("tracer_mod.f") +! (55 ) IDTHNO3 (INTEGER) : HNO3 index w/in STT array ("tracer_mod.f") +! (56 ) IDTH2O2 (INTEGER) : H2O2 index w/in STT array ("tracer_mod.f") +! (57 ) IDTACET (INTEGER) : ACET index w/in STT array ("tracer_mod.f") +! (58 ) IDTMEK (INTEGER) : MEK index w/in STT array ("tracer_mod.f") +! (59 ) IDTALD2 (INTEGER) : ALD2 index w/in STT array ("tracer_mod.f") +! (60 ) IDTRCHO (INTEGER) : RCHO index w/in STT array ("tracer_mod.f") +! (61 ) IDTMVK (INTEGER) : MVK index w/in STT array ("tracer_mod.f") +! (62 ) IDTMACR (INTEGER) : MACR index w/in STT array ("tracer_mod.f") +! (63 ) IDTPMN (INTEGER) : PMN index w/in STT array ("tracer_mod.f") +! (64 ) IDTPPN (INTEGER) : PPN index w/in STT array ("tracer_mod.f") +! (65 ) IDTISN2 (INTEGER) : ISN2 index w/in STT array ("tracer_mod.f") +! (66 ) IDTR4N2 (INTEGER) : R4N2 index w/in STT array ("tracer_mod.f") +! (67 ) IDTPRPE (INTEGER) : PRPE index w/in STT array ("tracer_mod.f") +! (68 ) IDTC3H8 (INTEGER) : C3H8 index w/in STT array ("tracer_mod.f") +! (69 ) IDTCH2O (INTEGER) : CH2O index w/in STT array ("tracer_mod.f") +! (70 ) IDTMP (INTEGER) : MP index w/in STT array ("tracer_mod.f") +! (71 ) IDTN2O5 (INTEGER) : N2O5 index w/in STT array ("tracer_mod.f") +! (72 ) IDTHNO4 (INTEGER) : HNO4 index w/in STT array ("tracer_mod.f") +! (73 ) IDTC2H6 (INTEGER) : C2H6 index w/in STT array ("tracer_mod.f") +! (74 ) IDTDMS (INTEGER) : DMS index w/in STT array ("tracer_mod.f") +! (75 ) IDTSO2 (INTEGER) : SO2 index w/in STT array ("tracer_mod.f") +! (76 ) IDTSO4 (INTEGER) : SO4 index w/in STT array ("tracer_mod.f") +! (77 ) IDTSO4aq (INTEGER) : SO4aq index w/in STT array ("tracer_mod.f") +! (78 ) IDTSO4s (INTEGER) : SO4s index w/in STT array ("tracer_mod.f") +! (79 ) IDTMSA (INTEGER) : MSA index w/in STT array ("tracer_mod.f") +! (80 ) IDTNH3 (INTEGER) : NH3 index w/in STT array ("tracer_mod.f") +! (81 ) IDTNH4 (INTEGER) : NH4 index w/in STT array ("tracer_mod.f") +! (82 ) IDTNIT (INTEGER) : NIT index w/in STT array ("tracer_mod.f") +! (83 ) IDTNITs (INTEGER) : NITs index w/in STT array ("tracer_mod.f") +! (84 ) IDTRN (INTEGER) : Rn index w/in STT array ("tracer_mod.f") +! (85 ) IDTPB (INTEGER) : Pb index w/in STT array ("tracer_mod.f") +! (86 ) IDTBE7 (INTEGER) : Be7 index w/in STT array ("tracer_mod.f") +! (87 ) IDTBCPI (INTEGER) : BCPI index w/in STT array ("tracer_mod.f") +! (88 ) IDTBCPO (INTEGER) : BCPO index w/in STT array ("tracer_mod.f") +! (89 ) IDTOCPI (INTEGER) : OCPI index w/in STT array ("tracer_mod.f") +! (90 ) IDTOCPO (INTEGER) : OCPO index w/in STT array ("tracer_mod.f") +! (91 ) IDTALPH (INTEGER) : ALPH index w/in STT array ("tracer_mod.f") +! (92 ) IDTLIMO (INTEGER) : LIMO index w/in STT array ("tracer_mod.f") +! (93 ) IDTALCO (INTEGER) : ALCO index w/in STT array ("tracer_mod.f") +! (94 ) IDTSOG1 (INTEGER) : SOG1 index w/in STT array ("tracer_mod.f") +! (95 ) IDTSOG2 (INTEGER) : SOG2 index w/in STT array ("tracer_mod.f") +! (96 ) IDTSOG3 (INTEGER) : SOG3 index w/in STT array ("tracer_mod.f") +! (97 ) IDTSOA1 (INTEGER) : SOA1 index w/in STT array ("tracer_mod.f") +! (98 ) IDTSOA2 (INTEGER) : SOA2 index w/in STT array ("tracer_mod.f") +! (99 ) IDTSOA3 (INTEGER) : SOA3 index w/in STT array ("tracer_mod.f") +! (100) IDTDST1 (INTEGER) : DST1 index w/in STT array ("tracer_mod.f") +! (101) IDTDST2 (INTEGER) : DST2 index w/in STT array ("tracer_mod.f") +! (102) IDTDST3 (INTEGER) : DST3 index w/in STT array ("tracer_mod.f") +! (103) IDTDST4 (INTEGER) : DST4 index w/in STT array ("tracer_mod.f") +! (104) IDTSALA (INTEGER) : SALA index w/in STT array ("tracer_mod.f") +! (105) IDTSALC (INTEGER) : SALC index w/in STT array ("tracer_mod.f") +! (109) IDENOX (INTEGER) : NOx index w/in EMISRRN array ("CMN_O3") +! (110) IDEOX (INTEGER) : Ox index w/in EMISRR array ("CMN_O3") +! (111) IDECO (INTEGER) : CO index w/in EMISRR array ("CMN_O3") +! (112) IDEPRPE (INTEGER) : PRPE index w/in EMISRR array ("CMN_O3") +! (113) IDEC3H8 (INTEGER) : C3H8 index w/in EMISRR array ("CMN_O3") +! (114) IDEALK4 (INTEGER) : ALK4 index w/in EMISRR array ("CMN_O3") +! (115) IDEC2H6 (INTEGER) : C2H6 index w/in EMISRR array ("CMN_O3") +! (116) IDEISOP (INTEGER) : ISOP index w/in EMISRR array ("CMN_O3") +! (117) IDEACET (INTEGER) : ACET index w/in EMISRR array ("CMN_O3") +! (118) IDEMEK (INTEGER) : MEK index w/in EMISRR array ("CMN_O3") +! (119) IDEALD2 (INTEGER) : ALD2 index w/in EMISRR array ("CMN_O3") +! (120) IDECH2O (INTEGER) : CH2O index w/in EMISRR array ("CMN_O3") +! (121) NEMBIOG (INTEGER) : # of biogenic emission species for SMVGEAR +! (122) NEMANTHRO (INTEGER) : # of anthro emission species for SMVGEAR +! (132) IDBFPRPE (INTEGER) : PRPE index w/in BURNEMIS array (biofuel_mod.f) +! (133) IDBALK4 (INTEGER) : ALD4 index w/in BURNEMIS array (biomass_mod.f) +! (134) IDBFNOX (INTEGER) : NOx index w/in BIOFUEL array (biofuel_mod.f) +! (135) IDBFCO (INTEGER) : CO index w/in BIOFUEL array (biofuel_mod.f) +! (136) IDBFALK4 (INTEGER) : ALK4 index w/in BIOFUEL array (biofuel_mod.f) +! (137) IDBFACET (INTEGER) : ACET index w/in BIOFUEL array (biofuel_mod.f) +! (138) IDBFMEK (INTEGER) : MEK index w/in BIOFUEL array (biofuel_mod.f) +! (139) IDBFALD2 (INTEGER) : ALD2 index w/in BIOFUEL array (biofuel_mod.f) +! (140) IDBFPRPE (INTEGER) : PRPE index w/in BIOFUEL array (biofuel_mod.f) +! (141) IDBFC3H8 (INTEGER) : NOx index w/in BIOFUEL array (biofuel_mod.f) +! (142) IDBFCH2O (INTEGER) : NOx index w/in BIOFUEL array (biofuel_mod.f) +! (143) IDBFC2H6 (INTEGER) : NOx index w/in BIOFUEL array (biofuel_mod.f) +! +! Module Routines: +! ============================================================================ +! (1 ) TRACERID : Defines tracer, biomass, biofuel, & anthro ID numbers +! (2 ) SETTRACE : Defines ID numbers for species in SMVGEAR mechanism +! (3 ) INIT_TRACERID : Zeroes all module variables +! +! GEOS-CHEM modules referenced by tracerid_mod.f +! ============================================================================ +! (1 ) charpak_mod.f : Module containing string handling routines +! (2 ) error_mod.f : Module containing I/O error and NaN check routines +! +! NOTES: +! (1 ) Added additional SMVGEAR species flags for DMS, SO2, SO4, MSA, so that +! these species can be handled w/in SMVGEAR (rjp, bmy, 3/23/03) +! (2 ) Added modifications for SMVGEAR II (bdf, bmy, 4/1/03) +! (3 ) Added extra flags for carbon & dust tracers (rjp, tdf, bmy, 4/1/04) +! (4 ) Added extra flags for seasalt tracers (rjp, bec, bmy, 4/20/04) +! (5 ) Increase NNNTRID for carb+dust+seasalt tracers (bmy, 4/26/04) +! (6 ) Increase NNNTRID & add extra flags for SOA tracers. (rjp, bmy, 7/13/04) +! (7 ) Bug fix: reverse IDECH2O and IDEISOP (bmy, 11/15/04) +! (8 ) Added IDTHG0, IDTHG2, IDTHGP + tagged Hg's (eck, bmy, 12/7/04) +! (9 ) Added IDTAS, IDTAHS, IDTLET, IDTNH4aq, IDTSO4aq (cas, bmy, 12/20/04) +! (10) Added IDTSO4s, IDTNITs +! (11) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (12) Added functions IS_Hg0, IS_Hg2, IS_HgP. Also now use index arrays +! ID_Hg0, ID_Hg2, ID_HgP for tagged Hg tracers. (cdh, bmy, 1/5/06) +! (13) Remove IDBxxxx biomass flags; these aren't needed. (bmy, 4/5/06) +! (14) Add IDTSOG4 and IDTSOA4 (dkh, bmy, 5/18/06) +! (15) Minor fixes for CH3I simulation (bmy, 7/25/06) +! (16) Add IDTH2 and IDTHD for H2/HD simulation (hup, lyj, phs, 9/18/07) +! (17) Set IDECO=1 for Tagged CO simulation (jaf, mak, bmy, 2/14/08) +! (18) Add IDEHNO3 to deal with ship NOx emissions (phs, 3/4/08) +! (19) Added tracers and emissions for dicarbonyl simulation (tmf, 1/7/09) +!****************************************************************************** +! + IMPLICIT NONE + + ! for CTM tracers + INTEGER, PARAMETER :: NNNTRID = 73 + INTEGER, PARAMETER :: MMMEMBER = 10 + INTEGER :: NMEMBER(NNNTRID) + INTEGER :: IDTRMB(NNNTRID,MMMEMBER) + INTEGER :: IDEMIS(NNNTRID) + REAL*8 :: CTRMB(NNNTRID,MMMEMBER) + + ! ID's for SMVGEAR species + INTEGER :: IDO3, IDNO2, IDNO3, IDN2O5, IDHNO4 + INTEGER :: IDOX, IDNOX, IDHC1, IDNO, IDHNO2 + INTEGER :: IDCO, IDPRPE, IDISOP, IDALK4, IDC3H8 + INTEGER :: IDPAN, IDGLPAN, IDGPAN, IDPMN, IDPPN + INTEGER :: IDHNO3, IDOH, IDHO2, IDH2O2, IDACET + INTEGER :: IDMEK, IDALD2, IDRCHO, IDMVK, IDMACR + INTEGER :: IDISN2, IDR4N2, IDCH2O, IDC2H6, IDMP + INTEGER :: IDDMS, IDSO2, IDSO4, IDMSA + INTEGER :: IDDRYO3, IDDRYPAN, IDDRYNO2, IDSO4s + INTEGER :: IDGLYX, IDMGLY + INTEGER :: IDBENZ, IDTOLU, IDXYLE, IDMONX + INTEGER :: IDDRYGLYX, IDDRYMGLY + INTEGER :: IDC2H2, IDC2H4 + INTEGER :: IDMBO, IDGLYC + INTEGER :: IDHAC + INTEGER :: IDAPAN, IDENPAN, IDMPAN, IDNIPAN + INTEGER :: IDDRYAPAN, IDDRYENPAN, IDDRYGLPAN + INTEGER :: IDDRYGPAN, IDDRYMPAN, IDDRYNIPAN + + ! GEOS-CHEM tracer ID's + INTEGER :: IDTNOX, IDTOX, IDTPAN, IDTCO, IDTALK4 + INTEGER :: IDTISOP, IDTHNO3, IDTH2O2, IDTACET, IDTMEK + INTEGER :: IDTALD2, IDTRCHO, IDTMVK, IDTMACR, IDTPMN + INTEGER :: IDTPPN, IDTISN2, IDTR4N2, IDTPRPE, IDTC3H8 + INTEGER :: IDTCH2O, IDTMP, IDTN2O5, IDTHNO4, IDTC2H6 + INTEGER :: IDTDMS, IDTSO2, IDTSO4, IDTMSA, IDTNH3 + INTEGER :: IDTNH4, IDTNIT, IDTRN, IDTPB, IDTBE7 + INTEGER :: IDTBCPI, IDTBCPO, IDTOCPI, IDTOCPO, IDTDST1 + INTEGER :: IDTDST2, IDTDST3, IDTDST4, IDTSALA, IDTSALC + INTEGER :: IDTALPH, IDTLIMO, IDTALCO, IDTSOG1, IDTSOG2 + INTEGER :: IDTSOG3, IDTSOG4, IDTSOA1, IDTSOA2, IDTSOA3 + INTEGER :: IDTSOA4, IDTHG0, IDTHg2, IDTHgP, IDTAS + INTEGER :: IDTAHS, IDTLET, IDTNH4aq,IDTSO4aq,IDTSO4s + INTEGER :: IDTNITs + INTEGER :: IDTBENZ, IDTTOLU, IDTXYLE, IDTMONX + INTEGER :: IDTGLYX, IDTMGLY + INTEGER :: IDTSOAG, IDTSOAM + INTEGER :: IDTC2H2, IDTC2H4 + INTEGER :: IDTMBO, IDTGLYC + INTEGER :: IDTAPAN, IDTENPAN, IDTMPAN, IDTNIPAN + INTEGER :: IDTGLPAN, IDTGPAN + INTEGER :: IDTHAC + !fp for NEI08 + INTEGER :: IDTCH4, IDTNO, IDTNO2, IDTHNO2 + INTEGER :: IDTEOH, IDTMOH + + ! For H2/HD simulation + INTEGER :: IDTH2, IDTHD ! (hup, phs, 9/18/07) + + ! For tagged Hg simulation + INTEGER :: N_Hg_CATS + INTEGER, ALLOCATABLE :: ID_Hg0(:), ID_Hg2(:), ID_HgP(:) + INTEGER :: ID_Hg_tot, ID_Hg_na, ID_Hg_eu + INTEGER :: ID_Hg_as, ID_Hg_rw, ID_Hg_oc + INTEGER :: ID_Hg_ln, ID_Hg_nt + + ! GEOS-CHEM emission ID's + INTEGER :: IDENOX, IDEOX, IDECO, IDEPRPE, IDEC3H8 + INTEGER :: IDEALK4, IDEC2H6, IDEISOP, IDEACET, IDEMEK + INTEGER :: IDEALD2, IDECH2O, IDEHNO3 + INTEGER :: NEMBIOG, NEMANTHRO + INTEGER :: IDEBENZ, IDETOLU, IDEXYLE, IDEMONX + INTEGER :: IDEC2H2, IDEC2H4 + INTEGER :: IDEMBO + INTEGER :: IDEGLYC + INTEGER :: IDEGLYX, IDEMGLY + INTEGER :: IDEHAC + + ! GEOS-CHEM biofuel ID's + INTEGER :: IDBFNOX, IDBFCO, IDBFALK4, IDBFACET + INTEGER :: IDBFMEK, IDBFALD2, IDBFPRPE, IDBFC3H8 + INTEGER :: IDBFCH2O, IDBFC2H6 + INTEGER :: IDBFBENZ, IDBFTOLU, IDBFXYLE + INTEGER :: IDBFC2H2, IDBFC2H4 + INTEGER :: IDBFGLYC + INTEGER :: IDBFGLYX, IDBFMGLY + INTEGER :: IDBFHAC + + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE TRACERID +! +!****************************************************************************** +! Subroutine TRACERID reads the "tracer.dat" file and determines which +! tracers, emission species, biomass burning species, and biofuel burning +! species are turned on/off. (bmy, 3/16/01, 9/18/07) +! +! NOTES: +! (1 ) Original code from Loretta's version of the GISS-II model. Now we +! loop thru the tracer names and flag tracers that way. (bmy, 11/12/02) +! (2 ) Added extra CASEs to the CASE statement for carbon & dust tracers. +! (rjp, tdf, bmy, 4/1/04) +! (3 ) Added extra CASEs to the CASE statement for seasalt tracers. +! (rjp, bec, bmy, 4/20/04) +! (4 ) Added extra CASEs to the CASE statement for SOA tracers. +! (rjp, bmy, 7/13/04) +! (5 ) Now references "tracer_mod.f". NAME is now CHAR*14. (bmy, 7/20/04) +! (6 ) Reverse the position of IDEISOP and IDECH2O so as to keep all of the +! anthropogenic tracers together in IDEMS (bmy, 11/15/04) +! (7 ) Added IDTHG0, IDTHG2, IDTHGP flags (eck, bmy, 12/7/04) +! (8 ) Added IDTAS, IDTAHS, IDTLET, IDTNH4aq, IDTSO4aq. Now no longer need +! to declare IDTCO, IDBCO, IDBFCO for offline aerosol simulations. +! (cas, bmy, 1/26/05) +! (9 ) Added IDTSO4s and IDTNITs (bec, bmy, 4/13/05) +! (10) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (11) Add alternate names for tagged Hg tracers. Also define ocean mercury +! flux categories. Now references LSPLIT from "logical_mod.f". +! (cdh, bmy, 12/15/05) +! (12) Now remove IDBxxx biomass flags (bmy, 4/5/06) +! (13) Now look for IDTSOG4 and IDTSOA4 (bmy, 5/18/06) +! (14) Minor fixes for CH3I simulation (bmy, 7/25/06) +! (15) Now define IDTH2, IDTHD (hup, lyj, phs, 9/18/07) +! (16) To satisfy IF statement in EMISSDR for using EMFOSSIL, we need +! to set IDECO=1 instead of IDECO=2. (jaf, mak, bmy, 2/14/08) +! (17) Increase NEMANTHRO from 10 to 12 and set IDEOX and IDEHNO3 (phs, 3/4/08) +!****************************************************************************** +! + ! References to F90 modules + USE CHARPAK_MOD, ONLY : TRANUC + USE LOGICAL_MOD, ONLY : LSPLIT + USE TRACER_MOD, ONLY : ITS_A_C2H6_SIM, ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM, ITS_A_MERCURY_SIM + USE TRACER_MOD, ONLY : ITS_A_H2HD_SIM + USE TRACER_MOD, ONLY : N_TRACERS, TRACER_NAME + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! IDEMS + + ! Local variables + INTEGER :: N, COUNT, COUNT_Hg0, COUNT_Hg2, COUNT_HgP + CHARACTER(LEN=14) :: NAME + + !================================================================= + ! TRACERID begins here! + ! + ! NOTE: There are still some vestiges of historical baggage, we + ! will get rid of this as time allows (bmy, 11/12/02) + !================================================================= + + ! Zero all ID #'s and allocate Hg index arrays (if necessary) + CALL INIT_TRACERID + + ! Initialize counters + COUNT = 0 + COUNT_Hg0 = 0 + COUNT_Hg2 = 0 + COUNT_HgP = 0 + + !================================================================= + ! Assign tracer, biomass, biofuel, and anthro emission ID's + !================================================================= + DO N = 1, N_TRACERS + + ! Convert tracer name to upper case. TCNAME is in the "CMN" header + ! file -- we might use something better later on (bmy, 11/12/02) + NAME = TRACER_NAME(N) + CALL TRANUC( NAME ) + + ! Find each tracer + SELECT CASE ( TRIM( NAME ) ) + + !------------------------ + ! Full chem tracers + !------------------------ + CASE ( 'NOX' ) + COUNT = COUNT + 1 + IDTNOX = N + IDBFNOX = COUNT + + CASE ( 'OX' ) + IDTOX = N + + CASE ( 'PAN' ) + IDTPAN = N + + CASE ( 'CO' ) + COUNT = COUNT + 1 + IDTCO = N + IDBFCO = COUNT + + ! Special case: Tagged CO + ! Set some emission flags and then exit + ! NOTE: To satisfy IF statement in EMISSDR for using + ! EMFOSSIL, we need to set IDECO=1 instead of IDECO=2. + ! (jaf, mak, bmy, 2/14/08) + IF ( ITS_A_TAGCO_SIM() ) THEN + NEMANTHRO = 1 + IDECO = 1 + IDTISOP = 1 + EXIT + ENDIF + + !----------------------------------- + ! FEW ASSUMPTIONS FOR H2HD SIM: + ! IDTH2=1, IDTHD=2, IDTCO=N('H2') + ! H2/HD simulation requires CO... + ! (hup, lyj, phs, 9/18/07) + !----------------------------------- + CASE ( 'H2' ) + COUNT = COUNT + 1 + IDTCO = N + IDBFCO = COUNT + + ! Special case: Tagged H2 (hup 4/28/2004) + ! Set some emissions flags then exit + IF ( ITS_A_H2HD_SIM() ) THEN + NEMANTHRO = 1 + IDECO = 2 + IDTISOP = 1 + IDTH2 = 1 ! (hup 7/14/2004) + + ENDIF + + ! ... and HD + CASE ( 'HD' ) + COUNT = COUNT + 1 + IDTHD = N + + CASE ( 'ALK4' ) + COUNT = COUNT + 1 + IDTALK4 = N + IDBFALK4 = COUNT + + CASE ( 'ISOP' ) + IDTISOP = N + + CASE ( 'HNO3' ) + IDTHNO3 = N + + CASE ( 'H2O2' ) + IDTH2O2 = N + + CASE ( 'ACET' ) + COUNT = COUNT + 1 + IDTACET = N + IDBFACET = COUNT + + CASE ( 'MEK' ) + COUNT = COUNT + 1 + IDTMEK = N + IDBFMEK = COUNT + + CASE ( 'ALD2' ) + COUNT = COUNT + 1 + IDTALD2 = N + IDBFALD2 = COUNT + + CASE ( 'RCHO' ) + IDTRCHO = N + + CASE ( 'MVK' ) + IDTMVK = N + + CASE ( 'MACR' ) + IDTMACR = N + + CASE ( 'PMN' ) + IDTPMN = N + + CASE ( 'PPN' ) + IDTPPN = N + + CASE ( 'R4N2' ) + IDTR4N2 = N + + CASE ( 'PRPE' ) + COUNT = COUNT + 1 + IDTPRPE = N + IDBFPRPE = COUNT + + CASE ( 'C3H8' ) + COUNT = COUNT + 1 + IDTC3H8 = N + IDBFC3H8 = COUNT + + CASE ( 'CH2O' ) + COUNT = COUNT + 1 + IDTCH2O = N + IDBFCH2O = COUNT + + CASE ( 'C2H6' ) + COUNT = COUNT + 1 + IDTC2H6 = N + IDBFC2H6 = COUNT + + ! Special case: tagged C2H6 + ! Set emission flags and then exit + IF ( ITS_A_C2H6_SIM() ) THEN + NEMANTHRO = 1 + IDEC2H6 = 1 + EXIT + ENDIF + + CASE ( 'N2O5' ) + IDTN2O5 = N + + CASE ( 'HNO4' ) + IDTHNO4 = N + + CASE ( 'MP' ) + IDTMP = N + + !-------------------------------- + ! Sulfur & nitrate aerosols + !-------------------------------- + CASE ( 'DMS' ) + IDTDMS = N + + CASE ( 'SO2' ) + IDTSO2 = N + + CASE ( 'SO4' ) + IDTSO4 = N + + CASE ( 'SO4S' ) + IDTSO4s = N + + CASE ( 'MSA' ) + IDTMSA = N + + CASE ( 'NH3' ) + IDTNH3 = N + + CASE ( 'NH4' ) + IDTNH4 = N + + CASE ( 'NIT' ) + IDTNIT = N + + CASE ( 'NITS' ) + IDTNITs = N + + !-------------------------------- + ! Crystalline & aqueous aerosols + !-------------------------------- + CASE ( 'AS' ) + IDTAS = N + + CASE ( 'AHS' ) + IDTAHS = N + + CASE ( 'LET' ) + IDTLET = N + + CASE ( 'NH4AQ' ) + IDTNH4aq = N + + CASE ( 'SO4AQ' ) + IDTSO4aq = N + + !-------------------------------- + ! Carbon & 2dy organic aerosols + !-------------------------------- + CASE ( 'BCPI' ) + IDTBCPI = N + + CASE ( 'OCPI' ) + IDTOCPI = N + + CASE ( 'BCPO' ) + IDTBCPO = N + + CASE ( 'OCPO' ) + IDTOCPO = N + + CASE ( 'ALPH' ) + IDTALPH = N + + CASE ( 'LIMO' ) + IDTLIMO = N + + CASE ( 'ALCO' ) + IDTALCO = N + + CASE ( 'SOG1' ) + IDTSOG1 = N + + CASE ( 'SOG2' ) + IDTSOG2 = N + + CASE ( 'SOG3' ) + IDTSOG3 = N + + CASE ( 'SOG4' ) + IDTSOG4 = N + + CASE ( 'SOA1' ) + IDTSOA1 = N + + CASE ( 'SOA2' ) + IDTSOA2 = N + + CASE ( 'SOA3' ) + IDTSOA3 = N + + CASE ( 'SOA4' ) + IDTSOA4 = N + + !-------------------------------- + ! Mineral dust aerosols + !-------------------------------- + CASE ( 'DST1' ) + IDTDST1 = N + + CASE ( 'DST2' ) + IDTDST2 = N + + CASE ( 'DST3' ) + IDTDST3 = N + + CASE ( 'DST4' ) + IDTDST4 = N + + !-------------------------------- + ! Seasalt aerosols + !-------------------------------- + CASE ( 'SALA' ) + IDTSALA = N + + CASE ( 'SALC' ) + IDTSALC = N + + !-------------------------------- + ! Dicarbonyls GLYX & MGLY + !-------------------------------- + CASE ( 'GLYX' ) + COUNT = COUNT + 1 + IDTGLYX = N + IDBFGLYX = COUNT + + CASE ( 'MGLY' ) + COUNT = COUNT + 1 + IDTMGLY = N + IDBFMGLY = COUNT + + !-------------------------------- + ! Aromatics tracers + !-------------------------------- + CASE ( 'BENZ' ) + COUNT = COUNT + 1 + IDTBENZ = N + IDBFBENZ = COUNT + + CASE ( 'TOLU' ) + COUNT = COUNT + 1 + IDTTOLU = N + IDBFTOLU = COUNT + + CASE ( 'XYLE' ) + COUNT = COUNT + 1 + IDTXYLE = N + IDBFXYLE = COUNT + + !-------------------------------- + ! Monoterpene + !-------------------------------- + CASE ( 'MONX' ) + IDTMONX = N + + !-------------------------------- + ! SOA from GLYX and MGLY + !-------------------------------- + CASE ( 'SOAG' ) + IDTSOAG = N + + CASE ( 'SOAM' ) + IDTSOAM = N + + !-------------------------------- + ! C2H4 + !-------------------------------- + CASE ( 'C2H4' ) + COUNT = COUNT + 1 + IDTC2H4 = N + IDBFC2H4 = COUNT + + !-------------------------------- + ! C2H2 + !-------------------------------- + CASE ( 'C2H2' ) + COUNT = COUNT + 1 + IDTC2H2 = N + IDBFC2H2 = COUNT + + !-------------------------------- + ! MBO + !-------------------------------- + CASE ( 'MBO' ) + IDTMBO = N + + !-------------------------------- + ! GLYC + !-------------------------------- + CASE ( 'GLYC' ) + COUNT = COUNT + 1 + IDTGLYC = N + IDBFGLYC = COUNT + + !-------------------------------- + ! HAC + !-------------------------------- + CASE ( 'HAC' ) + COUNT = COUNT + 1 + IDTHAC = N + IDBFHAC = COUNT + + !-------------------------------- + ! new PAN species + !-------------------------------- + CASE ( 'APAN' ) + IDTAPAN = N + + CASE ( 'ENPAN' ) + IDTENPAN = N + + CASE ( 'GLPAN' ) + IDTGLPAN = N + + CASE ( 'GPAN' ) + IDTGPAN = N + + CASE ( 'MPAN' ) + IDTMPAN = N + + CASE ( 'NIPAN' ) + IDTNIPAN = N + + !-------------------------------- + ! Rn-Pb-Be tracers + !-------------------------------- + CASE ( 'RN' ) + IDTRN = N + + CASE ( 'PB' ) + IDTPB = N + + CASE ( 'BE7' ) + IDTBE7 = N + + !-------------------------------- + ! CH3I and HCN tracers + !-------------------------------- + + ! Special case: CH3I needs CO biomass/biofuel + CASE ( 'CH3I', 'CH3IOC' ) + COUNT = COUNT + 1 + IDTCO = 1 + IDBFCO = COUNT + NEMANTHRO= 8 ! Reset NEMANTHRO here too (bmy, 7/25/06) + EXIT + + ! Special case: HCN needs CO biomass/biofuel + CASE ( 'HCN' ) + COUNT = COUNT + 1 + IDTCO = 1 + IDBFCO = COUNT + EXIT + + !-------------------------------- + ! Total & tagged mercury tracers + ! (eck, cdh, bmy, 12/15/05) + !-------------------------------- + CASE ( 'HG0' ) + COUNT_Hg0 = COUNT_Hg0 + 1 + ID_Hg_tot = COUNT_Hg0 + IDTHg0 = N + ID_Hg0(COUNT_Hg0) = N + + CASE ( 'HG2' ) + COUNT_Hg2 = COUNT_Hg2 + 1 + ID_Hg2(COUNT_Hg2) = N + + CASE ( 'HGP' ) + COUNT_HgP = COUNT_HgP + 1 + ID_HgP(COUNT_HgP) = N + + CASE ( 'HG0_AN_NA', 'HG0_AN' ) + COUNT_Hg0 = COUNT_Hg0 + 1 + ID_Hg_na = COUNT_Hg0 + ID_Hg0(COUNT_Hg0) = N + + CASE ( 'HG0_AN_EU', 'HG0_AE' ) + COUNT_Hg0 = COUNT_Hg0 + 1 + ID_Hg_eu = COUNT_Hg0 + ID_Hg0(COUNT_Hg0) = N + + CASE ( 'HG0_AN_AS', 'HG0_AA' ) + COUNT_Hg0 = COUNT_Hg0 + 1 + ID_Hg_as = COUNT_Hg0 + ID_Hg0(COUNT_Hg0) = N + + CASE ( 'HG0_AN_RW', 'HG0_AR' ) + COUNT_Hg0 = COUNT_Hg0 + 1 + ID_Hg_rw = COUNT_Hg0 + ID_Hg0(COUNT_Hg0) = N + + CASE ( 'HG0_OC' ) + COUNT_Hg0 = COUNT_Hg0 + 1 + ID_Hg_oc = COUNT_Hg0 + ID_Hg0(COUNT_Hg0) = N + + CASE ( 'HG0_LN' ) + COUNT_Hg0 = COUNT_Hg0 + 1 + ID_Hg_ln = COUNT_Hg0 + ID_Hg0(COUNT_Hg0) = N + + CASE ( 'HG0_NT' ) + COUNT_Hg0 = COUNT_Hg0 + 1 + ID_Hg_nt = COUNT_Hg0 + ID_Hg0(COUNT_Hg0) = N + + CASE ( 'HG2_AN_NA', 'HG2_AN' ) + COUNT_Hg2 = COUNT_Hg2 + 1 + ID_Hg2(COUNT_Hg2) = N + + CASE ( 'HG2_AN_EU', 'HG2_AE' ) + COUNT_Hg2 = COUNT_Hg2 + 1 + ID_Hg2(COUNT_Hg2) = N + + CASE ( 'HG2_AN_AS', 'HG2_AA' ) + COUNT_Hg2 = COUNT_Hg2 + 1 + ID_Hg2(COUNT_Hg2) = N + + CASE ( 'HG2_AN_RW', 'HG2_AR' ) + COUNT_Hg2 = COUNT_Hg2 + 1 + ID_Hg2(COUNT_Hg2) = N + + CASE ( 'HG2_OC' ) + COUNT_Hg2 = COUNT_Hg2 + 1 + ID_Hg2(COUNT_Hg2) = N + + CASE ( 'HG2_LN' ) + COUNT_Hg2 = COUNT_Hg2 + 1 + ID_Hg2(COUNT_Hg2) = N + + CASE ( 'HG2_NT' ) + COUNT_Hg2 = COUNT_Hg2 + 1 + ID_Hg2(COUNT_Hg2) = N + + CASE ( 'HGP_AN_NA', 'HGP_AN' ) + COUNT_HgP = COUNT_HgP + 1 + ID_HgP(COUNT_HgP) = N + + CASE ( 'HGP_AN_EU', 'HGP_AE' ) + COUNT_HgP = COUNT_HgP + 1 + ID_HgP(COUNT_HgP) = N + + CASE ( 'HGP_AN_AS', 'HGP_AA' ) + COUNT_HgP = COUNT_HgP + 1 + ID_HgP(COUNT_HgP) = N + + CASE ( 'HGP_AN_RW', 'HGP_AR' ) + COUNT_HgP = COUNT_HgP + 1 + ID_HgP(COUNT_HgP) = N + + CASE ( 'HGP_OC' ) + COUNT_HgP = COUNT_HgP + 1 + ID_HgP(COUNT_HgP) = N + + CASE ( 'HGP_LN' ) + COUNT_HgP = COUNT_HgP + 1 + ID_HgP(COUNT_HgP) = N + + CASE ( 'HGP_NT' ) + COUNT_HgP = COUNT_HgP + 1 + ID_HgP(COUNT_HgP) = N + + CASE DEFAULT + ! Nothing + + END SELECT + ENDDO + + !================================================================= + ! SPECIAL CASE: we need to hardwire the emission flags so that + ! they are in the same order as the old emissions code. The + ! order should be: 1 4 18 19 5 21 9 10 11 20 6. Think of a + ! better way to implement this later on. (bmy, 12/20/04) + ! Added HNO3 and Ox to deal with ship NOx emissions (3/4/08, phs) + !================================================================= + IF ( ITS_A_FULLCHEM_SIM() ) THEN +!----------------------------------------------------------------- +! Prior to 3/2/09 +! NEMANTHRO = 12 !phs - replaces 10 +! NEMBIOG = 1 +!----------------------------------------------------------------- + NEMANTHRO = 21 !phs - replaces 10 + NEMBIOG = 3 + IDENOX = 1 + IDECO = 2 + IDEPRPE = 3 + IDEC3H8 = 4 + IDEALK4 = 5 + IDEC2H6 = 6 + IDEACET = 7 + IDEMEK = 8 + IDEALD2 = 9 + IDECH2O = 10 + IDEOX = 11 !PHS + IDEHNO3 = 12 !PHS + IDEGLYX = 13 + IDEMGLY = 14 + IDEBENZ = 15 + IDETOLU = 16 + IDEXYLE = 17 + IDEC2H4 = 18 + IDEC2H2 = 19 + IDEGLYC = 20 + IDEHAC = 21 + IDEISOP = 22 + IDEMONX = 23 + IDEMBO = 24 + ENDIF + + !================================================================= + ! Fill IDEMS with appropriate tracer ID #'s + ! + ! NOTE: IDEMS is in "comode.h", maybe later split this off into + ! an F90 module somehow. Think about this later. (bmy, 11/12/02) + !================================================================= + IF ( IDENOX /= 0 ) IDEMS(IDENOX ) = IDTNOX + IF ( IDECO /= 0 ) IDEMS(IDECO ) = IDTCO + IF ( IDEPRPE /= 0 ) IDEMS(IDEPRPE) = IDTPRPE + IF ( IDEC3H8 /= 0 ) IDEMS(IDEC3H8) = IDTC3H8 + IF ( IDEALK4 /= 0 ) IDEMS(IDEALK4) = IDTALK4 + IF ( IDEC2H6 /= 0 ) IDEMS(IDEC2H6) = IDTC2H6 + IF ( IDEISOP /= 0 ) IDEMS(IDEISOP) = IDTISOP + IF ( IDEACET /= 0 ) IDEMS(IDEACET) = IDTACET + IF ( IDEMEK /= 0 ) IDEMS(IDEMEK ) = IDTMEK + IF ( IDEALD2 /= 0 ) IDEMS(IDEALD2) = IDTALD2 + IF ( IDECH2O /= 0 ) IDEMS(IDECH2O) = IDTCH2O + IF ( IDEOX /= 0 ) IDEMS(IDEOX ) = IDTOX ! PHS + IF ( IDEHNO3 /= 0 ) IDEMS(IDEHNO3) = IDTHNO3 ! PHS + IF ( IDEGLYX /= 0 ) IDEMS(IDEGLYX) = IDTGLYX + IF ( IDEMGLY /= 0 ) IDEMS(IDEMGLY) = IDTMGLY + IF ( IDEBENZ /= 0 ) IDEMS(IDEBENZ) = IDTBENZ + IF ( IDETOLU /= 0 ) IDEMS(IDETOLU) = IDTTOLU + IF ( IDEXYLE /= 0 ) IDEMS(IDEXYLE) = IDTXYLE + IF ( IDEMONX /= 0 ) IDEMS(IDEMONX) = IDTMONX + IF ( IDEC2H4 /= 0 ) IDEMS(IDEC2H4) = IDTC2H4 + IF ( IDEC2H2 /= 0 ) IDEMS(IDEC2H2) = IDTC2H2 + IF ( IDEMBO /= 0 ) IDEMS(IDEMBO ) = IDTMBO + IF ( IDEGLYC /= 0 ) IDEMS(IDEGLYC) = IDTGLYC + IF ( IDEHAC /= 0 ) IDEMS(IDEHAC ) = IDTHAC + + ! Echo anthro & biogenic emitted tracers + WRITE( 6, 100 ) IDEMS ( 1:NEMANTHRO+NEMBIOG ) + 100 FORMAT( /, 'TRACERID: Emitted tracers (anthro & bio) :', 20i3 ) + + ! Return to calling program + END SUBROUTINE TRACERID + +!------------------------------------------------------------------------------ + + SUBROUTINE SETTRACE +! +!****************************************************************************** +! Subroutine SETTRACE flags certain chemical species w/in the SMVGEAR full +! chemistry mechanism. (lwh, jyl, gmg, djj, 1990's; bmy, 11/12/02, 10/3/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NTRACER : Number of GEOS-CHEM tracers to process +! +! NOTES: +! (1 ) Added comment header. +! (2 ) Now initialize IDDMS, IDSO2, IDSO4, IDMSA. Updated comments, +! cosmetic changes. (rjp, bmy, 3/23/03) +! (3 ) Currently there are only families for the troposphere, so manually +! set NCS = NCSURBAN. Replace NAMESPEC w/ NAMEGAS for SMVGEAR II. +! (bdf, bmy, 4/23/03) +! (4 ) Make sure IDEMIS etc doesn't go out of array bounds (bmy, 4/26/04) +! (5 ) Removed NTRACER from the arg list, we can use N_TRACERS from +! "tracer_mod.f". Now references "tracer_mod.f". Now does not have +! to read the "tracer.dat" file. (bmy, 7/20/04) +! (6 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE TRACER_MOD, ONLY : ID_EMITTED, N_TRACERS + USE TRACER_MOD, ONLY : TRACER_COEFF, TRACER_CONST + USE TRACER_MOD, ONLY : TRACER_N_CONST, TRACER_NAME + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NAMEGAS + + ! Local variabales + INTEGER :: I, J, T, C + + !================================================================= + ! SETTRACE begins here! + !================================================================= + + ! Reset NCS = NCSURBAN, since we have defined our GEOS-CHEM + ! mechanism in the urban slot of SMVGEAR II (bmy, 4/21/03) + NCS = NCSURBAN + + DO I = 1, NSPEC(NCS) + IF ( NAMEGAS(I) == 'O3' ) IDO3 = I + IF ( NAMEGAS(I) == 'NO2' ) IDNO2 = I + IF ( NAMEGAS(I) == 'NO3' ) IDNO3 = I + IF ( NAMEGAS(I) == 'N2O5' ) IDN2O5 = I + IF ( NAMEGAS(I) == 'HNO4' ) IDHNO4 = I + IF ( NAMEGAS(I) == 'HNO2' ) IDHNO2 = I + IF ( NAMEGAS(I) == 'NO' ) IDNO = I + IF ( NAMEGAS(I) == 'CO' ) IDCO = I + IF ( NAMEGAS(I) == 'PRPE' ) IDPRPE = I + IF ( NAMEGAS(I) == 'C3H8' ) IDC3H8 = I + IF ( NAMEGAS(I) == 'ISOP' ) IDISOP = I + IF ( NAMEGAS(I) == 'ALK4' ) IDALK4 = I + IF ( NAMEGAS(I) == 'PAN' ) IDPAN = I + IF ( NAMEGAS(I) == 'GLPAN' ) IDGLPAN = I + IF ( NAMEGAS(I) == 'GPAN' ) IDGPAN = I + IF ( NAMEGAS(I) == 'PMN' ) IDPMN = I + IF ( NAMEGAS(I) == 'PPN' ) IDPPN = I + IF ( NAMEGAS(I) == 'HNO3' ) IDHNO3 = I + IF ( NAMEGAS(I) == 'OH' ) IDOH = I + IF ( NAMEGAS(I) == 'HO2' ) IDHO2 = I !(rvm, bmy, 2/27/02) + IF ( NAMEGAS(I) == 'H2O2' ) IDH2O2 = I + IF ( NAMEGAS(I) == 'ACET' ) IDACET = I + IF ( NAMEGAS(I) == 'MEK' ) IDMEK = I + IF ( NAMEGAS(I) == 'ALD2' ) IDALD2 = I + IF ( NAMEGAS(I) == 'RCHO' ) IDRCHO = I + IF ( NAMEGAS(I) == 'MVK' ) IDMVK = I + IF ( NAMEGAS(I) == 'MACR' ) IDMACR = I + IF ( NAMEGAS(I) == 'ISN2' ) IDISN2 = I + IF ( NAMEGAS(I) == 'R4N2' ) IDR4N2 = I + IF ( NAMEGAS(I) == 'CH2O' ) IDCH2O = I + IF ( NAMEGAS(I) == 'C2H6' ) IDC2H6 = I + IF ( NAMEGAS(I) == 'DMS' ) IDDMS = I !(rjp, bmy, 3/23/03) + IF ( NAMEGAS(I) == 'SO2' ) IDSO2 = I !(rjp, bmy, 3/23/03) + IF ( NAMEGAS(I) == 'SO4' ) IDSO4 = I !(rjp, bmy, 3/23/03) + IF ( NAMEGAS(I) == 'MSA' ) IDMSA = I !(rjp, bmy, 3/23/03) + IF ( NAMEGAS(I) == 'DRYNO2' ) IDDRYNO2 = I + IF ( NAMEGAS(I) == 'DRYPAN' ) IDDRYPAN = I + IF ( NAMEGAS(I) == 'DRYO3 ' ) IDDRYO3 = I + IF ( NAMEGAS(I) == 'BENZ' ) IDBENZ = I + IF ( NAMEGAS(I) == 'TOLU' ) IDTOLU = I + IF ( NAMEGAS(I) == 'XYLE' ) IDXYLE = I + IF ( NAMEGAS(I) == 'MONX' ) IDMONX = I + IF ( NAMEGAS(I) == 'GLYX' ) IDGLYX = I + IF ( NAMEGAS(I) == 'MGLY' ) IDMGLY = I + IF ( NAMEGAS(I) == 'DRYGLYX') IDDRYGLYX = I + IF ( NAMEGAS(I) == 'DRYMGLY') IDDRYMGLY = I + IF ( NAMEGAS(I) == 'C2H4' ) IDC2H4 = I + IF ( NAMEGAS(I) == 'C2H2' ) IDC2H2 = I + IF ( NAMEGAS(I) == 'MBO' ) IDMBO = I + IF ( NAMEGAS(I) == 'GLYC' ) IDGLYC = I + IF ( NAMEGAS(I) == 'HAC' ) IDHAC = I + IF ( NAMEGAS(I) == 'APAN' ) IDAPAN = I + IF ( NAMEGAS(I) == 'ENPAN' ) IDENPAN = I + IF ( NAMEGAS(I) == 'MPAN' ) IDMPAN = I + IF ( NAMEGAS(I) == 'NIPAN' ) IDNIPAN = I + + IF ( NAMEGAS(I) == 'DRYAPAN' ) IDDRYAPAN = I + IF ( NAMEGAS(I) == 'DRYENPAN') IDDRYENPAN = I + IF ( NAMEGAS(I) == 'DRYGLPAN') IDDRYGLPAN = I + IF ( NAMEGAS(I) == 'DRYGPAN' ) IDDRYGPAN = I + IF ( NAMEGAS(I) == 'DRYMPAN' ) IDDRYMPAN = I + IF ( NAMEGAS(I) == 'DRYNIPAN') IDDRYNIPAN = I + ENDDO + + !================================================================= + ! Initialize arrays + !================================================================= + DO I=1, NNNTRID + NMEMBER(I) = 0 + IDEMIS(I) = 0 + DO J=1, MMMEMBER + IDTRMB(I, J)= 0 + CTRMB(I, J)= 0. + ENDDO + ENDDO + + !================================================================= + ! Save IDs for tracers (sequence in NAMESPEC.) + ! + ! IDTRMB(T,C) = species number for J'th component of tracer I + ! CTRMB(T,C)+1 = coefficient of tracer constituent (e.g., each NO3 + ! molec. represents 2 units of Ox, so CTRMB=1) + ! TRACER_N(T) = number of component species in tracer I + ! IDEMIS(T) = which component of tracer I (in IDTRMB sense) + ! receives the emissions + ! NIDEMIS = 0,1 -- indicates which species is emitting species. + ! If there is only one species in tracer family and + ! it's emitted, you still need a "1" in the spot. + ! ljm changes: now read input from data file, tracer.dat + !================================================================= + + ! Loop over tracers + DO T = 1, N_TRACERS + + ! Number of constituents that tracer T has + NMEMBER(T) = TRACER_N_CONST(T) + + ! Index of which tracer constituent + ! will receive the emissions + IF ( ID_EMITTED(T) > 0 ) THEN + IDEMIS(T) = ID_EMITTED(T) + ENDIF + + ! Loop over all the species which make up the tracer + DO C = 1, NMEMBER(T) + + ! Store tracer coefficient in CTRMB + CTRMB(T,C) = TRACER_COEFF(T,C) - 1 + + ! Loop over all species in "globchem.dat" + DO J = 1, NSPEC(NCS) + + ! Special case: hydrocarbon tracers as atoms C + IF ( TRACER_CONST(T,C) == 'C' ) THEN + + ! Test SMVGEAR species name against TRACER_NAME + IF ( NAMEGAS(J) == TRACER_NAME(T) ) THEN + IDTRMB(T,C) = J + ENDIF + + ELSE + + ! Test SMVGEAR species name TRACER_CONST + IF ( NAMEGAS(J) == TRACER_CONST(T,C) ) THEN + IDTRMB(T,C) = J + ENDIF + + ENDIF + ENDDO + + !### Debug + !PRINT*, '###--------------------' + !PRINT*, '### T, C : ', T, C + !PRINT*, '### NAME : ', TRACER_NAME(T) + !PRINT*, '### NMEMBER : ', NMEMBER(T) + !PRINT*, '### CONST(T,C) : ', TRACER_CONST(T,C) + !PRINT*, '### CTRMB(T,C) : ', CTRMB(T,C) + !PRINT*, '### IDEMIS(T) : ', IDEMIS(T) + !PRINT*, '### IDTRMB(T,C): ', IDTRMB(T,C) + + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE SETTRACE + +!------------------------------------------------------------------------------ + + FUNCTION IS_Hg0( N ) RESULT( IT_IS_Hg0 ) +! +!****************************************************************************** +! Function IS_Hg0 returns TRUE if tracer N is a total or tagged Hg0 tracer. +! (cdh, bmy, 12/15/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) N (INTEGER) : GEOS-CHEM tracer number +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: N + + ! Local variables + LOGICAL :: IT_IS_Hg0 + INTEGER :: C + + !================================================================= + ! IS_Hg0 begins here! + !================================================================= + + ! Initialize + IT_IS_Hg0 = .FALSE. + + ! Loop over Hg0 categories + DO C = 1, N_Hg_CATS + + ! Exit with TRUE if corresponds to an Hg0 tracer + IF ( N == ID_Hg0(C) ) THEN + IT_IS_Hg0 = .TRUE. + EXIT + ENDIF + + ENDDO + + ! Return to calling program + END FUNCTION IS_Hg0 + +!------------------------------------------------------------------------------ + + FUNCTION IS_Hg2( N ) RESULT( IT_IS_Hg2 ) +! +!****************************************************************************** +! Function IS_Hg2 returns TRUE if tracer N is a total or tagged Hg2 tracer. +! (cdh, bmy, 12/15/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) N (INTEGER) : GEOS-CHEM tracer number +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: N + + ! Local variables + LOGICAL :: IT_IS_Hg2 + INTEGER :: C + + !================================================================= + ! IS_Hg2 begins here! + !================================================================= + + ! Initialize + IT_IS_Hg2 = .FALSE. + + ! Loop over Hg2 categories + DO C = 1, N_Hg_CATS + + ! Exit with TRUE if corresponds to an Hg2 tracer + IF ( N == ID_Hg2(C) ) THEN + IT_IS_Hg2 = .TRUE. + EXIT + ENDIF + + ENDDO + + ! Return to calling program + END FUNCTION IS_Hg2 + +!------------------------------------------------------------------------------ + + FUNCTION IS_HgP( N ) RESULT( IT_IS_HgP ) +! +!****************************************************************************** +! Function IS_HgP returns TRUE if tracer N is a total or tagged HgP tracer. +! (cdh, bmy, 12/15/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) N (INTEGER) : GEOS-CHEM tracer number +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: N + + ! Local variables + LOGICAL :: IT_IS_HgP + INTEGER :: C + + !================================================================= + ! IS_HgP begins here! + !================================================================= + + ! Initialize + IT_IS_HgP = .FALSE. + + ! Loop over Hg2 categories + DO C = 1, N_Hg_CATS + + ! Exit with TRUE if corresponds to an HgP tracer + IF ( N == ID_HgP(C) ) THEN + IT_IS_HgP = .TRUE. + EXIT + ENDIF + + ENDDO + + ! Return to calling program + END FUNCTION IS_HgP + +!------------------------------------------------------------------------------ + + FUNCTION GET_Hg0_CAT( N ) RESULT( NN ) +! +!****************************************************************************** +! Function GET_Hg0_CAT the Hg0 category number given the tracer number. +! (eck, sas, cdh, bmy, 1/6/05) +! +! Arguments as Input: +! ---------------------------------------------------------------------------- +! (1 ) N (INTEGER) : GEOS-CHEM tracer number +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: N + + ! Function value + INTEGER :: NN + + !================================================================= + ! GET_Hg2_CAT begins here! + !================================================================= + + ! Pick the Hg2 category number from the tracer number + IF ( N == ID_Hg0(ID_Hg_tot) ) THEN + + ! Total + NN = ID_Hg_tot + + ELSE IF ( N == ID_Hg0(ID_Hg_na) ) THEN + + ! Anthro North America + NN = ID_Hg_na + + ELSE IF ( N == ID_Hg0(ID_Hg_eu) ) THEN + + ! Anthro Europe + NN = ID_Hg_eu + + ELSE IF ( N == ID_Hg0(ID_Hg_as) ) THEN + + ! Anthro Asia + NN = ID_Hg_as + + ELSE IF ( N == ID_Hg0(ID_Hg_rw) ) THEN + + ! Anthro Rest of World + NN = ID_Hg_rw + + ELSE IF ( N == ID_Hg0(ID_Hg_oc) ) THEN + + ! Oceans + NN = ID_Hg_oc + + ELSE IF ( N == ID_Hg0(ID_Hg_ln) ) THEN + + ! Land re-emission + NN = ID_Hg_ln + + ELSE IF ( N == ID_Hg0(ID_Hg_nt) ) THEN + + ! Natural source + NN = ID_Hg_nt + + ELSE + + ! Invalid category + NN = -1 + + ENDIF + + ! Return to calling program + END FUNCTION GET_Hg0_CAT + +!------------------------------------------------------------------------------ + + FUNCTION GET_Hg2_CAT( N ) RESULT( NN ) +! +!****************************************************************************** +! Function GET_Hg2_CAT the Hg2 category number (i.e. index for DD_Hg2 and +! WD_Hg2) given the tracer number. (eck, sas, cdh, bmy, 1/6/05) +! +! Arguments as Input: +! ---------------------------------------------------------------------------- +! (1 ) N (INTEGER) : GEOS-CHEM tracer number +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: N + + ! Function value + INTEGER :: NN + + !================================================================= + ! GET_Hg2_CAT begins here! + !================================================================= + + ! Pick the Hg2 category number from the tracer number + IF ( N == ID_Hg2(ID_Hg_tot) ) THEN + + ! Total + NN = ID_Hg_tot + + ELSE IF ( N == ID_Hg2(ID_Hg_na) ) THEN + + ! Anthro North America + NN = ID_Hg_na + + ELSE IF ( N == ID_Hg2(ID_Hg_eu) ) THEN + + ! Anthro Europe + NN = ID_Hg_eu + + ELSE IF ( N == ID_Hg2(ID_Hg_as) ) THEN + + ! Anthro Asia + NN = ID_Hg_as + + ELSE IF ( N == ID_Hg2(ID_Hg_rw) ) THEN + + ! Anthro Rest of World + NN = ID_Hg_rw + + ELSE IF ( N == ID_Hg2(ID_Hg_oc) ) THEN + + ! Oceans + NN = ID_Hg_oc + + ELSE IF ( N == ID_Hg2(ID_Hg_ln) ) THEN + + ! Land re-emission + NN = ID_Hg_ln + + ELSE IF ( N == ID_Hg2(ID_Hg_nt) ) THEN + + ! Natural source + NN = ID_Hg_nt + + ELSE + + ! Invalid category + NN = -1 + + ENDIF + + ! Return to calling program + END FUNCTION GET_Hg2_CAT + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_TRACERID +! +!****************************************************************************** +! Subroutine INIT_TRACERID zeroes module variables. (bmy, 11/12/02, 9/18/07) +! +! NOTES: +! (1 ) Now also zero IDDMS, IDSO2, IDSO4, IDMSA (rjp, bmy, 3/23/03) +! (2 ) Now zero extra flags for carbon & dust tracers (rjp, tdf, bmy, 4/1/04) +! (3 ) Now zero extra flags for seasalt tracers (rjp, bec, bmy, 4/1/04) +! (4 ) Now zero extra flags for SOA tracers (rjp, bmy, 7/13/04) +! (5 ) Now zero IDTHG0, IDTHG2, IDTHGP + tagged Hg's (eck, bmy, 12/7/04) +! (6 ) Now zero IDTAS, IDTAHS, IDTLET, IDTNH4aq, IDTSO4aq (cas, bmy, 12/20/04) +! (7 ) Now allocate ID_Hg0, ID_Hg2, ID_HgP (bmy, 12/16/05) +! (8 ) Now zero IDTSOG4, IDTSOA4 (dkh, bmy, 5/18/06) +! (9 ) Now zero IDTH2, IDTHD (hup, lyj, phs, 9/18/07) +! (10) Now zero IDEHNO3 (PHS, 3/4/08) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE LOGICAL_MOD, ONLY : LSPLIT + USE TRACER_MOD, ONLY : ITS_A_MERCURY_SIM + + ! Local variables + INTEGER :: AS + + ! SMVGEAR species ID #'s + IDO3 = 0 + IDNO2 = 0 + IDNO3 = 0 + IDN2O5 = 0 + IDHNO4 = 0 + IDOX = 0 + IDNOX = 0 + IDHC1 = 0 + IDNO = 0 + IDHNO2 = 0 + IDCO = 0 + IDPRPE = 0 + IDISOP = 0 + IDALK4 = 0 + IDC3H8 = 0 + IDPAN = 0 + IDGLPAN = 0 + IDGPAN = 0 + IDPMN = 0 + IDPPN = 0 + IDHNO3 = 0 + IDOH = 0 + IDHO2 = 0 + IDH2O2 = 0 + IDACET = 0 + IDMEK = 0 + IDALD2 = 0 + IDRCHO = 0 + IDMVK = 0 + IDMACR = 0 + IDISN2 = 0 + IDR4N2 = 0 + IDCH2O = 0 + IDC2H6 = 0 + IDMP = 0 + IDDMS = 0 + IDSO2 = 0 + IDSO4 = 0 + IDMSA = 0 + IDDRYO3 = 0 + IDDRYPAN = 0 + IDDRYNO2 = 0 + IDBENZ = 0 + IDTOLU = 0 + IDXYLE = 0 + IDMONX = 0 + IDGLYX = 0 + IDMGLY = 0 + IDDRYGLYX = 0 + IDDRYMGLY = 0 + IDC2H4 = 0 + IDC2H2 = 0 + IDMBO = 0 + IDGLYC = 0 + IDHAC = 0 + + IDAPAN = 0 + IDENPAN = 0 + IDMPAN = 0 + IDNIPAN = 0 + + IDDRYAPAN = 0 + IDDRYENPAN = 0 + IDDRYGLPAN = 0 + IDDRYGPAN = 0 + IDDRYMPAN = 0 + IDDRYNIPAN = 0 + + ! GEOS-CHEM Tracer ID #'s + IDTNOX = 0 + IDTOX = 0 + IDTPAN = 0 + IDTCO = 0 + IDTH2 = 0 ! (hup, 7/14/2004) + IDTHD = 0 ! (jaegle, 11/07/2005) + IDTALK4 = 0 + IDTISOP = 0 + IDTHNO3 = 0 + IDTH2O2 = 0 + IDTACET = 0 + IDTMEK = 0 + IDTALD2 = 0 + IDTRCHO = 0 + IDTMVK = 0 + IDTMACR = 0 + IDTPMN = 0 + IDTPPN = 0 + IDTISN2 = 0 + IDTR4N2 = 0 + IDTPRPE = 0 + IDTC3H8 = 0 + IDTCH2O = 0 + IDTC2H6 = 0 + IDTN2O5 = 0 + IDTHNO4 = 0 + IDTMP = 0 + IDTDMS = 0 + IDTSO2 = 0 + IDTSO4 = 0 + IDTMSA = 0 + IDTNH3 = 0 + IDTNH4 = 0 + IDTNIT = 0 + IDTAS = 0 + IDTAHS = 0 + IDTNH4aq = 0 + IDTLET = 0 + IDTSO4aq = 0 + IDTBCPI = 0 + IDTOCPI = 0 + IDTBCPO = 0 + IDTOCPO = 0 + IDTALPH = 0 + IDTLIMO = 0 + IDTALCO = 0 + IDTSOG1 = 0 + IDTSOG2 = 0 + IDTSOG3 = 0 + IDTSOG4 = 0 + IDTSOA1 = 0 + IDTSOA2 = 0 + IDTSOA3 = 0 + IDTSOA4 = 0 + IDTDST1 = 0 + IDTDST2 = 0 + IDTDST3 = 0 + IDTDST4 = 0 + IDTSALA = 0 + IDTSALC = 0 + IDTRN = 0 + IDTPB = 0 + IDTBE7 = 0 + IDTGLYX = 0 + IDTMGLY = 0 + IDTBENZ = 0 + IDTTOLU = 0 + IDTXYLE = 0 + IDTMONX = 0 + IDTSOAG = 0 + IDTSOAM = 0 + IDTC2H4 = 0 + IDTC2H2 = 0 + IDTMBO = 0 + IDTGLYC = 0 + IDTHAC = 0 + IDTAPAN = 0 + IDTENPAN = 0 + IDTGLPAN = 0 + IDTGPAN = 0 + IDTMPAN = 0 + IDTNIPAN = 0 +!added for NEI08 compatibility + IDTCH4 = 0 + IDTNO = 0 + IDTNO2 = 0 + IDTHNO2 = 0 + IDTEOH = 0 + IDTMOH = 0 + + ! GEOS-CHEM Emission ID #'s + NEMANTHRO = 0 + NEMBIOG = 0 + IDENOX = 0 + IDEOX = 0 + IDECO = 0 + IDEPRPE = 0 + IDEC3H8 = 0 + IDEALK4 = 0 + IDEC2H6 = 0 + IDEACET = 0 + IDEMEK = 0 + IDEALD2 = 0 + IDEISOP = 0 + IDECH2O = 0 + IDEHNO3 = 0 !phs (3/4/08) + IDEGLYX = 0 + IDEMGLY = 0 + IDEBENZ = 0 + IDETOLU = 0 + IDEXYLE = 0 + IDEMONX = 0 + IDEC2H4 = 0 + IDEC2H2 = 0 + IDEMBO = 0 + IDEGLYC = 0 + IDEHAC = 0 + + ! GEOS-CHEM Biofuel ID #'s + IDBFNOX = 0 + IDBFCO = 0 + IDBFALK4 = 0 + IDBFACET = 0 + IDBFMEK = 0 + IDBFALD2 = 0 + IDBFPRPE = 0 + IDBFC3H8 = 0 + IDBFCH2O = 0 + IDBFC2H6 = 0 + IDBFBENZ = 0 + IDBFTOLU = 0 + IDBFXYLE = 0 + IDBFC2H2 = 0 + IDBFC2H4 = 0 + IDBFGLYC = 0 + IDBFGLYX = 0 + IDBFMGLY = 0 + IDBFHAC = 0 + + !----------------------------------- + ! Initialize tagged Hg index arrays + !----------------------------------- + IF ( ITS_A_MERCURY_SIM() ) THEN + + ! Initialize category flags + ID_Hg_tot = 0 + ID_Hg_na = 0 + ID_Hg_eu = 0 + ID_Hg_as = 0 + ID_Hg_rw = 0 + ID_Hg_oc = 0 + ID_Hg_ln = 0 + ID_Hg_nt = 0 + + ! Number of Hg categories + IF ( LSPLIT ) THEN + N_Hg_CATS = 8 + ELSE + N_Hg_CATS = 1 + ENDIF + + ! Index array for Hg0 tracers + ALLOCATE( ID_Hg0( N_Hg_CATS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_Hg0' ) + ID_Hg0 = 0 + + ! Index array for Hg2 tracers + ALLOCATE( ID_Hg2( N_Hg_CATS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_Hg2' ) + ID_Hg2 = 0 + + ! Index array for HgP tracers + ALLOCATE( ID_HgP( N_Hg_CATS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ID_HgP' ) + ID_HgP = 0 + + ENDIF + + ! Return to calling program + END SUBROUTINE INIT_TRACERID + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_TRACERID +! +!****************************************************************************** +! Subroutine CLEANUP_TRACERID deallocates all module arrays (bmy, 12/16/05) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_TRACERID begins here! + !================================================================= + IF ( ALLOCATED( ID_Hg0 ) ) DEALLOCATE( ID_Hg0 ) + IF ( ALLOCATED( ID_Hg2 ) ) DEALLOCATE( ID_Hg2 ) + IF ( ALLOCATED( ID_HgP ) ) DEALLOCATE( ID_HgP ) + + ! Return to calling program + END SUBROUTINE CLEANUP_TRACERID + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE TRACERID_MOD diff --git a/code/transfer_mod.f b/code/transfer_mod.f new file mode 100644 index 0000000..9080b01 --- /dev/null +++ b/code/transfer_mod.f @@ -0,0 +1,1674 @@ +! $Id: transfer_mod.f,v 1.1 2009/06/09 21:51:51 daven Exp $ + MODULE TRANSFER_MOD +! +!****************************************************************************** +! Module TRANSFER_MOD contains routines used to copy data from REAL*4 to +! REAL*8 arrays after being read from disk. Also, vertical levels will be +! collapsed in the stratosphere if necessary. This will help us to gain +! computational advantage. (mje, bmy, 9/27/01, 10/3/07) +! +! NOTE: The level above which we start collapsing layers is ~78 hPa. +! +! Module Variables: +! ============================================================================ +! (1 ) EDGE_IN : Input sigma edges (for pure sigma models) +! (2 ) I0 : Global longitude offset (%%% NOTE: usually=0 %%%) +! (3 ) J0 : Global latitude offset (%%% NOTE: usually=0 %%%) +! (4 ) L_COPY : # of levels to copy (before stratosphere lumping) +! +! Module Routines: +! ============================================================================ +! (1 ) TRANSFER_A6 : Transfers GEOS A-6 fields, regrids if necessary +! (2 ) TRANSFER_3D : Transfers GEOS 3-D fields, regrids if necessary +! (3 ) TRANSFER_3D_TROP : Transfers GEOS 3-D fields up to tropopause level +! (4 ) TRANSFER_G5_PLE : Transfers GEOS-5 3-D pressure edges, regrids +! (5 ) TRANSFER_3D_Lp1 : Transfers GEOS-5 3-D fields defined on level edges +! (6 ) TRANSFER_ZONAL_R4 : Transfers GEOS zonal fields, regrids (REAL*4) +! (7 ) TRANSFER_ZONAL_R8 : Transfers GEOS zonal fields, regrids (REAL*8) +! (8 ) TRANSFER_ZONAL : Transfers GEOS zonal fields, regrids if necessary +! (9 ) TRANSFER_2D_INT : Transfers GEOS 2-D fields (INTEGER argument) +! (10) TRANSFER_2D_R4 : Transfers GEOS 2-D fields (REAL*4 argument) +! (11) TRANSFER_2D_R8 : Transfers GEOS 2-D fields (REAL*8 argument) +! (12) TRANSFER_TO_1D : Transfers GEOS 2-D fields to a 1-D array +! (13) LUMP_2_R4 : Combines 2 levels into 1 thick level (REAL*4) +! (14) LUMP_2_R8 : Combines 2 levels into 1 thick level (REAL*8) +! (15) LUMP_4_R4 : Combines 4 levels into 1 thick level (REAL*4) +! (16) LUMP_4_R8 : Combines 4 levels into 1 thick level (REAL*8) +! (17) INIT_TRANSFER : Allocates and initializes the EDGE_IN array +! (18) CLEANUP_TRANSFER : Deallocates the EDGE_IN array +! +! Module Interfaces: +! ============================================================================ +! (1 ) LUMP_2 : Overloads LUMP_2_* module routines +! (2 ) LUMP_4 : Overloads LUMP_4_* module routines +! (3 ) TRANSFER_2D : Overloads TRANSFER_2D_* module routines +! (4 ) TRANSFER_ZONAL : Overloads TRANSFER_ZONAL_* module routines +! +! GEOS-Chem modules referenced by "transfer_mod.f" +! ============================================================================ +! (1 ) error_mod.f : Module w/ NaN and other error check routines +! +! NOTES: +! (1 ) GEOS-3 Output levels were determined by Mat Evans. Groups of 2 levels +! and groups of 4 levels on the original grid are merged together into +! thick levels for the output grid. (mje, bmy, 9/26/01) +! (2 ) Assumes that LLPAR == LGLOB for GEOS-1, GEOS-STRAT (bmy, 9/26/01) +! (3 ) EDGE_IN needs to be provided for each model type, within an #ifdef +! block, in order to ensure compilation. However, EDGE_IN is currently +! only used for regridding GEOS-3 data (and probably also GEOS-4 when +! that becomes available). (bmy, 9/26/01) +! (4 ) Add interfaces TRANSFER_2D and TRANSFER_ZONAL (bmy, 9/27/01) +! (5 ) Added routine TRANSFER_2D_R4. Added TRANSFER_2D_R4 to the generic +! TRANSFER_2D interface. (bmy, 1/25/02) +! (6 ) Updated comments, cosmetic changes (bmy, 2/28/02) +! (7 ) Bug fix: remove extraneous "," in GEOS-1 definition of EDGE_IN array. +! (bmy, 3/25/02) +! (8 ) Now divide module header into MODULE PRIVATE, MODULE VARIABLES, and +! MODULE ROUTINES sections. Also add MODULE INTERFACES section, +! since we have an interface here. (bmy, 5/28/02) +! (9 ) Now references "pressure_mod.f" (dsa, bdf, bmy, 8/22/02) +! (10) Bug fix in "init_transfer", declare variable L. Also reference +! GEOS_CHEM_STOP from "error_mod.f" for safe stop (bmy, 10/15/02) +! (11) Added routine TRANSFER_3D_TROP. Also updated comments. (bmy, 10/31/02) +! (12) Now uses functions GET_XOFFSET and GET_YOFFSET from "grid_mod.f". +! (bmy, 3/11/03) +! (13) Added code to regrid GEOS-4 from 55 --> 30 levels. Renamed module +! variable SIGE_IN to EDGE_IN. (mje, bmy, 10/31/03) +! (14) Now modified for GEOS-5 and GCAP met fields (swu, bmy, 5/24/05) +! (15) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +! (16) Modified for GEOS-5. Rewritten for clarity. (bmy, 10/30/07) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "transfer_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: TRANSFER_A6 + PUBLIC :: TRANSFER_2D + PUBLIC :: TRANSFER_3D + PUBLIC :: TRANSFER_3D_Lp1 + PUBLIC :: TRANSFER_3D_TROP + PUBLIC :: TRANSFER_G5_PLE + PUBLIC :: TRANSFER_ZONAL + PUBLIC :: TRANSFER_TO_1D + PUBLIC :: INIT_TRANSFER + PUBLIC :: CLEANUP_TRANSFER + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Scalars + INTEGER :: I0 + INTEGER :: J0 + INTEGER :: L_COPY + + ! Arrays + REAL*8, ALLOCATABLE :: EDGE_IN(:) + + !================================================================= + ! MODULE INTERFACES -- "bind" two or more routines with different + ! argument types or # of arguments under one unique name + !================================================================= + + ! Interface for routines to lump 2 levels together + INTERFACE LUMP_2 + MODULE PROCEDURE LUMP_2_R4 + MODULE PROCEDURE LUMP_2_R8 + END INTERFACE + + ! Interface for routines to lump 4 levels together + INTERFACE LUMP_4 + MODULE PROCEDURE LUMP_4_R4 + MODULE PROCEDURE LUMP_4_R8 + END INTERFACE + + ! Interface for routines which copy 2-D data + INTERFACE TRANSFER_2D + MODULE PROCEDURE TRANSFER_2D_INT + MODULE PROCEDURE TRANSFER_2D_R4 + MODULE PROCEDURE TRANSFER_2D_R8 + END INTERFACE + + ! Interface for routines which copy zonal data + INTERFACE TRANSFER_ZONAL + MODULE PROCEDURE TRANSFER_ZONAL_R4 + MODULE PROCEDURE TRANSFER_ZONAL_R8 + END INTERFACE + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_A6( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_A6 transfers A-6 data from a REAL*4 array to a REAL*8 +! array. Vertical layers are collapsed (from LGLOB to LLPAR) if necessary. +! (mje, bmy, 9/21/01, 11/6/08) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4) : Input field, dimensioned (IGLOB,JGLOB,LGLOB) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (REAL*4) : Output field, dimensioned (LLPAR,IIPAR,JJPAR) +! +! NOTES: +! (1 ) A-6 fields are dimensioned (LLPAR,IIPAR,JJPAR) since for Fortran +! efficiency, since the code loops over vertical layers L in a column +! located above a certain surface location (I,J). (bmy, 9/21/01) +! (2 ) Assumes that LLPAR == LGLOB for GEOS-1, GEOS-STRAT (bmy, 9/21/01) +! (3 ) Now use functions GET_XOFFSET and GET_YOFFSET from "grid_mod.f". +! Now I0, J0 are local variables. (bmy, 3/11/03) +! (4 ) Added code to regrid GEOS-4 from 55 --> 30 levels (mje, bmy, 10/31/03) +! (5 ) Now modified for GEOS-5 met fields (bmy, 5/24/05) +! (6 ) Rewritten for clarity (bmy, 2/8/07) +! (7 ) Now get nested-grid offsets (dan, bmy, 11/6/08) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*4, INTENT(IN) :: IN(IGLOB,JGLOB,LGLOB) + REAL*8, INTENT(OUT) :: OUT(LLPAR,IIPAR,JJPAR) + + ! Local variables + INTEGER :: I, J, L + REAL*4 :: INCOL(LGLOB) + + !================================================================ + ! TRANSFER_A6 begins here! + !================================================================ + + ! Copy the first L_COPY levels +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO J = 1, JJPAR + DO I = 1, IIPAR + DO L = 1, L_COPY + OUT(L,I,J) = IN(I+I0,J+J0,L) + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Exit if we are running at full vertical resolution + IF ( LLPAR == LGLOB ) RETURN + + !================================================================= + ! Collapse levels in the stratosphere + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, INCOL ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Store vertical column at (IREF,JREF) in a 1-D vector + INCOL = IN( I+I0, J+J0, 1:LGLOB ) + +#if defined( GEOS_3 ) + + !-------------------------------------------------------------- + ! GEOS-3: Lump 48 levels into 30 levels, starting above L=22. + ! Lump levels in groups of 2, then 4. (cf. Mat Evans) + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time, starting at L=23 + OUT(23,I,J) = LUMP_2( INCOL, LGLOB, 23 ) + OUT(24,I,J) = LUMP_2( INCOL, LGLOB, 25 ) + OUT(25,I,J) = LUMP_2( INCOL, LGLOB, 27 ) + + ! Lump 4 levels together at a time, starting at L=29 + OUT(26,I,J) = LUMP_4( INCOL, LGLOB, 29 ) + OUT(27,I,J) = LUMP_4( INCOL, LGLOB, 33 ) + OUT(28,I,J) = LUMP_4( INCOL, LGLOB, 37 ) + OUT(29,I,J) = LUMP_4( INCOL, LGLOB, 41 ) + OUT(30,I,J) = LUMP_4( INCOL, LGLOB, 45 ) + +#elif defined( GEOS_4 ) + + !-------------------------------------------------------------- + ! GEOS-4: Lump 55 levels into 30 levels, starting above L=20 + ! Lump levels in groups of 2, then 4. (cf. Mat Evans) + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time + OUT(20,I,J) = LUMP_2( INCOL, LGLOB, 20 ) + OUT(21,I,J) = LUMP_2( INCOL, LGLOB, 22 ) + OUT(22,I,J) = LUMP_2( INCOL, LGLOB, 24 ) + OUT(23,I,J) = LUMP_2( INCOL, LGLOB, 26 ) + + ! Lump 4 levels together at a time + OUT(24,I,J) = LUMP_4( INCOL, LGLOB, 28 ) + OUT(25,I,J) = LUMP_4( INCOL, LGLOB, 32 ) + OUT(26,I,J) = LUMP_4( INCOL, LGLOB, 36 ) + OUT(27,I,J) = LUMP_4( INCOL, LGLOB, 40 ) + OUT(28,I,J) = LUMP_4( INCOL, LGLOB, 44 ) + OUT(29,I,J) = LUMP_4( INCOL, LGLOB, 48 ) + OUT(30,I,J) = LUMP_4( INCOL, LGLOB, 52 ) + +#elif defined( GEOS_5 ) || defined( GEOS_FP ) + + !-------------------------------------------------------------- + ! GEOS-5: Lump 72 levels into 47 levels, starting above L=36 + ! Lump levels in groups of 2, then 4. (cf. Bob Yantosca) + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time + OUT(37,I,J) = LUMP_2( INCOL, LGLOB, 37 ) + OUT(38,I,J) = LUMP_2( INCOL, LGLOB, 39 ) + OUT(39,I,J) = LUMP_2( INCOL, LGLOB, 41 ) + OUT(40,I,J) = LUMP_2( INCOL, LGLOB, 43 ) + + ! Lump 4 levels together at a time + OUT(41,I,J) = LUMP_4( INCOL, LGLOB, 45 ) + OUT(42,I,J) = LUMP_4( INCOL, LGLOB, 49 ) + OUT(43,I,J) = LUMP_4( INCOL, LGLOB, 53 ) + OUT(44,I,J) = LUMP_4( INCOL, LGLOB, 57 ) + OUT(45,I,J) = LUMP_4( INCOL, LGLOB, 61 ) + OUT(46,I,J) = LUMP_4( INCOL, LGLOB, 65 ) + OUT(47,I,J) = LUMP_4( INCOL, LGLOB, 69 ) + +#endif + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE TRANSFER_A6 + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_3D( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_3D transfers A-6 data from a REAL*4 array to a REAL*8 +! array. Vertical layers are collapsed (from LGLOB to LLPAR) if necessary. +! (mje, bmy, 9/21/01, 2/8/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4) : Input field, of dimension (IGLOB,JGLOB,LGLOB) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (REAL*8) : Output field, of dimension (IIPAR,JJPAR,LLPAR) +! +! NOTES: +! (1 ) Lump levels together in groups of 2 or 4, as dictated by Mat Evans. +! (bmy, 9/21/01) +! (2 ) Assumes that LLPAR == LGLOB for GEOS-1, GEOS-STRAT (bmy, 9/21/01) +! (3 ) Now use functions GET_XOFFSET and GET_YOFFSET from "grid_mod.f". +! Now I0, J0 are local variables. (bmy, 3/11/03) +! (4 ) Added code to regrid GEOS-4 from 55 --> 30 levels (mje, bmy, 10/31/03) +! (5 ) Now modified for GEOS-5 met fields (bmy, 5/24/05) +! (6 ) Rewritten for clarity (bmy, 2/8/07) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*4, INTENT(IN) :: IN(IIPAR,JJPAR,LGLOB) + REAL*8, INTENT(OUT) :: OUT(IIPAR,JJPAR,LLPAR) + + ! Local variables + INTEGER :: I, J + REAL*4 :: INCOL(LGLOB) + + !================================================================ + ! TRANSFER_3D begins here! + !================================================================ + + ! Copy the first L_COPY levels + OUT(:,:,1:L_COPY) = IN( 1+I0:IIPAR+I0, 1+J0:JJPAR+J0, 1:L_COPY ) + + ! Exit if we are running at full vertical resolution + IF ( LLPAR == LGLOB ) RETURN + + !================================================================ + ! Collapse levels in the stratosphere + !================================================================ + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, INCOL ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Copy a vertical column into INCOL + INCOL = IN( I+I0, J+J0, 1:LGLOB ) + +#if defined( GEOS_3 ) + + !-------------------------------------------------------------- + ! GEOS-3: Lump 48 levels into 30 levels, starting above L=22. + ! Lump levels in groups of 2, then 4. (cf. Mat Evans) + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time, starting at L=23 + OUT(I,J,23) = LUMP_2( INCOL, LGLOB, 23 ) + OUT(I,J,24) = LUMP_2( INCOL, LGLOB, 25 ) + OUT(I,J,25) = LUMP_2( INCOL, LGLOB, 27 ) + + ! Lump 4 levels together at a time, starting at L=29 + OUT(I,J,26) = LUMP_4( INCOL, LGLOB, 29 ) + OUT(I,J,27) = LUMP_4( INCOL, LGLOB, 33 ) + OUT(I,J,28) = LUMP_4( INCOL, LGLOB, 37 ) + OUT(I,J,29) = LUMP_4( INCOL, LGLOB, 41 ) + OUT(I,J,30) = LUMP_4( INCOL, LGLOB, 45 ) + +#elif defined( GEOS_4 ) + + !-------------------------------------------------------------- + ! GEOS-4: Lump 55 levels into 30 levels, starting above L=20 + ! Lump levels in groups of 2, then 4. (cf. Mat Evans) + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time, starting at L=20 + OUT(I,J,20) = LUMP_2( INCOL, LGLOB, 20 ) + OUT(I,J,21) = LUMP_2( INCOL, LGLOB, 22 ) + OUT(I,J,22) = LUMP_2( INCOL, LGLOB, 24 ) + OUT(I,J,23) = LUMP_2( INCOL, LGLOB, 26 ) + + ! Lump 4 levels together at a time, starting at L=28 + OUT(I,J,24) = LUMP_4( INCOL, LGLOB, 28 ) + OUT(I,J,25) = LUMP_4( INCOL, LGLOB, 32 ) + OUT(I,J,26) = LUMP_4( INCOL, LGLOB, 36 ) + OUT(I,J,27) = LUMP_4( INCOL, LGLOB, 40 ) + OUT(I,J,28) = LUMP_4( INCOL, LGLOB, 44 ) + OUT(I,J,29) = LUMP_4( INCOL, LGLOB, 48 ) + OUT(I,J,30) = LUMP_4( INCOL, LGLOB, 52 ) + +#elif defined( GEOS_5 ) || defined( GEOS_FP ) + + !-------------------------------------------------------------- + ! GEOS-5: Lump 72 levels into 47 levels, starting above L=36 + ! Lump levels in groups of 2, then 4. (cf. Bob Yantosca) + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time + OUT(I,J,37) = LUMP_2( INCOL, LGLOB, 37 ) + OUT(I,J,38) = LUMP_2( INCOL, LGLOB, 39 ) + OUT(I,J,39) = LUMP_2( INCOL, LGLOB, 41 ) + OUT(I,J,40) = LUMP_2( INCOL, LGLOB, 43 ) + + ! Lump 4 levels together at a time + OUT(I,J,41) = LUMP_4( INCOL, LGLOB, 45 ) + OUT(I,J,42) = LUMP_4( INCOL, LGLOB, 49 ) + OUT(I,J,43) = LUMP_4( INCOL, LGLOB, 53 ) + OUT(I,J,44) = LUMP_4( INCOL, LGLOB, 57 ) + OUT(I,J,45) = LUMP_4( INCOL, LGLOB, 61 ) + OUT(I,J,46) = LUMP_4( INCOL, LGLOB, 65 ) + OUT(I,J,47) = LUMP_4( INCOL, LGLOB, 69 ) + +#endif + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE TRANSFER_3D + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_G5_PLE( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_G5_PLE transfers GEOS-5 pressure edge data from the +! native 72-level grid to the reduced 47-level grid. (bmy, 2/8/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4) : Input field, of dimension (IGLOB,JGLOB,LGLOB) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (REAL*8) : Output field, of dimension (IIPAR,JJPAR,LLPAR) +! +! NOTES: +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*4, INTENT(IN) :: IN(IIPAR,JJPAR,LGLOB+1) + REAL*8, INTENT(OUT) :: OUT(IIPAR,JJPAR,LLPAR+1) + + ! Local variables + INTEGER :: I, J + + !================================================================ + ! TRANSFER_PLE begins here! + !================================================================ + + ! Copy the first L_COPY+1 edges (which define L_COPY levels) + OUT(:,:,1:L_COPY+1) = IN( 1+I0:IIPAR+I0,1+J0:JJPAR+J0,1:L_COPY+1 ) + + ! Exit if we are running at full vertical resolution + IF ( LLPAR == LGLOB ) RETURN + + !================================================================ + ! Return GEOS-5 pressure edges for reduced grid + !================================================================ + +#if defined( GEOS_5 ) || defined( GEOS_FP ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Top edges of levels lumped by 2's + OUT(I,J,38) = IN(I+I0,J+J0,39) + OUT(I,J,39) = IN(I+I0,J+J0,41) + OUT(I,J,40) = IN(I+I0,J+J0,43) + OUT(I,J,41) = IN(I+I0,J+J0,45) + + ! Top edges of levels lumped by 4's + OUT(I,J,42) = IN(I+I0,J+J0,49) + OUT(I,J,43) = IN(I+I0,J+J0,53) + OUT(I,J,44) = IN(I+I0,J+J0,57) + OUT(I,J,45) = IN(I+I0,J+J0,61) + OUT(I,J,46) = IN(I+I0,J+J0,65) + OUT(I,J,47) = IN(I+I0,J+J0,69) + OUT(I,J,48) = IN(I+I0,J+J0,73) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + +#endif + + ! Return to calling program + END SUBROUTINE TRANSFER_G5_PLE + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_3D_Lp1( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_3D_Lp1 transfers 3-D data from a REAL*4 array of +! dimension (IGLOB,JGLOB,LGLOB+1) to a REAL*8 array of dimension +! (IIPAR,JJPAR,LLPAR+1). Regrid in the vertical if needed. +! (bmy, 9/21/01, 2/8/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4) : Input field, of dimension (IGLOB,JGLOB,LGLOB+1) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (REAL*8) : Output field, of dimension (IIPAR,JJPAR,LLPAR+1) +! +! NOTES: +!****************************************************************************** +! +# include "CMN_SIZE" + + ! Arguments + REAL*4, INTENT(IN) :: IN(IGLOB,JGLOB,LGLOB+1) + REAL*8, INTENT(OUT) :: OUT(IIPAR,JJPAR,LLPAR+1) + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J + REAL*4 :: INCOL(LGLOB) + + !================================================================= + ! TRANSFER_3D_Lp1 begins here! + !================================================================= + + ! Copy the first L_COPY+1 levels + OUT(:,:,1:L_COPY+1) = IN( 1+I0:IIPAR+I0, 1+J0:JJPAR+J0,1:L_COPY+1) + + ! Exit if we are running full vertical resolution + IF ( LLPAR == LGLOB ) RETURN + + !================================================================= + ! Collapse levels in the stratosphere + ! + ! %%% TEMPORARY KLUDGE!!!! + ! %%% NOTE: For now do the same thing as in TRANSFER_G5_PLE, i.e. + ! %%% return the values at the edges. The only other field than + ! %%% PLE defined on the edges is CMFMC and that is always zero + ! %%% above about 120 hPa. (bmy, 2/8/07) + !================================================================= + +#if defined( GEOS_5 ) || defined( GEOS_FP ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Top edges of levels lumped by 2's + OUT(I,J,38) = IN(I+I0,J+J0,39) + OUT(I,J,39) = IN(I+I0,J+J0,41) + OUT(I,J,40) = IN(I+I0,J+J0,43) + OUT(I,J,41) = IN(I+I0,J+J0,45) + + ! Top edges of levels lumped by 4's + OUT(I,J,42) = IN(I+I0,J+J0,49) + OUT(I,J,43) = IN(I+I0,J+J0,53) + OUT(I,J,44) = IN(I+I0,J+J0,57) + OUT(I,J,45) = IN(I+I0,J+J0,61) + OUT(I,J,46) = IN(I+I0,J+J0,65) + OUT(I,J,47) = IN(I+I0,J+J0,69) + OUT(I,J,48) = IN(I+I0,J+J0,73) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + +#endif + + ! Return to calling program + END SUBROUTINE TRANSFER_3D_Lp1 + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_3D_TROP( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_3D_TROP transfers tropospheric 3-D data from a REAL*4 +! array to a REAL*8 array. (mje, bmy, 9/21/01, 2/8/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4) : Input field, of dimension (IGLOB,JGLOB,LLTROP) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (REAL*8) : Output field, of dimension (IIPAR,LLPAR,LLTROP) +! +! NOTES: +! (1 ) Now use LLTROP_FIX instead of LLTROP, since most of the offline +! simulations use the annual mean tropopause (bmy, 2/8/07) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*4, INTENT(IN) :: IN(IGLOB,JGLOB,LLTROP_FIX) + REAL*8, INTENT(OUT) :: OUT(IIPAR,JJPAR,LLTROP_FIX) + + ! Local variables + INTEGER :: L + + !================================================================= + ! TRANSFER_3D_TROP + !================================================================= + + ! Cast to REAL*8 abd resize up to LLTROP + DO L = 1, LLTROP_FIX + CALL TRANSFER_2D( IN(:,:,L), OUT(:,:,L) ) + ENDDO + + ! Return to calling program + END SUBROUTINE TRANSFER_3D_TROP + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_ZONAL_R4( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_ZOJAL_R4 transfers zonal-mean data from a REAL*4 array +! to a REAL*8 array. Vertical levels are collapsed (from LGLOB to LLPAR) if +! necessary. (mje, bmy, 9/21/01, 2/8/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4) : Input field, of dimension (JGLOB,LGLOB) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (REAL*8) : Output field, of dimension (JJPAR,LLPAR) +! +! NOTES: +! (1 ) Lump levels together in groups of 2 or 4, as dictated by Mat Evans. +! (bmy, 9/21/01) +! (2 ) Assumes that LLPAR == LGLOB for GEOS-1, GEOS-STRAT (bmy, 9/21/01) +! (3 ) Now use function GET_YOFFSET from "grid_mod.f". Now I0 and J0 are +! local variables (bmy, 3/11/03) +! (4 ) Added code to regrid GEOS-4 from 55 --> 30 levels (mje, bmy, 10/31/03) +! (5 ) Rewritten for clarity (bmy, 2/8/07) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*4, INTENT(IN) :: IN(JGLOB,LGLOB) + REAL*4, INTENT(OUT) :: OUT(JJPAR,LLPAR) + + ! Local variables + INTEGER :: J + REAL*4 :: INCOL(LGLOB) + + !================================================================ + ! TRANSFER_ZONAL_R4 begins here! + !================================================================ + + ! Copy the first L_COPY levels + OUT(:,1:L_COPY) = IN( 1+J0:JJPAR+J0, 1:L_COPY ) + + ! Exit if we are running at full vertical resolution + IF ( LLPAR == LGLOB ) RETURN + + !================================================================ + ! Collapse levels in the stratosphere + !================================================================ + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( J, INCOL ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + + ! Store vertical column at (I,J) in a 1-D vector + INCOL = IN( J+J0, 1:LGLOB ) + +#if defined( GEOS_3 ) + + !-------------------------------------------------------------- + ! GEOS-3: Lump 48 levels into 30 levels, starting above L=22. + ! Lump levels in groups of 2, then 4. (cf. Mat Evans) + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time + OUT(J,23) = LUMP_2( INCOL, LGLOB, 23 ) + OUT(J,24) = LUMP_2( INCOL, LGLOB, 25 ) + OUT(J,25) = LUMP_2( INCOL, LGLOB, 27 ) + + ! Lump 4 levels together at a time + OUT(J,26) = LUMP_4( INCOL, LGLOB, 29 ) + OUT(J,27) = LUMP_4( INCOL, LGLOB, 33 ) + OUT(J,28) = LUMP_4( INCOL, LGLOB, 37 ) + OUT(J,29) = LUMP_4( INCOL, LGLOB, 41 ) + OUT(J,30) = LUMP_4( INCOL, LGLOB, 45 ) + +#elif defined( GEOS_4 ) + + !-------------------------------------------------------------- + ! GEOS-4: Lump 55 levels into 30 levels, starting above L=20 + ! Lump levels in groups of 2, then 4. (cf. Mat Evans) + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time + OUT(J,20) = LUMP_2( INCOL, LGLOB, 20 ) + OUT(J,21) = LUMP_2( INCOL, LGLOB, 22 ) + OUT(J,22) = LUMP_2( INCOL, LGLOB, 24 ) + OUT(J,23) = LUMP_2( INCOL, LGLOB, 26 ) + + ! Lump 4 levels together at a time + OUT(J,24) = LUMP_4( INCOL, LGLOB, 28 ) + OUT(J,25) = LUMP_4( INCOL, LGLOB, 32 ) + OUT(J,26) = LUMP_4( INCOL, LGLOB, 36 ) + OUT(J,27) = LUMP_4( INCOL, LGLOB, 40 ) + OUT(J,28) = LUMP_4( INCOL, LGLOB, 44 ) + OUT(J,29) = LUMP_4( INCOL, LGLOB, 48 ) + OUT(J,30) = LUMP_4( INCOL, LGLOB, 52 ) + +#elif defined( GEOS_5 ) || defined( GEOS_FP ) + + !-------------------------------------------------------------- + ! GEOS-5: Lump 72 levels into 47 levels, starting above L=36 + ! Lump levels in groups of 2, then 4. + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time + OUT(J,37) = LUMP_2( INCOL, LGLOB, 37 ) + OUT(J,38) = LUMP_2( INCOL, LGLOB, 39 ) + OUT(J,39) = LUMP_2( INCOL, LGLOB, 41 ) + OUT(J,40) = LUMP_2( INCOL, LGLOB, 43 ) + + ! Lump 4 levels together at a time + OUT(J,41) = LUMP_4( INCOL, LGLOB, 45 ) + OUT(J,42) = LUMP_4( INCOL, LGLOB, 49 ) + OUT(J,43) = LUMP_4( INCOL, LGLOB, 53 ) + OUT(J,44) = LUMP_4( INCOL, LGLOB, 57 ) + OUT(J,45) = LUMP_4( INCOL, LGLOB, 61 ) + OUT(J,46) = LUMP_4( INCOL, LGLOB, 65 ) + OUT(J,47) = LUMP_4( INCOL, LGLOB, 69 ) + +#endif + + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE TRANSFER_ZONAL_R4 + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_ZONAL_R8( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_ZONAL_R4 transfers zonal mean or lat-alt data from a +! REAL*4 array of dimension (JGLOB,LGLOB) to a REAL*8 array of dimension +! (JJPAR,LLPAR). Regrid GEOS-3 data from 48 --> 30 levels or GEOS-4 data +! from 55 --> 30 levels if necessary. (bmy, 9/21/01, 5/24/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4) : Input field, of dimension (JGLOB,LGLOB) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (REAL*8) : Output field, of dimension (JJPAR,LLPAR) +! +! NOTES: +! (1 ) Lump levels together in groups of 2 or 4, as dictated by Mat Evans. +! (bmy, 9/21/01) +! (2 ) Assumes that LLPAR == LGLOB for GEOS-1, GEOS-STRAT (bmy, 9/21/01) +! (3 ) Now use function GET_YOFFSET from "grid_mod.f". Now I0 and J0 are +! local variables (bmy, 3/11/03) +! (4 ) Added code to regrid GEOS-4 from 55 --> 30 levels (mje, bmy, 10/31/03) +! (5 ) Now modified for GEOS-5 met fields (bmy, 5/24/05) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*4, INTENT(IN) :: IN(JGLOB,LGLOB) + REAL*8, INTENT(OUT) :: OUT(JJPAR,LLPAR) + + ! Local variables + INTEGER :: J + REAL*4 :: INCOL(LGLOB) + + !================================================================ + ! TRANSFER_ZONAL_R8 begins here! + !================================================================ + + ! Copy the first L_COPY levels + OUT(:,1:L_COPY) = IN( 1+J0:JJPAR+J0, 1:L_COPY ) + + ! Exit if we are running at full vertical resolution + IF ( LLPAR == LGLOB ) RETURN + + !================================================================ + ! Collapse levels in the stratosphere + !================================================================ + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( J, INCOL ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + + ! Store vertical column at (I,J) in a 1-D vector + INCOL = IN( J+J0, 1:LGLOB ) + +#if defined( GEOS_3 ) + + !-------------------------------------------------------------- + ! GEOS-3: Lump 48 levels into 30 levels, starting above L=22. + ! Lump levels in groups of 2, then 4. (cf. Mat Evans) + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time + OUT(J,23) = LUMP_2( INCOL, LGLOB, 23 ) + OUT(J,24) = LUMP_2( INCOL, LGLOB, 25 ) + OUT(J,25) = LUMP_2( INCOL, LGLOB, 27 ) + + ! Lump 4 levels together at a time + OUT(J,26) = LUMP_4( INCOL, LGLOB, 29 ) + OUT(J,27) = LUMP_4( INCOL, LGLOB, 33 ) + OUT(J,28) = LUMP_4( INCOL, LGLOB, 37 ) + OUT(J,29) = LUMP_4( INCOL, LGLOB, 41 ) + OUT(J,30) = LUMP_4( INCOL, LGLOB, 45 ) + +#elif defined( GEOS_4 ) + + !-------------------------------------------------------------- + ! GEOS-4: Lump 55 levels into 30 levels, starting above L=20 + ! Lump levels in groups of 2, then 4. (cf. Mat Evans) + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time + OUT(J,20) = LUMP_2( INCOL, LGLOB, 20 ) + OUT(J,21) = LUMP_2( INCOL, LGLOB, 22 ) + OUT(J,22) = LUMP_2( INCOL, LGLOB, 24 ) + OUT(J,23) = LUMP_2( INCOL, LGLOB, 26 ) + + ! Lump 4 levels together at a time + OUT(J,24) = LUMP_4( INCOL, LGLOB, 28 ) + OUT(J,25) = LUMP_4( INCOL, LGLOB, 32 ) + OUT(J,26) = LUMP_4( INCOL, LGLOB, 36 ) + OUT(J,27) = LUMP_4( INCOL, LGLOB, 40 ) + OUT(J,28) = LUMP_4( INCOL, LGLOB, 44 ) + OUT(J,29) = LUMP_4( INCOL, LGLOB, 48 ) + OUT(J,30) = LUMP_4( INCOL, LGLOB, 52 ) + +#elif defined( GEOS_5 ) || defined( GEOS_FP ) + + !-------------------------------------------------------------- + ! GEOS-5: Lump 72 levels into 47 levels, starting above L=36 + ! Lump levels in groups of 2, then 4. + !-------------------------------------------------------------- + + ! Lump 2 levels together at a time + OUT(J,37) = LUMP_2( INCOL, LGLOB, 37 ) + OUT(J,38) = LUMP_2( INCOL, LGLOB, 39 ) + OUT(J,39) = LUMP_2( INCOL, LGLOB, 41 ) + OUT(J,40) = LUMP_2( INCOL, LGLOB, 43 ) + + ! Lump 4 levels together at a time + OUT(J,41) = LUMP_4( INCOL, LGLOB, 45 ) + OUT(J,42) = LUMP_4( INCOL, LGLOB, 49 ) + OUT(J,43) = LUMP_4( INCOL, LGLOB, 53 ) + OUT(J,44) = LUMP_4( INCOL, LGLOB, 57 ) + OUT(J,45) = LUMP_4( INCOL, LGLOB, 61 ) + OUT(J,46) = LUMP_4( INCOL, LGLOB, 65 ) + OUT(J,47) = LUMP_4( INCOL, LGLOB, 69 ) +#endif + + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE TRANSFER_ZONAL_R8 + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_2D_INT( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_2D_INT transfers 2-D data from a REAL*4 array of +! dimension (IGLOB,JGLOB) to an INTEGER array of dimension (IIPAR,JJPAR). +! (bmy, 9/21/01, 3/11/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4 ) : Input field, of dimension (IGLOB,JGLOB) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (INTEGER) : Output field, of dimension (IIPAR,JJPAR) +! +! NOTES: +! (1 ) Use parallel DO loops to speed things up (bmy, 9/21/01)! +! (2 ) Now use functions GET_XOFFSET and GET_YOFFSET from "grid_mod.f". +! Now I0 and J0 are local variables. (bmy, 3/11/03) +!****************************************************************************** +! +# include "CMN_SIZE" + + ! Arguments + REAL*4, INTENT(IN) :: IN(IGLOB,JGLOB) + INTEGER, INTENT(OUT) :: OUT(IIPAR,JJPAR) + + !================================================================= + ! TRANSFER_2D_INT begins here! + !================================================================= + + ! Copy and cast array + OUT = IN( 1+I0:IIPAR+I0, 1+J0:JJPAR+J0 ) + + ! Return to calling program + END SUBROUTINE TRANSFER_2D_INT + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_2D_R4( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_2D_R4 transfers 2-D data from a REAL*4 array of +! dimension (IGLOB,JGLOB) to a REAL*4 array of dimension (IIPAR,JJPAR). +! (bmy, 1/25/02, 3/11/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4) : Input field, of dimension (IGLOB,JGLOB) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (REAL*4) : Output field, of dimension (IIPAR,JJPAR) +! +! NOTES: +! (1 ) Use parallel DO loops to speed things up (bmy, 9/21/01) +! (2 ) Now use functions GET_XOFFSET and GET_YOFFSET from "grid_mod.f" +! Now I0 and J0 are local variables (bmy, 3/11/03) +!****************************************************************************** +! +# include "CMN_SIZE" + + ! Arguments + REAL*4, INTENT(IN) :: IN(IGLOB,JGLOB) + REAL*4, INTENT(OUT) :: OUT(IIPAR,JJPAR) + + !================================================================= + ! TRANSFER_2D_R4 begins here! + !================================================================= + + ! Copy and cast array + OUT = IN( 1+I0:IIPAR+I0, 1+J0:JJPAR+J0 ) + + ! Return to calling program + END SUBROUTINE TRANSFER_2D_R4 + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_2D_R8( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_2D_R8 transfers 2-D data from a REAL*4 array of +! dimension (IGLOB,JGLOB) to a REAL*8 array of dimension (IIPAR,JJPAR). +! (bmy, 9/21/01, 3/11/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4) : Input field, of dimension (IGLOB,JGLOB) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (REAL*8) : Output field, of dimension (IIPAR,JJPAR) +! +! NOTES: +! (1 ) Use parallel DO loops to speed things up (bmy, 9/21/01) +! (2 ) Now use functions GET_XOFFSET and GET_YOFFSET from "grid_mod.f" +! Now I0 and J0 are local variables. (bmy, 3/11/03) +!****************************************************************************** +! +# include "CMN_SIZE" + + ! Arguments + REAL*4, INTENT(IN) :: IN(IGLOB,JGLOB) + REAL*8, INTENT(OUT) :: OUT(IIPAR,JJPAR) + + !================================================================= + ! TRANSFER_2D_R8 begins here! + !================================================================= + + ! Copy and cast array + OUT = IN( 1+I0:IIPAR+I0, 1+J0:JJPAR+J0 ) + + ! Return to calling program + END SUBROUTINE TRANSFER_2D_R8 + +!------------------------------------------------------------------------------ + + SUBROUTINE TRANSFER_TO_1D( IN, OUT ) +! +!****************************************************************************** +! Subroutine TRANSFER_TO_1D transfers 2-D data from a REAL*4 array of +! dimension (IGLOB,JGLOB) to 1-D a REAL*8 array of dimension (MAXIJ), +! where MAXIJ = IIPAR * JJPAR. (bmy, 9/21/01, 3/11/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4) : Input field, of dimension (IGLOB,JGLOB) +! +! Arguments as Output: +! ============================================================================ +! (2 ) OUT (REAL*8) : Output field, of dimension (MAXIJ) +! +! NOTES: +! (1 ) Use single-processor DO-loops for now (bmy, 9/21/01) +! (2 ) Now use functions GET_XOFFSET and GET_YOFFSET from "grid_mod.f". +! Now I0 and J0 are local variables. (bmy, 3/11/03) +!****************************************************************************** +! +# include "CMN_SIZE" + + ! Arguments + REAL*4, INTENT(IN) :: IN(IGLOB,JGLOB) + REAL*8, INTENT(OUT) :: OUT(MAXIJ) + + ! Local variables + INTEGER :: I, IREF, J, JREF, IJLOOP + + !================================================================= + ! TRANSFER_TO_1D begins here! + !================================================================= + + ! 1-D counter + IJLOOP = 0 + + ! IJLOOP = ( (J-1) * IIPAR ) + I + + DO J = 1, JJPAR + JREF = J + J0 + DO I = 1, IIPAR + IREF = I + I0 + IJLOOP = IJLOOP + 1 + OUT(IJLOOP) = IN(IREF,JREF) + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE TRANSFER_TO_1D + +!------------------------------------------------------------------------------ + + FUNCTION LUMP_2_R4( IN, L_IN, L ) RESULT( OUT ) +! +!****************************************************************************** +! Function LUMP_2_R4 lumps 2 sigma levels into one thick level. +! Input arguments must be REAL*4. (bmy, 9/18/01, 10/31/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4 ) : Column of data on input vertical grid +! (2 ) L_IN (INTEGER) : Vertical dimension of the IN array +! (3 ) L (INTEGER) : Level on input grid from which to start regridding +! +! Function Value: +! ============================================================================ +! (4 ) OUT (REAL*4 ) : Data on output grid -- 2 levels merged together +! +! NOTES: +! (1 ) Now references GEOS_CHEM_STOP from "error_mod.f" (bmy, 10/15/02) +! (2 ) Renamed SIGE_IN to EDGE_IN to denote that it is not always a sigma +! coordinate (as for GEOS-4). Also updated comments (bmy, 10/31/03) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + + ! Arguments + INTEGER, INTENT(IN) :: L_IN, L + REAL*4, INTENT(IN) :: IN(L_IN) + + ! Function value + REAL*4 :: OUT + + !================================================================= + ! LUMP_2_R4 begins here! + !================================================================= + + ! Error check: prevent array out of bounds error + IF ( L < 1 .or. L > L_IN .or. L+2 > L_IN+1 ) THEN + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'Error: L < 1 or L > L_IN or L+2 > L_IN+1!' + WRITE( 6, '(a)' ) 'STOP in LUMP_2 ("regrid_mod.f")' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + !================================================================= + ! When lumping the levels together, we need to perform a weighted + ! average by air mass. The air mass in a grid box is given by: + ! + ! Air Mass = Delta-P [hPa] * 100/g * Grid box sfc area [cm2] + ! + ! Where Delta-P is the difference in pressure between the bottom + ! and top edges of the grid box (Delta-P is positive), 100/g is a + ! constant, and the grid box surface area is also constant w/in + ! the same vertical column. Therefore, for a vertical column, + ! the air mass in a grid box really only depends on Delta-P. + ! + ! Because of this, we may compute the quantity Q(L') on the new + ! merged sigma according to the weighted average (EQUATION 1): + ! + ! [ ( Q(L ) * ( PEDGE(L ) - PEDGE(L+1) ) ) + + ! ( Q(L+1) * ( PEDGE(L+1) - PEDGE(L+2) ) ) ] + ! Q(L') = ------------------------------------------------- + ! PEDGE(L) - PEDGE(L+2) + ! + ! where PEDGE(L) is the pressure at the bottom edge of layer L. + ! + ! GEOS-4 is a hybrid sigma-pressure grid, with all of the levels + ! above level 14 being pure pressure levels. Therefore, for + ! GEOS-4, we may just use EQUATION 1 exactly as written above. + ! + ! However, GEOS-3 is a pure sigma grid. The pressure at the + ! edge of a grid box is given by (EQUATION 2): + ! + ! PEDGE(I,J,L) = PTOP + ( SIG_EDGE(L) * ( Psurf(I,J) - PTOP) ) + ! + ! In a vertical column, then ( Psurf(I,J) - PTOP ) will be the + ! same for all vertical levels, and will divide out of the + ! equation. Also the PTOP's will cancel each other out. Thus + ! for GEOS-3, the above equation reduces to (EQUATION 3): + ! + ! [ ( Q(L ) * ( SIG_EDGE(L ) - SIG_EDGE(L+1) ) ) + + ! ( Q(L+1) * ( SIG_EDGE(L+1) - SIG_EDGE(L+2) ) ) ] + ! Q(L') = ---------------------------------------------------- + ! SIG_EDGE(L) - SIG_EDGE(L+2) + !================================================================= + + ! For GEOS-3, EDGE_IN are the sigma values at grid box edges + ! For GEOS-4, EDGE_IN are the pressures at grid box edges + OUT = ( IN(L ) * ( EDGE_IN(L ) - EDGE_IN(L+1) ) ) + + & ( IN(L+1) * ( EDGE_IN(L+1) - EDGE_IN(L+2) ) ) + + ! Divde by sigma thickness of new thick level + OUT = OUT / ( EDGE_IN(L) - EDGE_IN(L+2) ) + + ! Return to calling routine + END FUNCTION LUMP_2_R4 + +!------------------------------------------------------------------------------ + + FUNCTION LUMP_2_R8( IN, L_IN, L ) RESULT( OUT ) +! +!****************************************************************************** +! Function LUMP_2_R8 lumps 2 sigma levels into one thick level. +! Input arguments must be REAL*8. (bmy, 9/18/01, 10/31/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*8 ) : Column of data on input vertical grid +! (2 ) L_IN (INTEGER) : Vertical dimension of the IN array +! (3 ) L (INTEGER) : Level on input grid from which to start regridding +! +! Function Value: +! ============================================================================ +! (4 ) OUT (REAL*8 ) : Data on output grid -- 2 levels merged together +! +! NOTES: +! (1 ) Now references GEOS_CHEM_STOP from "error_mod.f" (bmy, 10/15/02) +! (2 ) Renamed SIGE_IN to EDGE_IN to denote that it is not always a sigma +! coordinate (as for GEOS-4). Also updated comments (bmy, 10/31/03) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + + ! Arguments + INTEGER, INTENT(IN) :: L_IN, L + REAL*8, INTENT(IN) :: IN(L_IN) + + ! Function value + REAL*8 :: OUT + + !================================================================= + ! LUMP_2_R8 begins here! + !================================================================= + + ! Error check: prevent array out of bounds error + IF ( L < 1 .or. L > L_IN .or. L+2 > L_IN+1 ) THEN + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'ERROR: L < 1 or L > L_IN or L+2 > L_IN+1!' + WRITE( 6, '(a)' ) 'STOP in LUMP_2 ("regrid_mod.f")' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + !================================================================= + ! When lumping the levels together, we need to perform a weighted + ! average by air mass. The air mass in a grid box is given by: + ! + ! Air Mass = Delta-P [hPa] * 100/g * Grid box sfc area [cm2] + ! + ! Where Delta-P is the difference in pressure between the bottom + ! and top edges of the grid box (Delta-P is positive), 100/g is a + ! constant, and the grid box surface area is also constant w/in + ! the same vertical column. Therefore, for a vertical column, + ! the air mass in a grid box really only depends on Delta-P. + ! + ! Because of this, we may compute the quantity Q(L') on the new + ! merged sigma according to the weighted average (EQUATION 1): + ! + ! [ ( Q(L ) * ( PEDGE(L ) - PEDGE(L+1) ) ) + + ! ( Q(L+1) * ( PEDGE(L+1) - PEDGE(L+2) ) ) + + ! ( Q(L+2) * ( PEDGE(L+2) - PEDGE(L+3) ) ) + + ! ( Q(L+3) * ( PEDGE(L+3) - PEDGE(L+4) ) ) ] + ! Q(L') = ------------------------------------------------ + ! PEDGE(L) - PEDGE(L+4) + ! + ! where PEDGE(L) is the pressure at the bottom edge of layer L. + ! + ! GEOS-4 is a hybrid sigma-pressure grid, with all of the levels + ! above level 14 being pure pressure levels. Therefore, for + ! GEOS-4, we may just use EQUATION 1 exactly as written above. + ! + ! However, GEOS-3 is a pure sigma grid. The pressure at the + ! edge of a grid box is given by EQUATION 2: + ! + ! PEDGE(I,J,L) = PTOP + ( SIG_EDGE(L) * ( Psurf(I,J) - PTOP) ) + ! + ! In a vertical column, then ( Psurf(I,J) - PTOP ) will be the + ! same for all vertical levels, and will divide out of the + ! equation. Also the PTOP's will cancel each other out. Thus + ! for GEOS-3, the above equation reduces to (EQUATION 3): + ! + ! [ ( Q(L ) * ( SIG_EDGE(L ) - SIG_EDGE(L+1) ) ) + + ! ( Q(L+1) * ( SIG_EDGE(L+1) - SIG_EDGE(L+2) ) ) ] + ! Q(L') = ---------------------------------------------------- + ! SIG_EDGE(L) - SIG_EDGE(L+2) + !================================================================= + + ! For GEOS-3, EDGE_IN are the sigma values at grid box edges + ! For GEOS-4, EDGE_IN are the pressures at grid box edges + OUT = ( IN(L ) * ( EDGE_IN(L ) - EDGE_IN(L+1) ) ) + + & ( IN(L+1) * ( EDGE_IN(L+1) - EDGE_IN(L+2) ) ) + + ! Divde by thickness of new lumped level + OUT = OUT / ( EDGE_IN(L) - EDGE_IN(L+2) ) + + ! Return to calling routine + END FUNCTION LUMP_2_R8 + +!------------------------------------------------------------------------------ + + FUNCTION LUMP_4_R4( IN, L_IN, L ) RESULT( OUT ) +! +!****************************************************************************** +! Function LUMP_4_R4 lumps 4 sigma levels into one thick level. +! Input arguments must be REAL*4. (bmy, 9/18/01, 10/31/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*4 ) : Column of data on input vertical grid +! (2 ) L_IN (INTEGER) : Vertical dimension of the IN array +! (3 ) L (INTEGER) : Level on input grid from which to start regridding +! +! Function Value: +! ============================================================================ +! (4 ) OUT (REAL*4 ) : Data on output grid -- 4 levels merged together +! +! NOTES: +! (1 ) Now references GEOS_CHEM_STOP from "error_mod.f" (bmy, 10/15/02) +! (2 ) Renamed SIGE_IN to EDGE_IN to denote that it is not always a sigma +! coordinate (as for GEOS-4). Also updated comments (bmy, 10/31/03) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + + ! Arguments + INTEGER, INTENT(IN) :: L_IN, L + REAL*4, INTENT(IN) :: IN(L_IN) + + ! Function value + REAL*4 :: OUT + + !================================================================= + ! LUMP_4_R4 begins here! + !================================================================= + + ! Error check: prevent array out of bounds error + IF ( L < 1 .or. L > L_IN .or. L+4 > L_IN+1 ) THEN + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'ERROR: L < 1 or L > L_IN or L+4 > L_IN+1!' + WRITE( 6, '(a)' ) 'STOP in LUMP_4 ("regrid_mod.f")' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + !================================================================= + ! When lumping the levels together, we need to perform a weighted + ! average by air mass. The air mass in a grid box is given by: + ! + ! Air Mass = Delta-P [hPa] * 100/g * Grid box sfc area [cm2] + ! + ! Where Delta-P is the difference in pressure between the bottom + ! and top edges of the grid box (Delta-P is positive), 100/g is a + ! constant, and the grid box surface area is also constant w/in + ! the same vertical column. Therefore, for a vertical column, + ! the air mass in a grid box really only depends on Delta-P. + ! + ! Because of this, we may compute the quantity Q(L') on the new + ! merged sigma according to the weighted average (EQUATION 1): + ! + ! [ ( Q(L ) * ( PEDGE(L ) - PEDGE(L+1) ) ) + + ! ( Q(L+1) * ( PEDGE(L+1) - PEDGE(L+2) ) ) + + ! ( Q(L+2) * ( PEDGE(L+2) - PEDGE(L+3) ) ) + + ! ( Q(L+3) * ( PEDGE(L+3) - PEDGE(L+4) ) ) ] + ! Q(L') = -------------------------------------------------- + ! PEDGE(L) - PEDGE(L+4) + ! + ! where PEDGE(L) is the pressure at the bottom edge of layer L. + ! + ! GEOS-4 is a hybrid sigma-pressure grid, with all of the levels + ! above level 14 being pure pressure levels. Therefore, for + ! GEOS-4, we may just use EQUATION 1 exactly as written above. + ! + ! However, GEOS-3 is a pure sigma grid. The pressure at the + ! edge of a grid box is given by EQUATION 2: + ! + ! PEDGE(I,J,L) = PTOP + ( SIG_EDGE(L) * ( Psurf(I,J) - PTOP) ) + ! + ! In a vertical column, then ( Psurf(I,J) - PTOP ) will be the + ! same for all vertical levels, and will divide out of the + ! equation. Also the PTOP's will cancel each other out. Thus + ! for GEOS-3, the above equation reduces to (EQUATION 3): + ! + ! [ ( Q(L ) * ( SIG_EDGE(L ) - SIG_EDGE(L+1) ) ) + + ! ( Q(L+1) * ( SIG_EDGE(L+1) - SIG_EDGE(L+2) ) ) + + ! ( Q(L+2) * ( SIG_EDGE(L+2) - SIG_EDGE(L+3) ) ) + + ! ( Q(L+3) * ( SIG_EDGE(L+3) - SIG_EDGE(L+4) ) ) ] + ! Q(L') = ---------------------------------------------------- + ! SIG_EDGE(L) - SIG_EDGE(L+4) + !================================================================= + + ! For GEOS-3, EDGE_IN are the sigma values at grid box edges + ! For GEOS-4, EDGE_IN are the pressures at grid box edges + OUT = ( IN(L ) * ( EDGE_IN(L ) - EDGE_IN(L+1) ) ) + + & ( IN(L+1) * ( EDGE_IN(L+1) - EDGE_IN(L+2) ) ) + + & ( IN(L+2) * ( EDGE_IN(L+2) - EDGE_IN(L+3) ) ) + + & ( IN(L+3) * ( EDGE_IN(L+3) - EDGE_IN(L+4) ) ) + + ! Divde by thickness of new lumped level + OUT = OUT / ( EDGE_IN(L) - EDGE_IN(L+4) ) + + ! Return to calling routine + END FUNCTION LUMP_4_R4 + +!------------------------------------------------------------------------------ + + FUNCTION LUMP_4_R8( IN, L_IN, L ) RESULT( OUT ) +! +!****************************************************************************** +! Function LUMP_4_R8 lumps 4 sigma levels into one thick level. +! Input arguments must be REAL*8. (bmy, 9/18/01, 10/31/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IN (REAL*8 ) : Column of data on input vertical grid +! (2 ) L_IN (INTEGER) : Vertical dimension of the IN array +! (3 ) L (INTEGER) : Level on input grid from which to start regridding +! +! Function Value: +! ============================================================================ +! (4 ) OUT (REAL*8 ) : Data on output grid -- 4 levels merged together +! +! NOTES: +! (1 ) Now references GEOS_CHEM_STOP from "error_mod.f" (bmy, 10/15/02) +! (2 ) Renamed SIGE_IN to EDGE_IN to denote that it is not always a sigma +! coordinate (as for GEOS-4). Also updated comments (bmy, 10/31/03) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + +# include "CMN_SIZE" + + ! Arguments + INTEGER, INTENT(IN) :: L_IN, L + REAL*8, INTENT(IN) :: IN(L_IN) + + ! Function value + REAL*8 :: OUT + + !================================================================= + ! LUMP_4_R8 begins here! + !================================================================= + + ! Error check: prevent array out of bounds error + IF ( L < 1 .or. L > L_IN .or. L+4 > L_IN+1 ) THEN + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'ERROR: L < 1 or L > L_IN or L+4 > L_IN+1!' + WRITE( 6, '(a)' ) 'STOP in LUMP_4 ("regrid_mod.f")' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + !================================================================= + ! When lumping the levels together, we need to perform a weighted + ! average by air mass. The air mass in a grid box is given by: + ! + ! Air Mass = Delta-P [hPa] * 100/g * Grid box sfc area [cm2] + ! + ! Where Delta-P is the difference in pressure between the bottom + ! and top edges of the grid box (Delta-P is positive), 100/g is a + ! constant, and the grid box surface area is also constant w/in + ! the same vertical column. Therefore, for a vertical column, + ! the air mass in a grid box really only depends on Delta-P. + ! + ! Because of this, we may compute the quantity Q(L') on the new + ! merged sigma according to the weighted average (EQUATION 1): + ! + ! [ ( Q(L ) * ( PEDGE(L ) - PEDGE(L+1) ) ) + + ! ( Q(L+1) * ( PEDGE(L+1) - PEDGE(L+2) ) ) + + ! ( Q(L+2) * ( PEDGE(L+2) - PEDGE(L+3) ) ) + + ! ( Q(L+3) * ( PEDGE(L+3) - PEDGE(L+4) ) ) ] + ! Q(L') = ------------------------------------------------ + ! PEDGE(L) - PEDGE(L+4) + ! + ! where PEDGE(L) is the pressure at the bottom edge of layer L. + ! + ! GEOS-4 is a hybrid sigma-pressure grid, with all of the levels + ! above level 14 being pure pressure levels. Therefore, for + ! GEOS-4, we may just use EQUATION 1 exactly as written above. + ! + ! However, GEOS-3 is a pure sigma grid. The pressure at the + ! edge of a grid box is given by EQUATION 2: + ! + ! PEDGE(I,J,L) = PTOP + ( SIG_EDGE(L) * ( Psurf(I,J) - PTOP) ) + ! + ! In a vertical column, then ( Psurf(I,J) - PTOP ) will be the + ! same for all vertical levels, and will divide out of the + ! equation. Also the PTOP's will cancel each other out. Thus + ! for GEOS-3, the above equation reduces to (EQUATION 3): + ! + ! [ ( Q(L ) * ( SIG_EDGE(L ) - SIG_EDGE(L+1) ) ) + + ! ( Q(L+1) * ( SIG_EDGE(L+1) - SIG_EDGE(L+2) ) ) + + ! ( Q(L+2) * ( SIG_EDGE(L+2) - SIG_EDGE(L+3) ) ) + + ! ( Q(L+3) * ( SIG_EDGE(L+3) - SIG_EDGE(L+4) ) ) ] + ! Q(L') = ------------------------------------------------ + ! SIG_EDGE(L) - SIG_EDGE(L+4) + !================================================================= + + ! For GEOS-3, EDGE_IN are the sigma values at grid box edges + ! For GEOS-4, EDGE_IN are the pressures at grid box edges + OUT = ( IN(L ) * ( EDGE_IN(L ) - EDGE_IN(L+1) ) ) + + & ( IN(L+1) * ( EDGE_IN(L+1) - EDGE_IN(L+2) ) ) + + & ( IN(L+2) * ( EDGE_IN(L+2) - EDGE_IN(L+3) ) ) + + & ( IN(L+3) * ( EDGE_IN(L+3) - EDGE_IN(L+4) ) ) + + ! Divde by thickness of new lumped level + OUT = OUT / ( EDGE_IN(L) - EDGE_IN(L+4) ) + + ! Return to calling routine + END FUNCTION LUMP_4_R8 + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_TRANSFER( THIS_I0, THIS_J0 ) +! +!****************************************************************************** +! Subroutine INIT_TRANSFER initializes and zeroes the EDGE_IN array. +! (bmy, 9/19/01, 2/8/07) +! +! NOTES: +! (1 ) Removed additional "," for GEOS-1 definition of EDGE_IN (bmy, 3/25/02) +! (2 ) Now use GET_BP from "pressure_mod.f" to get sigma edges for all +! grids except GEOS-3 (dsa, bdf, bmy, 8/22/02) +! (3 ) Declare L as a local variable. Also reference ALLOC_ERR from module +! "error_mod.f" (bmy, 10/15/02) +! (4 ) Renamed SIGE_IN to EDGE_IN to denote that it is not always a sigma +! coordinate (as for GEOS-4). Now assign original Ap coordinates from +! the GEOS-4 grid to the EDGE_IN array (bmy, 10/31/03) +! (5 ) Now modified for GEOS-5 met fields (bmy, 5/24/05) +! (6 ) Rewritten for clarity. Remove references to "grid_mod.f" and +! "pressure_mod.f". Now pass I0, J0 from "grid_mod.f" via the arg list. +! (bmy, 2/8/07) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: THIS_I0, THIS_J0 + + ! Local variables + LOGICAL, SAVE :: IS_INIT = .FALSE. + INTEGER :: AS, L + + !================================================================= + ! INIT_TRANSFER begins here! + !================================================================= + + ! Return if we have already initialized + IF ( IS_INIT ) RETURN + + !----------------------------------------------------------------- + ! Get global X and Y offsets (usually =0, even for nested grid) + !----------------------------------------------------------------- + I0 = THIS_I0 + J0 = THIS_J0 + + !----------------------------------------------------------------- + ! Get the # of levels to copy in the vertical + !----------------------------------------------------------------- + IF ( LLPAR == LGLOB ) THEN + + ! Full vertical resolution; copy all levels! + L_COPY = LGLOB + + ELSE + +#if defined( GEOS_3 ) + L_COPY = 22 ! GEOS-3: Copy up to L=22 +#elif defined( GEOS_4 ) + L_COPY = 19 ! GEOS-4: Copy up to L=19 +#elif defined( GEOS_5 ) || defined( GEOS_FP ) + L_COPY = 36 ! GEOS-5: Copy up to L=36 +#elif defined( GCAP ) + L_COPY = LGLOB ! GCAP: Copy all levels +#endif + + ENDIF + + !================================================================= + ! Define vertical edges for collapsing stratospheric levels + !================================================================= + + ! Allocate the EDGE_IN array + ALLOCATE( EDGE_IN( LGLOB + 1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EDGE_IN' ) + EDGE_IN = 0d0 + +#if defined( GEOS_5 ) || defined( GEOS_FP ) + + !----------------------------------------------------------------- + ! For GEOS-5, levels 1-31 are "terrain-following" coordinates + ! (i.e. vary with location), and levels 32-72 are fixed pressure + ! levels. The transition pressure is 176.93 hPa, which is the + ! edge between L=31 and L=32. + ! + ! Initialize EDGE_IN with the original 73 Ap values for GEOS-5. + !----------------------------------------------------------------- + EDGE_IN = (/ + & 0.000000d+00, 4.804826d-02, 6.593752d+00, 1.313480d+01, + & 1.961311d+01, 2.609201d+01, 3.257081d+01, 3.898201d+01, + & 4.533901d+01, 5.169611d+01, 5.805321d+01, 6.436264d+01, + & 7.062198d+01, 7.883422d+01, 8.909992d+01, 9.936521d+01, + & 1.091817d+02, 1.189586d+02, 1.286959d+02, 1.429100d+02, + & 1.562600d+02, 1.696090d+02, 1.816190d+02, 1.930970d+02, + & 2.032590d+02, 2.121500d+02, 2.187760d+02, 2.238980d+02, + & 2.243630d+02, 2.168650d+02, 2.011920d+02, +!------- EDGES OF GEOS-5 FIXED PRESSURE LEVELS OCCUR BELOW THIS LINE ------ + & 1.769300d+02, + & 1.503930d+02, 1.278370d+02, 1.086630d+02, 9.236572d+01, + & 7.851231d+01, 6.660341d+01, 5.638791d+01, 4.764391d+01, + & 4.017541d+01, 3.381001d+01, 2.836781d+01, 2.373041d+01, + & 1.979160d+01, 1.645710d+01, 1.364340d+01, 1.127690d+01, + & 9.292942d+00, 7.619842d+00, 6.216801d+00, 5.046801d+00, + & 4.076571d+00, 3.276431d+00, 2.620211d+00, 2.084970d+00, + & 1.650790d+00, 1.300510d+00, 1.019440d+00, 7.951341d-01, + & 6.167791d-01, 4.758061d-01, 3.650411d-01, 2.785261d-01, + & 2.113490d-01, 1.594950d-01, 1.197030d-01, 8.934502d-02, + & 6.600001d-02, 4.758501d-02, 3.270000d-02, 2.000000d-02, + & 1.000000d-02 /) + +#elif defined( GEOS_4 ) + + !----------------------------------------------------------------- + ! For GEOS-4, levels 1-14 are "terrain-following" coordinates + ! (i.e. vary with location), and levels 15-55 are fixed pressure + ! levels. The transition pressure is 176.93 hPa, which is the + ! edge between L=14 and L=15. + ! + ! Initialize EDGE_IN with the original 56 Ap values for GEOS-4. + !----------------------------------------------------------------- + EDGE_IN = (/ 0.000000d0, 0.000000d0, 12.704939d0, + & 35.465965d0, 66.098427d0, 101.671654d0, + & 138.744400d0, 173.403183d0, 198.737839d0, + & 215.417526d0, 223.884689d0, 224.362869d0, + & 216.864929d0, 201.192093d0, 176.929993d0, + & 150.393005d0, 127.837006d0, 108.663429d0, + & 92.365662d0, 78.512299d0, 66.603378d0, + & 56.387939d0, 47.643932d0, 40.175419d0, + & 33.809956d0, 28.367815d0, 23.730362d0, + & 19.791553d0, 16.457071d0, 13.643393d0, + & 11.276889d0, 9.292943d0, 7.619839d0, + & 6.216800d0, 5.046805d0, 4.076567d0, + & 3.276433d0, 2.620212d0, 2.084972d0, + & 1.650792d0, 1.300508d0, 1.019442d0, + & 0.795134d0, 0.616779d0, 0.475806d0, + & 0.365041d0, 0.278526d0, 0.211349d0, + & 0.159495d0, 0.119703d0, 0.089345d0, + & 0.066000d0, 0.047585d0, 0.032700d0, + & 0.020000d0, 0.010000d0 /) + +#elif defined( GEOS_3 ) + + !----------------------------------------------------------------- + ! For GEOS-3, this is a pure-sigma grid. + ! Initialize EDGE_IN with the original 49 sigma edges. + !----------------------------------------------------------------- + EDGE_IN = (/ 1.000000d0, 0.997095d0, 0.991200d0, 0.981500d0, + & 0.967100d0, 0.946800d0, 0.919500d0, 0.884000d0, + & 0.839000d0, 0.783000d0, 0.718200d0, 0.647600d0, + & 0.574100d0, 0.500000d0, 0.427800d0, 0.359500d0, + & 0.297050d0, 0.241950d0, 0.194640d0, 0.155000d0, + & 0.122680d0, 0.096900d0, 0.076480d0, 0.060350d0, + & 0.047610d0, 0.037540d0, 0.029600d0, 0.023330d0, + & 0.018380d0, 0.014480d0, 0.011405d0, 0.008975d0, + & 0.007040d0, 0.005500d0, 0.004280d0, 0.003300d0, + & 0.002530d0, 0.001900d0, 0.001440d0, 0.001060d0, + & 0.000765d0, 0.000540d0, 0.000370d0, 0.000245d0, + & 0.000155d0, 9.20000d-5, 4.75000d-5, 1.76800d-5, + & 0.000000d0 /) + +#endif + + ! We have now initialized everything + IS_INIT = .TRUE. + + ! Return to calling program + END SUBROUTINE INIT_TRANSFER + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_TRANSFER +! +!****************************************************************************** +! Subroutine CLEANUP_TRANSFER deallocates the EDGE_IN array. +! (bmy, 9/19/01, 10/31/03) +! +! NOTES: +! (1 ) Renamed SIGE_IN to EDGE_IN to denote that it is not always a sigma +! coordinate (as for GEOS-4). (bmy, 10/31/03) +!****************************************************************************** +! + !================================================================= + ! CLEANUP_TRANSFER begins here! + !================================================================= + IF ( ALLOCATED( EDGE_IN ) ) DEALLOCATE( EDGE_IN ) + + ! Return to calling program + END SUBROUTINE CLEANUP_TRANSFER + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE TRANSFER_MOD diff --git a/code/tropopause.f b/code/tropopause.f new file mode 100644 index 0000000..f312fc7 --- /dev/null +++ b/code/tropopause.f @@ -0,0 +1,90 @@ +! $Id: tropopause.f,v 1.1 2009/06/09 21:51:53 daven Exp $ + SUBROUTINE TROPOPAUSE +! +!****************************************************************************** +! Subroutine TROPOPAUSE defines the tropopause layer in terms of temperature +! lapse rates. (hyl, bmy, 11/30/99, 10/17/06) +! +! NOTES: +! (1 ) Make sure the DO-loops go in the order L-J-I, wherever possible. +! (2 ) Now archive ND55 diagnostic here rather than in DIAG1.F. Also, +! use an allocatable array (AD55) to archive tropopause heights. +! (3 ) HTPAUSE is now a local variable, since it is only used here. +! (4 ) Make LTPAUSE a local variable, since LPAUSE is used to store +! the annual mean tropopause. (bmy, 4/17/00) +! (5 ) Replace PW(I,J) with P(I,J). Also updated comments. (bmy, 10/3/01) +! (6 ) Removed obsolete code from 9/01 and 10/01 (bmy, 10/24/01) +! (7 ) Added polar tropopause for GEOS-3 in #if defined( GEOS_3 ) block +! (bmy, 5/20/02) +! (8 ) Replaced all instances of IM with IIPAR and JM with JJPAR, in order +! to prevent namespace confusion for the new TPCORE (bmy, 6/25/02) +! (9 ) Now use GET_PCENTER from "pressure_mod.f" to compute the pressure +! at the midpoint of box (I,J,L). Also deleted obsolete, commented-out +! code. (dsa, bdf, bmy, 8/21/02) +! (10) Now reference BXHEIGHT and T from "dao_mod.f". Also reference routine +! ERROR_STOP from "error_mod.f" (bmy, 10/15/02) +! (11) Now uses routine GET_YMID from "grid_mod.f" to compute grid box +! latitude. (bmy, 2/3/03) +! (12) Add proper polar tropopause level for GEOS-4 (bmy, 6/18/03) +! (13) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06) +! (14) Get tropopause level from TROPOPAUSE_MOD.F routines (phs, 10/17/06) +!****************************************************************************** +! + ! References to F90 modules. + USE DAO_MOD, ONLY : BXHEIGHT !, T + USE DIAG_MOD, ONLY : AD55 + USE LOGICAL_MOD, ONLY : LVARTROP + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE TROPOPAUSE_MOD, ONLY : GET_TPAUSE_LEVEL + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! LPAUSE +# include "CMN_DIAG" ! Diagnostic switches + + ! Local variables + INTEGER :: I, J, L + REAL*8 :: H(IIPAR,JJPAR,LLPAR) + + !================================================================= + ! TROPOPAUSE begins here! + ! + ! H (in m) is the height of the midpoint of layer L (hyl, 03/28/99) + !================================================================= + + ! Find height of the midpoint of the first level + DO J = 1, JJPAR + DO I = 1, IIPAR + H(I,J,1) = BXHEIGHT(I,J,1) / 2.d0 + ENDDO + ENDDO + + ! Add to H 1/2 of the sum of the two adjacent boxheights + DO L = 1, LLPAR-1 + DO J = 1, JJPAR + DO I = 1, IIPAR + H(I,J,L+1) = H(I,J,L) + + & ( BXHEIGHT(I,J,L) + BXHEIGHT(I,J,L+1) ) / 2.d0 + ENDDO + ENDDO + ENDDO + + !================================================================= + ! ND55: Tropopause level, height [ km ], and pressure [ mb ] + ! Recall that PW(I,J) = PS(I,J) - PTOP + !================================================================= + IF ( ND55 > 0 ) THEN + DO J = 1, JJPAR + DO I = 1, IIPAR + L = GET_TPAUSE_LEVEL( I, J ) + IF ( LVARTROP ) L = L+1 + AD55(I,J,1) = AD55(I,J,1) + L + AD55(I,J,2) = AD55(I,J,2) + H(I,J,L) / 1.0d3 ! m --> km + AD55(I,J,3) = AD55(I,J,3) + GET_PCENTER(I,J,L) + ENDDO + ENDDO + ENDIF + + ! Return to calling program + END SUBROUTINE TROPOPAUSE diff --git a/code/tropopause_mod.f b/code/tropopause_mod.f new file mode 100644 index 0000000..98ea685 --- /dev/null +++ b/code/tropopause_mod.f @@ -0,0 +1,692 @@ +! $Id: tropopause_mod.f,v 1.3 2009/06/18 21:29:43 daven Exp $ + MODULE TROPOPAUSE_MOD +! +!****************************************************************************** +! Module TROPOPAUSE_MOD contains routines and variables for reading and +! returning the value of the annual mean tropopause. (bmy, 8/15/05, 11/14/08) +! +! Module Variables: +! ============================================================================ +! (1 ) LMIN (INTEGER) : Minimum extent of annual mean tropopause +! (2 ) LMAX (INTEGER) : Maximum extent of annual mean tropopause +! (3 ) LPAUSE (INTEGER) : Array for annual mean tropopause +! (4 ) IFLX (INTEGER) : Array for tropopause flags for ND27 (OBSOLETE) +! +! Module Routines: +! ============================================================================ +! (1 ) READ_TROPOPAUSE : Reads annual mean tropopause from disk +! (2 ) GET_MIN_TPAUSE_LEVEL : Returns min extent of ann mean tropopause +! (3 ) GET_MAX_TPAUSE_LEVEL : Returns max extent of ann mean tropopause +! (4 ) GET_TPAUSE_LEVEL : Returns tropopause level at box (I,J) +! (5 ) ITS_IN_THE_TROP : Returns TRUE if box (I,J,L) is in troposphere +! (6 ) ITS_IN_THE_STRAT : Returns TRUE if box (I,J,L) is in stratosphere +! (7 ) INIT_TROPOPAUSE : Allocates and zeroes all module arrays +! (8 ) CLEANUP_TROPOPAUSE : Deallocates all module arrays +! (9 ) COPY_FULL_TROP : for variable tropopause +! (10) SAVE_FULL_TROP : for variable tropopause +! (11) CHECK_VAR_TROP : check value of LLTROP and set LMAX and LMIN +! +! GEOS-CHEM modules referenced by tropopause_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (2 ) comode_mod.f : Module w/ common for ODE +! (3 ) dao_mod.f : Module w/ input fields +! (3 ) directory_mod.f : Module w/ GEOS-CHEM met field and data dirs +! (4 ) error_mod.f : Module w/ NaN, other error check routines +! (6 ) pressure_mod.f : Module w/ routines to get pressure +! (7 ) time_mod.f : Module w/ time routines +! (8 ) transfer_mod.f : Module w/ routines to cast & resize arrays +! +! NOTES: +! (1 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (2 ) Simplify counting of tropospheric boxes (bmy, 11/1/05) +! (3 ) Added case of variable tropopause. +! The definition of the tropopause boxes is different in the two cases. +! They are part of the troposphere in the case of a variable +! troposphere. LMAX, LMIN are the min and max extent of the troposphere +! in that case. (bdf, phs, 1/19/07) +! (4 ) Bug fix: set NCS=NCSURBAN for safety's sake (bmy, 4/25/07) +! (5 ) Updated comments (bmy, 9/18/07) +! (6 ) Bug fix: make ITS_IN_THE_STRAT more robust. (phs, 11/14/08) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "tropopause_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: CLEANUP_TROPOPAUSE + PUBLIC :: CHECK_VAR_TROP + PUBLIC :: COPY_FULL_TROP + PUBLIC :: GET_MIN_TPAUSE_LEVEL + PUBLIC :: GET_MAX_TPAUSE_LEVEL + PUBLIC :: GET_TPAUSE_LEVEL + PUBLIC :: ITS_IN_THE_TROP + PUBLIC :: ITS_IN_THE_STRAT + PUBLIC :: READ_TROPOPAUSE + PUBLIC :: SAVE_FULL_TROP + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Scalars + INTEGER :: LMIN, LMAX + + ! Arrays + INTEGER, ALLOCATABLE :: TROPOPAUSE(:,:) + INTEGER, ALLOCATABLE :: IFLX(:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE COPY_FULL_TROP +! +!****************************************************************************** +! Subroutine COPY_FULL_TROP takes the saved full troposphere and copies +! chemical species into the current troposphere that will be used in SMVGEAR +! for this timestep. (phs, bmy, 9/14/06, 4/25/07) +! +! ROUTINE NEEDED BECAUSE WITH VARIABLE TROPOPAUSE +! JLOOP WILL NOT ALWAYS REFER TO THE SAME (I,J,L) BOX +! +! NOTES: +! (1 ) Very similar to a get_properties of an object. Should probably +! be in COMODE_MOD.F, and called GET_SPECIES_CONCENTRATION (phs) +! (2 ) Bug fix: set NCS=NCSURBAN for safety's sake (bmy, 4/25/07) +!****************************************************************************** +! + ! References to F90 modules + USE COMODE_MOD, ONLY : CSPEC, CSPEC_FULL + USE COMODE_MOD, ONLY : IXSAVE, IYSAVE, IZSAVE + + IMPLICIT NONE + +# include "CMN_SIZE" +# include "comode.h" + + ! Local variables + INTEGER :: JGAS, JLOOP, IX, IY, IZ + INTEGER :: LOCATION(4) + + !================================================================= + ! COPY_FULL_TROP begins here! + !================================================================= + + ! Reset NCS to NCSURBAN for safety's sake (bmy, 4/25/07) + NCS = NCSURBAN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JGAS, JLOOP, IX, IY, IZ ) + + ! Loop over species + DO JGAS = 1, NTSPEC(NCS) + + ! Loop over 1-D grid boxes + DO JLOOP = 1, NTLOOP + + ! 3-D array indices + IX = IXSAVE(JLOOP) + IY = IYSAVE(JLOOP) + IZ = IZSAVE(JLOOP) + + ! Copy from 3-D array + CSPEC(JLOOP,JGAS) = CSPEC_FULL(IX,IY,IZ,JGAS) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE COPY_FULL_TROP + +!------------------------------------------------------------------------------ + + SUBROUTINE SAVE_FULL_TROP +! +!****************************************************************************** +! Subroutine SAVE_FULL_TROP takes the current troposphere and copies chemical +! species into the full troposphere that will be used in SMVGEAR for this +! timestep. (phs, bmy, 9/14/06) +! +! ROUTINE NEEDED BECAUSE WITH VARIABLE TROPOPAUSE +! JLOOP WILL NOT ALWAYS REFER TO THE SAME (I,J,L) BOX +! +! NOTES: +! (1 ) Very similar to a set_properties of an object. Should probably +! be in COMODE_MOD.F, and called SAVE_SPECIES_CONCENTRATION (phs) +! (2 ) Bug fix: set NCS=NCSURBAN for safety's sake! (bmy, 4/25/07) +!****************************************************************************** +! + ! References to F90 modules + USE COMODE_MOD, ONLY : CSPEC, CSPEC_FULL + USE COMODE_MOD, ONLY : IXSAVE, IYSAVE, IZSAVE + + IMPLICIT NONE + +# include "CMN_SIZE" +# include "comode.h" + + ! Local variables + INTEGER :: JGAS, JLOOP, IX, IY, IZ + + !================================================================= + ! SAVE_FULL_TROP begins here! + !================================================================= + + ! Reset NCS to NCSURBAN for safety's sake (bmy, 4/25/07) + NCS = NCSURBAN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( JGAS, JLOOP, IX, IY, IZ ) + + ! Loop over species + DO JGAS = 1, NTSPEC(NCS) + + ! Loop over 1-D grid boxes + DO JLOOP = 1, NTLOOP + + ! 3-D array indices + IX = IXSAVE(JLOOP) + IY = IYSAVE(JLOOP) + IZ = IZSAVE(JLOOP) + + ! Save in 3-D array + CSPEC_FULL(IX,IY,IZ,JGAS) = CSPEC(JLOOP,JGAS) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE SAVE_FULL_TROP + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_VAR_TROP +! +!****************************************************************************** +! Subroutine CHECK_VAR_TROP checks that the entire variable troposphere is +! included in the 1..LLTROP range, and set the LMIN and LMAX to current +! min and max tropopause. (phs, 8/24/06, 1/19/07) +! +! NOTES: +! (1 ) LLTROP is set at the first level entirely above 20 km (phs, 9/29/06) +! (2 ) Fix LPAUSE for CH4 chemistry (phs, 1/19/07) +!****************************************************************************** +! + ! Reference to F90 modules + USE DAO_MOD, ONLY : TROPP + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! LPAUSE, for backwards compatibility + + ! Local Variables + INTEGER :: I, J + REAL*8 :: TPAUSE_LEV(IIPAR,JJPAR) + + !================================================================= + ! CHECK_VAR_TROP begins here! + !================================================================= + + ! set LMIN and LMAX to current min and max tropopause + DO J = 1, JJPAR + DO I = 1, IIPAR + TPAUSE_LEV(I,J) = GET_TPAUSE_LEVEL(I,J) + ENDDO + ENDDO + + LMIN = MINVAL( TPAUSE_LEV ) + LMAX = MAXVAL( TPAUSE_LEV ) + + !### For backwards compatibility during transition (still needed??) + !### LPAUSE is still used by CH4 chemistry and ND27 (phs, 1/19/07) + LPAUSE = TPAUSE_LEV - 1 + + ! check to be sure LLTROP is large enough. + IF ( LLTROP < LMAX ) THEN + WRITE( 6, '(a)' ) 'CHECK_VAR_TROP: LLTROP is set too low!' + WRITE( 6, 10 ) LMAX, LLTROP + 10 FORMAT( 'MAX TROPOSPHERE LEVEL = ', i3, ' and LLTROP = ', i3 ) + WRITE( 6, '(a)' ) 'STOP in TROPOPAUSE_MOD.F!!!' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK_VAR_TROP + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_TROPOPAUSE +! +!****************************************************************************** +! Subroutine READ_TROPOPAUSE reads in the annual mean tropopause. +! (qli, bmy, 12/13/99, 11/1/05) +! +! NOTES: +! (1 ) Call READ_BPCH2 to read in the annual mean tropopause data +! which is stored in binary punch file format. (bmy, 12/13/99) +! (2 ) Now also read integer flags for ND27 diagnostic -- these determine +! how to sum fluxes from boxes adjacent to the annual mean tropoause. +! (qli, bmy, 1/7/00) +! (3 ) Cosmetic changes (bmy, 3/17/00) +! (4 ) Reference F90 module "bpch2_mod" which contains routine "read_bpch2" +! for reading data from binary punch files (bmy, 6/28/00) +! (5 ) Call TRANSFER_2D from "transfer_mod.f" to cast data from REAL*4 to +! INTEGER and also to resize to (IIPAR,JJPAR). ARRAY needs to be of +! size (IGLOB,JGLOB). Also updated comments and made cosmetic changes. +! Removed obsolete variables.(bmy, 9/26/01) +! (6 ) Removed obsolete code from 9/01 (bmy, 10/26/01) +! (7 ) Now read annual mean tropopause files from the ann_mean_trop_200202/ +! subdirectory of DATA_DIR (bmy, 1/24/02) +! (8 ) Eliminated obsolete code from 1/02 (bmy, 2/27/02) +! (9 ) Now write file name to stdout (bmy, 4/3/02) +! (10) Now reference GEOS_CHEM_STOP from "error_mod.f", which frees all +! allocated memory before stopping the run. (bmy, 10/15/02) +! (11) Now call READ_BPCH2 with QUIET=.TRUE. to suppress printing of extra +! info to stdout. Also updated FORMAT strings. (bmy, 3/14/03) +! (12) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +! (13) Now bundled into "tropopause_mod.f' (bmy, 2/10/05) +! (14) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (15) Simplify counting of # of tropospheric boxes (bmy, 11/1/05) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE TRANSFER_MOD, ONLY : TRANSFER_2D + +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! LPAUSE, for backwards compatibility + + ! Local Variables + LOGICAL, SAVE :: FIRST=.TRUE. + INTEGER :: I, J, COUNT + REAL*4 :: ARRAY(IGLOB,JGLOB,1) + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_TROPOPAUSE begins here! + ! + ! Read the annual mean tropopause from disk (binary punch file + ! format). Transfer data into an array of size (IIPAR,JJPAR). + !================================================================= + + ! Allocate arrays + IF ( FIRST ) THEN + CALL INIT_TROPOPAUSE + FIRST = .FALSE. + ENDIF + + ! Create filename + FILENAME = TRIM( DATA_DIR ) // + & 'ann_mean_trop_200202/ann_mean_trop.' // + & GET_NAME_EXT() // '.' // GET_RES_EXT() + + ! Write file name to stdout + WRITE( 6, 110 ) TRIM( FILENAME ) + 110 FORMAT( ' - READ_TROPOPAUSE: Reading ', a ) + + ! Annual mean tropopause is tracer #1 + CALL READ_BPCH2( FILENAME, 'TR-PAUSE', 1, + & 0d0, IGLOB, JGLOB, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Copy from REAL*4 to INTEGER and resize to (IIPAR,JJPAR) + CALL TRANSFER_2D( ARRAY(:,:,1), TROPOPAUSE ) + + !### For backwards compatibility during transition + LPAUSE = TROPOPAUSE + +!----------------------------------------------------------------------------- +! Prior to 2/10/05: +! For now don't read in IFLUX (bmy, 1/2 +! ! Integer flags for ND27 diagnostic is tracer #4 +! CALL READ_BPCH2( FILENAME, 'TR-PAUSE', 4, 0d0, +! & IGLOB, JGLOB, 1, ARRAY, QUIET=.TRUE. ) +! +! ! Copy from REAL*4 to INTEGER and resize to (IIPAR,JJPAR) +! CALL TRANSFER_2D( ARRAY(:,:,1), IFLX ) +!----------------------------------------------------------------------------- + + !================================================================= + ! L < TROPOPAUSE(I,J) are tropospheric boxes + ! L >= TROPOPAUSE(I,J) are stratospheric boxes + ! + ! LMIN = level where minimum extent of the TROPOPAUSE occurs + ! LMAX = level where maximum extent of the TROPOPAUSE occurs + ! + ! LMIN-1 = level where minimum extent of the TROPOSPHERE occurs + ! LMAX-1 = level where maximum extent of the TROPOSPHERE occurs + ! + ! Write LMAX-1 and LMIN-1 to the standard output. + ! + ! Also make sure that LMAX-1 does not exceed LLTROP, since LLTROP + ! is used to dimension the chemistry arrays in "comode.h". + !================================================================= + LMIN = MINVAL( TROPOPAUSE ) + LMAX = MAXVAL( TROPOPAUSE ) + + WRITE( 6, 120 ) LMIN-1 + 120 FORMAT( ' - READ_TROPOPAUSE: Minimum tropospheric extent,', + & ' L=1 to L=', i3 ) + + WRITE( 6, 130 ) LMAX-1 + 130 FORMAT( ' - READ_TROPOPAUSE: Maximum tropospheric extent,', + & ' L=1 to L=', i3 ) + + IF ( LMAX-1 > LLTROP ) THEN + WRITE( 6, '(a)' ) 'READ_TROPOPAUSE: LLTROP is set too low!' + WRITE( 6, 131 ) LMAX-1, LLTROP + 131 FORMAT( 'LMAX = ', i3, ' LLTROP = ', i3 ) + WRITE( 6, '(a)' ) 'STOP in READ_TROPOPAUSE.F!!!' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + !================================================================= + ! Write the number of tropopsheric and stratospheric boxes. + ! Recall that tropospheric boxes extend up to TROPOPAUSE - 1. + !================================================================= + COUNT = SUM( TROPOPAUSE - 1 ) + + WRITE( 6, 140 ) COUNT + 140 FORMAT( ' - READ_TROPOPAUSE: # of tropopsheric boxes: ', i8 ) + + WRITE( 6, 150 ) ( IIPAR * JJPAR * LLPAR ) - COUNT + 150 FORMAT( ' - READ_TROPOPAUSE: # of stratospheric boxes: ', i8 ) + + ! Return to calling program + END SUBROUTINE READ_TROPOPAUSE + +!------------------------------------------------------------------------------ + + FUNCTION GET_MAX_TPAUSE_LEVEL() RESULT( L_MAX ) +! +!****************************************************************************** +! Function GET_MAX_TPAUSE_LEVEL returns GEOS-CHEM level at the highest extent +! of the annual mean tropopause. (bmy, 2/10/05) +! +! NOTES: +!****************************************************************************** +! + ! Function value + INTEGER :: L_MAX + + !================================================================= + ! GET_MAX_TPAUSE_LEVEL begins here! + !================================================================= + L_MAX = LMAX + + ! Return to calling program + END FUNCTION GET_MAX_TPAUSE_LEVEL + +!------------------------------------------------------------------------------ + + FUNCTION GET_MIN_TPAUSE_LEVEL() RESULT( L_MIN ) +! +!****************************************************************************** +! Function GET_MIN_TPAUSE_LEVEL returns GEOS-CHEM level at the lowest extent +! of the annual mean tropopause. (bmy, 2/10/05) +! +! NOTES: +!****************************************************************************** +! + ! Function value + INTEGER :: L_MIN + + !================================================================= + ! GET_MIN_TPAUSE_LEVEL begins here! + !================================================================= + L_MIN = LMIN + + ! Return to calling program + END FUNCTION GET_MIN_TPAUSE_LEVEL + +!------------------------------------------------------------------------------ + + FUNCTION GET_TPAUSE_LEVEL( I, J ) RESULT( L_TP ) +! +!****************************************************************************** +! Function GET_TPAUSE_LEVEL returns the model level L_TP which contains the +! GEOS_CHEM annual mean tropopause at grid box (I,J). Note that L_TP is +! considered to be in the stratosphere. Levels L_TP-1 and below are +! considered to be purely tropospheric levels. (bmy, 8/22/05) +! +! NOTES: +! (1 ) If logical LVARTROP is true (i.e., case of a variable tropopause), +! the tropopause box (i.e., the tropopause level) is the highest purely +! tropospheric box. +!****************************************************************************** +! + + USE DAO_MOD, ONLY : TROPP, PSC2 + USE LOGICAL_MOD, ONLY : LVARTROP + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE PRESSURE_MOD, ONLY : GET_PEDGE + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: I, J + + ! Local variables + INTEGER :: L_TP, L + REAL*8 :: PRESS_BEDGE + + !================================================================= + ! GET_TPAUSE_LEVEL begins here! + !================================================================= + IF ( LVARTROP ) THEN + + L = 1 + DO + !check to find the current tropopause + PRESS_BEDGE = GET_PEDGE(I,J,L) + + IF ( TROPP(I,J) .GE. PRESS_BEDGE ) THEN + L_TP = L-1 ! get_pedge gets edge for BOTTOM of box + EXIT + ENDIF + L = L+1 + + ! THIS TEST IS DUBIOUS since GET_PEDGE will not be defined + ! if L > LLPAR +! IF (L .GT. 1000000) THEN + ! replaced by (phs): + IF ( L .GT. LLPAR ) THEN + WRITE( 6, '(a)' ) 'GET_TPAUSE_LEVEL: CANNOT ' // + & 'FIND T-PAUSE !' + WRITE( 6, 160 ) L + 160 FORMAT( 'L reaches ', i3 ) + WRITE( 6, '(a)' ) 'STOP in GET_TPAUSE_LEVEL' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ENDDO + + ELSE + + L_TP = TROPOPAUSE(I,J) + + ENDIF + +! DEBUG: +! write(6,*) i,j, 'value of tropopause pressure', tropp(i,j) +! write(6,*) 'surface pressure', psc2(i,j) + + + ! Return to calling program + END FUNCTION GET_TPAUSE_LEVEL + +!------------------------------------------------------------------------------ + + FUNCTION ITS_IN_THE_TROP( I, J, L ) RESULT ( IS_TROP ) +! +!****************************************************************************** +! Function ITS_IN_THE_TROP returns TRUE if grid box (I,J,L) lies within +! the troposphere, or FALSE otherwise. (phs, bmy, 2/10/05, 9/14/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : GEOS-CHEM longitude index +! (2 ) J (INTEGER) : GEOS-CHEM latitude index +! (3 ) L (INTEGER) : GEOS-CHEM level index +! +! NOTES: +! (1 ) Modified for variable tropopause (phs, 9/14/06) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : TROPP, PSC2 + USE LOGICAL_MOD, ONLY : LVARTROP + USE PRESSURE_MOD, ONLY : GET_PEDGE + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L + + ! Local variables + REAL*8 :: PRESS_BEDGE + + ! Return value + LOGICAL :: IS_TROP + + !================================================================= + ! ITS_IN_THE_TROP begins here + !================================================================= + IF ( LVARTROP ) THEN + + ! Get bottom pressure edge + PRESS_BEDGE = GET_PEDGE(I,J,L) + + ! Check against actual tropopause pressure + IS_TROP = ( PRESS_BEDGE > TROPP(I,J) ) + + ELSE + + ! Check against annual mean tropopause + IS_TROP = ( L < TROPOPAUSE(I,J) ) + + ENDIF + + ! Return to calling program + END FUNCTION ITS_IN_THE_TROP + +!------------------------------------------------------------------------------ + + FUNCTION ITS_IN_THE_STRAT( I, J, L ) RESULT( IS_STRAT ) +! +!****************************************************************************** +! Function ITS_IN_THE_STRAT returns TRUE if grid box (I,J,L) lies within +! the stratosphere, or FALSE otherwise. (phs, bmy, 2/10/05, 11/14/08) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : GEOS-CHEM longitude index +! (2 ) J (INTEGER) : GEOS-CHEM latitude index +! (3 ) L (INTEGER) : GEOS-CHEM level index +! +! NOTES: +! (1 ) Modified for variable tropopause (phs, 9/14/06) +! (2 ) Now return the opposite value of ITS_IN_THE_TROP. This should help +! to avoid numerical issues. (phs, 11/14/08) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : TROPP, PSC2 + USE LOGICAL_MOD, ONLY : LVARTROP + USE PRESSURE_MOD, ONLY : GET_PEDGE + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L + + ! Local variables + REAL*8 :: PRESS_BEDGE + + ! Return value + LOGICAL :: IS_STRAT + + !================================================================= + ! ITS_IN_THE_STRAT begins here + !================================================================= + + ! Make the algorithm more robust by making ITS_IN_THE_STRAT be the + ! exact opposite of function ITS_IN_THE_TROP. This should avoid + ! numerical issues. (phs, 11/14/08) + IS_STRAT = ( .not. ITS_IN_THE_TROP( I, J, L ) ) + + ! Return to calling program + END FUNCTION ITS_IN_THE_STRAT + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_TROPOPAUSE +! +!****************************************************************************** +! Subroutine INIT_TROPOPAUSE allocates & zeroes module arrays. (bmy, 2/10/05) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" + + INTEGER :: AS + + !================================================================= + ! INIT_TROPOPAUSE + !================================================================= + ALLOCATE( TROPOPAUSE( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TROPOPAUSE' ) + TROPOPAUSE = 0 + + ! For now don't allocate IFLX + !ALLOCATE( IFLX( IIPAR, JJPAR ), STAT=AS ) + !IF ( AS /= 0 ) CALL ALLOC_ERR( 'IFLX' ) + !IFLX = 0 + + ! Return to calling program + END SUBROUTINE INIT_TROPOPAUSE + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_TROPOPAUSE +! +!****************************************************************************** +! Subroutine CLEANUP_TROPOPAUSE deallocates module arrays (bmy, 2/10/05) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_TROPOPAUSE begins here! + !================================================================= + IF ( ALLOCATED( TROPOPAUSE ) ) DEALLOCATE( TROPOPAUSE ) + IF ( ALLOCATED( IFLX ) ) DEALLOCATE( IFLX ) + + ! Return to calling program + END SUBROUTINE CLEANUP_TROPOPAUSE + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE TROPOPAUSE_MOD diff --git a/code/unix_cmds_mod.f b/code/unix_cmds_mod.f new file mode 100644 index 0000000..add6605 --- /dev/null +++ b/code/unix_cmds_mod.f @@ -0,0 +1,49 @@ +! $Id: unix_cmds_mod.f,v 1.1 2009/06/09 21:51:51 daven Exp $ + MODULE UNIX_CMDS_MOD +! +!****************************************************************************** +! Module UNIX_CMDS_MOD contains variables which contain file suffixes and +! Unix command strings that are used to unzip met field data. (bmy, 7/9/04) +! +! Module Variables: +! ============================================================================ +! (1 ) BACKGROUND : String for background operator (' &' in Unix) +! (2 ) REDIRECT : String for redirection operator (' >' in Unix) +! (3 ) REMOVE_CMD : String for remove command ('rm' in Unix) +! (4 ) SEPARATOR : String for dir path separator ('/' in Unix) +! (5 ) SPACE : String for blank spaces (' ' in Unix) +! (6 ) STAR : String for wild card operator ('*' in Unix) +! (7 ) UNZIP_CMD : String for unzip command ('gzcat' in Unix) +! (8 ) A3_SUFFIX : Suffix for DAO A-3 (Average 3h ) met fields +! (9 ) A6_SUFFIX : Suffix for DAO A-6 (Average 6h ) met fields +! (10) I6_SUFFIX : Suffix for DAO I-6 (Instantaneous 6h) met fields +! (11) PH_SUFFIX : Suffix for DAO PHIS (geopotential hts) met fields +! (12) KZZ_SUFFIX : Suffix for DAO KZZ (Average 3h ) met fields +! (13) GRID_SUFFIX : Suffix for grid resolution +! (14) ZIP_SUFFIX : Suffix for denoting compressed files +! +! NOTES: +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + CHARACTER(LEN=255) :: BACKGROUND + CHARACTER(LEN=255) :: REDIRECT + CHARACTER(LEN=255) :: REMOVE_CMD + CHARACTER(LEN=255) :: SEPARATOR + CHARACTER(LEN=255) :: SPACE + CHARACTER(LEN=255) :: UNZIP_CMD + CHARACTER(LEN=255) :: WILD_CARD + CHARACTER(LEN=255) :: A3_SUFFIX + CHARACTER(LEN=255) :: A6_SUFFIX + CHARACTER(LEN=255) :: I6_SUFFIX + CHARACTER(LEN=255) :: PH_SUFFIX + CHARACTER(LEN=255) :: KZZ_SUFFIX + CHARACTER(LEN=255) :: GRID_SUFFIX + CHARACTER(LEN=255) :: ZIP_SUFFIX + + ! End of module + END MODULE UNIX_CMDS_MOD diff --git a/code/update.f b/code/update.f new file mode 100644 index 0000000..de32734 --- /dev/null +++ b/code/update.f @@ -0,0 +1,105 @@ +! $Id: update.f,v 1.1 2009/06/09 21:51:50 daven Exp $ + SUBROUTINE UPDATE +! +!****************************************************************************** +! Subroutine UPDATE updates rxn rates for each timestep for SMVGEAR II. +! (M. Jacobson, 1997, bdf, bmy, 4/18/03) +! +! NOTES: +! (1 ) +!****************************************************************************** +! + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! SMVGEAR II arrays +C +C ********************************************************************* +C ************ WRITTEN BY MARK JACOBSON (1993) ************ +C *** (C) COPYRIGHT, 1993 BY MARK Z. JACOBSON *** +C *** (650) 723-6836 *** +C ********************************************************************* +C +C U U PPPPPPP DDDDDD A TTTTTTT EEEEEEE +C U U P P D D A A T E +C U U PPPPPPP D D A A T EEEEEEE +C U U P D D AAAAAAA T E +C UUUUUUU P DDDDDD A A T EEEEEEE +C +C ********************************************************************* +C * THIS SUBROUTINE UPDATES PHOTORATES AND ARB EMISSIONS RATES FOR * +C * EACH TIME-STEP. PHOTORATES ARE INCLUDED IN FIRST AND PARTIAL * +C * DERIVATIVE EQUATIONS WHILE EMISSIONS RATES ARE INCLUDED IN FIRST * +C * DERIVATE EQUATIONS ONLY. SINCE THE EMISSIONS RATES ARE CONSTANT * +C * FOR A GIVEN TIME STEP AND LOCATION (ALTHOUGH THEY CHANGE EACH * +C * TIME STEP AND LOCATION, THEY ARE PUT INTO THE FIRST DERIVATIVE * +C * TERM OF SUBFUN.F ONLY (NOT INTO PARTIAL DERIVATIVE TERMS. EVERY * +C * INTEGRATION TIME-STEP, EMISSIONS ARE RECALCULATED. * +C ********************************************************************* +C +C ********************************************************************* +C * UPDATE PHOTO-RATES AND OTHER PARMETERS BECAUSE THE TIME CHANGED. * +C * NOTE THAT A TIME CHANGE COULD CORRESPOND TO EITHER A SUCCESSFUL * +C * OR FAILED STEP * +C ********************************************************************* +C RRATE = PRATE1 + XELAPS * (PRATE - PRATE1) +C XELAPS = ELAPSED TIME DURING INTERVAL +C IFPRAT = 1: USE SCALED PHOTORATES FROM photrate.dat (ITESTGEAR.EQ.0) +C = 0: USE PHOTORATES FROM globchem.dat (ITESTGEAR > 0) +C +C ********************************************************************* +C ************** UPDATE PHOTORATES *************** +C ****************** INTERPOLATE BETWEEN TWO VALUES ******************* +C ********************************************************************* +C + ! Local variables + INTEGER J,NKN,KLOOP,I,NK,NH,ISPC1,ISPC2,ISPC3 + + REAL*8 TOFDAY,HOURANG,SINFUNC +C +C ********************************************************************* +C * SET RATES WHERE PHOTOREACTION HAS NO ACTIVE LOSS TERM * +C ********************************************************************* +C JOLD = MAPPL(JOLD) FOR INACTIVE SPECIES +C + DO 80 I = 1, NOLOSP(NCSP) + NK = NKNLOSP(I,NCS) + NKN = NEWFOLD(NK,NCS) + NH = NKN + NALLR + DO 79 KLOOP = 1, KTLOOP + TRATE(KLOOP,NKN) = RRATE(KLOOP,NKN) + TRATE(KLOOP,NH) = -RRATE(KLOOP,NKN) + 79 CONTINUE + 80 CONTINUE +C +C ********************************************************************* +C * PRINT OUT CHEMICAL RATES AND STOP * +C ********************************************************************* +C + IF (IPRATES.EQ.1) THEN + if ( jlooplo == 744 ) then + DO 90 I = 1, NALLRAT(NCS) + NK = NCEQUAT(I,NCS) + NKN = NEWFOLD(NK,NCS) + ISPC1 = IRM(1,NK,NCS) + ISPC2 = IRM(2,NK,NCS) + ISPC3 = IRM(3,NK,NCS) + IF (ISPC3.LT.0) ISPC3 = 0 + IF (ISPC1.GT.NSPEC(NCS)) ISPC1 = 0 + IF (ISPC2.GT.NSPEC(NCS)) ISPC2 = 0 + IF (ISPC3.GT.NSPEC(NCS)) ISPC3 = 0 + WRITE(6,95)I,NK,NKN,NAMENCS(ISPC1,NCS), NAMENCS(ISPC2,NCS), + 1 NAMENCS(ISPC3,NCS), RRATE(1,NKN) + 90 CONTINUE + STOP + endif + ENDIF + 95 FORMAT(I3,1X,I3,1X,I3,1X,3A15,1X,1PE13.6) +C +C ********************************************************************* +C ******************** END OF SUBROUTINE UPDATE.F ********************* +C ********************************************************************* +C + RETURN + END SUBROUTINE UPDATE + diff --git a/code/uvalbedo_mod.f b/code/uvalbedo_mod.f new file mode 100644 index 0000000..108fa76 --- /dev/null +++ b/code/uvalbedo_mod.f @@ -0,0 +1,175 @@ +! $Id: uvalbedo_mod.f,v 1.1 2009/06/09 21:51:51 daven Exp $ + MODULE UVALBEDO_MOD +! +!****************************************************************************** +! Module UVALBEDO_MOD contains variables and routines for reading the UV +! Albedo data from disk (for use w/ the FAST-J photolysis routines). +! (bmy, 4/19/02, 10/3/05) +! +! Module Variables: +! ============================================================================ +! (1 ) UVALBEDO (REAL*8) : Array to hold UV Albedo data from disk +! +! Module Routines: +! ============================================================================ +! (1 ) READ_UVALBEDO : Routine to allocate UVALBEDO array and read data +! (2 ) CLEANUP_UVALBEDO : Routine to deallocate UVALBEDO array +! +! GEOS-CHEM modules referenced by biomass_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module containing routines for binary punch file I/O +! (2 ) directory_mod.f : Module containing GEOS-CHEM data & met field dirs +! (3 ) error_mod.f : Module containing NaN and other error check routines +! (4 ) transfer_mod.f : Module containing routines to cast & resize arrays +! +! NOTES: +! (1 ) Now read uvalbedo file directly from DATA_DIR/uvalbedo_200111 +! subdirectory. (bmy, 4/2/02) +! (2 ) Now divide module header into MODULE PRIVATE, MODULE VARIABLES, and +! MODULE ROUTINES sections. (bmy, 5/28/02) +! (3 ) Now references "error_mod.f" (bmy, 10/15/02) +! (4 ) Minor modification in READ_UVALBEDO (bmy, 3/14/03) +! (5 ) Now references "directory_mod.f" (bmy, 7/20/04) +! (6 ) Bug fix for GCAP grid in READ_UVALBEDO (bmy, 8/16/05) +! (7 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Array for UV albedo data + REAL*8, ALLOCATABLE :: UVALBEDO(:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_UVALBEDO( MONTH ) +! +!****************************************************************************** +! Subroutine READ_UVALBEDO reads in UV albedo data from a binary punch +! file for the given grid, model, and month. (bmy, 2/2/00, 10/3/05) +! +! Arguments as Input: +! ========================================================================== +! (1 ) MONTH (INTEGER) : Current month (1-12) +! (2 ) UVALBEDO (REAL*8 ) : Array with UV albedo data +! +! Reference: +! ========================================================================== +! Herman, J.R and Celarier, E.A., "Earth surface reflectivity climatology +! at 340-380 nm from TOMS data", JGR, Vol. 102, D23, pp. 28003-28011, +! Dec 20, 1997. +! +! NOTES: +! (1 ) Call READ_BPCH2 to read in the UV albedo data from the binary punch +! file. (bmy, 2/2/00) +! (2 ) Cosmetic changes (bmy, 3/17/00) +! (3 ) Reference F90 module "bpch2_mod" which contains routine "read_bpch2" +! for reading data from binary punch files (bmy, 6/28/00) +! (4 ) Remove IOS variable -- it wasn't used (bmy, 9/13/00) +! (5 ) Now use GET_TAU0 to return the TAU0 values for 1985. Also use +! TRANSFER_2D from "transfer_mod.f" to copy data from an array of +! size (IGLOB,JGLOB) to an array of size (IIPAR,JJPAR). ARRAY needs +! to be of size (IGLOB,JGLOB). Also updated comments and made +! cosmetic changes. (bmy, 9/26/01) +! (6 ) Removed obsolete code from 9/01 (bmy, 10/24/01) +! (7 ) Now echo FILENAME to the std output (bmy, 11/15/01) +! (8 ) Bundled into "uvalbedo_mod.f" (bmy, 1/15/02) +! (9 ) Now read uvalbedo file directly from DATA_DIR/uvalbedo_200111 +! subdirectory. (bmy, 4/2/02) +! (10) Now references ALLOC_ERR from "error_mod.f". Also eliminated obsolete +! code from 4/02. Updated comments, cosmetic changes. (bmy, 10/15/02) +! (11) Now call READ_BPCH2 with QUIET=.TRUE. to suppress printing of extra +! info to stdout. Also made cosmetic changes. (bmy, 3/14/03) +! (12) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04) +! (13) Read proper filename for GCAP or GEOS grids (swu, bmy, 8/15/05) +! (14) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRANSFER_MOD, ONLY : TRANSFER_2D + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: MONTH + + ! Local Variables + LOGICAL :: FIRST = .TRUE. + INTEGER :: AS + REAL*4 :: ARRAY(IGLOB,JGLOB,1) + REAL*8 :: XTAU + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_UVALBEDO begins here! + ! + ! Allocate UVALBEDO array on the first call + !================================================================= + IF ( FIRST ) THEN + + ! Allocate UVALBEDO + ALLOCATE( UVALBEDO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'UVALBEDO' ) + + ! Zero UVALBEDO + UVALBEDO(:,:) = 0d0 + + ! Reset FIRST flag + FIRST = .FALSE. + ENDIF + + !================================================================= + ! Read UVALBEDO data from disk + !================================================================= + + ! Create filename + FILENAME = TRIM( DATA_DIR ) // + & 'uvalbedo_200111/uvalbedo.' // GET_NAME_EXT_2D() // + & '.' // GET_RES_EXT() + + ! Echo filename + WRITE( 6, 110 ) TRIM( FILENAME ) + 110 FORMAT( ' - READ_UVALBEDO: Reading ', a ) + + ! Get TAU0 value for first day of the MONTH -- use generic year 1985 + XTAU = GET_TAU0( MONTH, 1, 1985 ) + + ! Read data: UV albedos are tracer #1, category name "UVALBEDO" + CALL READ_BPCH2( FILENAME, 'UVALBEDO', 1, + & XTAU, IGLOB, JGLOB, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Transfer data from REAL*4 to REAL*8 and to size (IIPAR,JJPAR) + CALL TRANSFER_2D( ARRAY(:,:,1), UVALBEDO ) + + ! Return to calling program + END SUBROUTINE READ_UVALBEDO + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_UVALBEDO +! +!****************************************************************************** +! Subroutine CLEANUP_UVALBEDO deallocates the UVALBEDO array (bmy, 1/15/02) +!****************************************************************************** +! + IF ( ALLOCATED( UVALBEDO ) ) DEALLOCATE( UVALBEDO ) + + ! Return to calling program + END SUBROUTINE CLEANUP_UVALBEDO + +!------------------------------------------------------------------------------ + + END MODULE UVALBEDO_MOD diff --git a/code/vistas_anthro_mod.f b/code/vistas_anthro_mod.f new file mode 100644 index 0000000..e4d88eb --- /dev/null +++ b/code/vistas_anthro_mod.f @@ -0,0 +1,582 @@ +! $Id: vistas_anthro_mod.f,v 1.1 2009/06/09 21:51:51 daven Exp $ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: VISTAS_ANTHRO_MOD +! +! !DESCRIPTION: Module VISTAS\_ANTHRO\_MOD contains variables and routines +! to read the VISTAS anthropogenic emissions. (amv, 11/24/2008) +!\\ +!\\ +! !INTERFACE: +! + MODULE VISTAS_ANTHRO_MOD +! +! !USES: +! + USE EPA_NEI_MOD, ONLY : GET_USA_MASK + + IMPLICIT NONE + PRIVATE +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: CLEANUP_VISTAS_ANTHRO + PUBLIC :: EMISS_VISTAS_ANTHRO + PUBLIC :: GET_VISTAS_ANTHRO +! +! !PRIVATE MEMBER FUNCTIONS: +! + PRIVATE :: INIT_VISTAS_ANTHRO + PRIVATE :: VISTAS_SCALE_FUTURE + PRIVATE :: TOTAL_ANTHRO_Tg +! +! !REVISION HISTORY: +! 28 Jan 2009 - P. Le Sager - Initial Version +!EOP +!------------------------------------------------------------------------------ +! +! !PRIVATE DATA MEMBERS: + + ! Arrays for weekday & weekend emissions + REAL*8, ALLOCATABLE :: VISTAS_WD_NOx(:,:) + REAL*8, ALLOCATABLE :: VISTAS_WE_NOx(:,:) + + ! Array for surface area + REAL*8, ALLOCATABLE :: A_CM2(:) + + CONTAINS + +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: GET_VISTAS_ANTHRO +! +! !DESCRIPTION: Function GET\_VISTAS\_ANTHRO returns the VISTAS emission for +! GEOS-Chem grid box (I,J) and tracer N. Emissions can be returned in +! units of [kg/s] or [molec/cm2/s]. (amv, phs, 1/28/09) +!\\ +!\\ +! !INTERFACE: +! + FUNCTION GET_VISTAS_ANTHRO( I, J, N, + & WEEKDAY, MOLEC_CM2_S, KG_S ) + & RESULT( VALUE ) +! +! !USES: +! + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTNOx +! +! !INPUT PARAMETERS: +! + ! Longitude, latitude, and tracer indices + INTEGER, INTENT(IN) :: I, J, N + + ! Return weekday or weekend emissions + LOGICAL, INTENT(IN) :: WEEKDAY + + ! OPTIONAL -- return emissions in [molec/cm2/s] + LOGICAL, INTENT(IN), OPTIONAL :: MOLEC_CM2_S + + ! OPTIONAL -- return emissions in [kg/s] + LOGICAL, INTENT(IN), OPTIONAL :: KG_S +! +! !RETURN VALUE: +! + ! Emissions output + REAL*8 :: VALUE +! +! !REVISION HISTORY: +! 28 Jan 2009 - P. Le Sager - Initial Version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL :: DO_KGS + + !================================================================= + ! GET_VISTA_ANTHRO begins here! + !================================================================= + + ! Initialize + DO_KGS = .FALSE. + + ! Return data in [kg/s] or [molec/cm2/s]? + IF ( PRESENT( KG_S ) ) DO_KGS = KG_S + + IF ( N == IDTNOx ) THEN + + ! NOx [molec/cm2/s] + IF ( WEEKDAY ) THEN + VALUE = VISTAS_WD_NOx(I,J) + ELSE + VALUE = VISTAS_WE_NOx(I,J) + ENDIF + + ELSE + + ! Otherwise return a negative value to indicate + ! that there are no VISTAS emissions for tracer N + VALUE = -1d0 + RETURN + + ENDIF + + !------------------------------ + ! Convert units (if necessary) + !------------------------------ + IF ( DO_KGS ) THEN + + ! Convert from [molec/c,2/s] to [kg/s] + VALUE = VALUE * A_CM2(J) / XNUMOL(N) + + ENDIF + + ! Return to calling program + END FUNCTION GET_VISTAS_ANTHRO +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: EMISS_VISTAS_ANTHRO +! +! !DESCRIPTION: Subroutine EMISS\_VISTAS\_ANTHRO reads the VISTAS emission +! fields at 1x1 resolution and regrids them to the current model resolution. +! (amv, phs, 1/28/09) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE EMISS_VISTAS_ANTHRO +! +! !USES: +! + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE LOGICAL_MOD, ONLY : LFUTURE + USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1 + USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH + USE SCALE_ANTHRO_MOD, ONLY : GET_ANNUAL_SCALAR_1x1 + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! FSCALYR +! +! !REVISION HISTORY: +! 28 Jan 2009 - P. Le Sager - Initial Version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, THISYEAR + INTEGER :: MN, SNo, ScNo + REAL*4 :: ARRAY(I1x1,J1x1,1) + REAL*8 :: GEOS_1x1(I1x1,J1x1,1) + REAL*8 :: SC_1x1(I1x1,J1x1) + REAL*8 :: TAU2002, TAU + CHARACTER(LEN=255) :: FILENAME, VISTAS_DIR + CHARACTER(LEN=4) :: SYEAR, SNAME + CHARACTER(LEN=2) :: SMN + CHARACTER(LEN=1) :: SSMN + + !================================================================= + ! EMISS_VISTAS_ANTHRO begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + CALL INIT_VISTAS_ANTHRO + FIRST = .FALSE. + ENDIF + + VISTAS_DIR = TRIM( DATA_DIR_1x1 ) // 'VISTAS_200811/' + + ! Get emissions year + IF ( FSCALYR < 0 ) THEN + THISYEAR = GET_YEAR() + ELSE + THISYEAR = FSCALYR + ENDIF + + ! cap maximum scaling year + IF ( THISYEAR .gt. 2007 ) THEN + THISYEAR = 2007 + ENDIF + + SNAME = 'NOx' + SNo = 1 + ScNo = 71 + + TAU2002 = GET_TAU0( 1, 1, 2002) + MN = GET_MONTH() + + IF (MN .lt. 10) THEN + WRITE( SSMN, '(i1)' ) MN + FILENAME = TRIM( VISTAS_DIR ) + & // 'Vistas-' // TRIM(SNAME) // '-' + & // SSMN // '.1x1' + ELSE + WRITE( SMN, '(i2)' ) MN + FILENAME = TRIM( VISTAS_DIR ) + & // 'Vistas-' // TRIM(SNAME) // '-' + & // SMN // '.1x1' + ENDIF + + WRITE( SYEAR, '(i4)' ) THISYEAR + + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - EMISS_VISTAS_ANTHRO: Reading ', a ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'ANTHSRCE', SNo, + & TAU2002, I1x1, J1x1, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 before regridding + GEOS_1x1(:,:,1) = ARRAY(:,:,1) + + ! Load ozone season regulation factors + IF (MN .lt. 10) THEN + WRITE( SSMN, '(i1)' ) MN + FILENAME = TRIM( VISTAS_DIR ) + & // 'ARP-SeasonalVariation-' // SYEAR // '-' + & // SSMN // '.1x1' + ELSE + WRITE( SMN, '(i2)' ) MN + FILENAME = TRIM( VISTAS_DIR ) + & // 'ARP-SeasonalVariation-' // SYEAR // '-' + & // SMN // '.1x1' + ENDIF + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'RATIO-2D', ScNo, + & TAU2002, I1x1, J1x1, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Apply Ozone Season Scalars + GEOS_1x1(:,:,1) = GEOS_1x1(:,:,1) * ARRAY(:,:,1) + + ! Apply Annual Scalar + IF ( THISYEAR .ne. 2002 ) THEN + CALL GET_ANNUAL_SCALAR_1x1( ScNo, 2002, + & THISYEAR, SC_1x1 ) + + GEOS_1x1(:,:,1) = GEOS_1x1(:,:,1) * SC_1x1(:,:) + ENDIF + + ! Load/Apply weekend/weekday factors + TAU = GET_TAU0( MN, 1, 1999) + FILENAME = TRIM( VISTAS_DIR ) + & // 'wkend_an_scalar.nei99.geos.1x1' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'WD-WE-$', 2, + & TAU, I1x1, J1x1, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Regrid from GEOS 1x1 --> current model resolution + CALL DO_REGRID_1x1( 'molec/cm2/s', GEOS_1x1 * ARRAY, + & VISTAS_WE_NOx ) + + FILENAME = TRIM( VISTAS_DIR ) + & // 'wkday_an_scalar.nei99.geos.1x1' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'WD-WE-$', 1, + & TAU, I1x1, J1x1, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Regrid from GEOS 1x1 --> current model resolution + CALL DO_REGRID_1x1( 'molec/cm2/s', GEOS_1x1 * ARRAY, + & VISTAS_WD_NOx ) + + !-------------------------- + ! Compute future emissions + !-------------------------- + IF ( LFUTURE ) THEN + CALL VISTAS_SCALE_FUTURE + ENDIF + + !-------------------------- + ! Print emission totals + !-------------------------- + CALL TOTAL_ANTHRO_Tg( THISYEAR, MN ) + + ! Return to calling program + END SUBROUTINE EMISS_VISTAS_ANTHRO +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: VISTAS_SCALE_FUTURE +! +! !DESCRIPTION: Subroutine VISTAS\_SCALE\_FUTURE applies the IPCC future scale +! factors to the VISTAS anthropogenic emissions. (amv, phs, 1/28/09) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE VISTAS_SCALE_FUTURE +! +! !USES: +! + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NOxff + +# include "CMN_SIZE" ! Size parameters +! +! !REVISION HISTORY: +! 28 Jan 2009 - P. Le Sager - Initial Version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: I, J + + !================================================================= + ! VISTAS_SCALE_FUTURE begins here! + !================================================================= + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Future NOx [kg NO2/yr] + VISTAS_WE_NOx(I,J) = VISTAS_WE_NOx(I,J) + & * GET_FUTURE_SCALE_NOxff( I, J ) + VISTAS_WD_NOx(I,J) = VISTAS_WD_NOx(I,J) + & * GET_FUTURE_SCALE_NOxff( I, J ) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE VISTAS_SCALE_FUTURE +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: TOTAL_ANTHRO_TG +! +! !DESCRIPTION: Subroutine TOTAL\_ANTHRO\_TG prints the totals for the +! anthropogenic emissions of NOx. (phs, 1/28/09) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE TOTAL_ANTHRO_TG( YEAR, THISMONTH ) +! +! !USES: +! + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TRACER_MOD, ONLY : TRACER_MW_KG + USE TRACERID_MOD, ONLY : IDTNOX + +# include "CMN_SIZE" ! Size parameters +! +! !INPUT PARAMETERS: +! + ! Year and month of data for which to compute totals + INTEGER, INTENT(IN) :: YEAR, THISMONTH +! +! !REVISION HISTORY: +! 28 Jan 2009 - P. Le Sager - Initial Version +! +! !REMARKS: +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: I, J + REAL*8 :: WD_NOX, WE_NOX, F_NOX, A + CHARACTER(LEN=3) :: UNIT + + ! Days per month + INTEGER :: D(12) = (/ 31, 28, 31, 30, 31, 30, + & 31, 31, 30, 31, 30, 31 /) + + !================================================================= + ! TOTAL_ANTHRO_TG begins here! + !================================================================= + + WD_NOX = 0d0 + WE_NOX = 0d0 + F_NOX = TRACER_MW_KG(IDTNOX ) + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Surface area [cm2] * seconds in this month / AVOGADRO's number + ! Also multiply by the factor 1d-9 to convert kg to Tg + A = GET_AREA_CM2( J ) * ( D(THISMONTH) * 86400d-9 ) / 6.0225d23 + + ! Loop over longitudes + DO I = 1, IIPAR + + ! Weekday avg emissions + WD_NOX = WD_NOX + VISTAS_WD_NOX (I,J) * A * F_NOX + + ! Weekend avg emissions + WE_NOX = WE_NOX + VISTAS_WE_NOX (I,J) * A * F_NOX + + ENDDO + ENDDO + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, 100 ) + 100 FORMAT( 'VISTAS U S A E M I S S I O N S', / ) + + ! Weekday avg anthro + WRITE( 6, '(a)' ) + WRITE( 6, 110 ) 'NOx ', THISMONTH, WD_NOX, ' ' + 110 FORMAT( 'Total weekday avg anthro ', a4, ' for 1999/', + & i2.2, ': ', f13.6, ' Tg', a2 ) + + ! Weekend avg anthro + WRITE( 6, '(a)' ) + WRITE( 6, 120 ) 'NOx ', THISMONTH, WE_NOX, ' ' + 120 FORMAT( 'Total weekend avg anthro ', a4, ' for 1999/', + & i2.2, ': ', f13.6, ' Tg', a2 ) + + ! Return to calling program + END SUBROUTINE TOTAL_ANTHRO_Tg +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: INIT_VISTAS_ANTHRO +! +! !DESCRIPTION: Subroutine INIT\_VISTAS\_ANTHRO allocates and zeroes all +! module arrays. (phs, 1/28/09) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE INIT_VISTAS_ANTHRO +! +! !USES: +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LVISTAS + +# include "CMN_SIZE" ! Size parameters +! +! !REVISION HISTORY: +! 28 Jan 2009 - P. Le Sager - Initial Version +! +! !REMARKS: +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: AS, J + + !================================================================= + ! INIT_VISTAS_ANTHRO begins here! + !================================================================= + + ! Return if LVISTAS is false + IF ( .not. LVISTAS ) RETURN + + !-------------------------------------------------- + ! Allocate and zero arrays for emissions + !-------------------------------------------------- + + ALLOCATE( VISTAS_WD_NOx( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'VISTAS_WD_NOx' ) + VISTAS_WD_NOx = 0d0 + + ALLOCATE( VISTAS_WE_NOx( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'VISTAS_WE_NOx' ) + VISTAS_WE_NOx = 0d0 + + !--------------------------------------------------- + ! Pre-store array for grid box surface area in cm2 + !--------------------------------------------------- + + ! Allocate array + ALLOCATE( A_CM2( JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'A_CM2' ) + + ! Fill array + DO J = 1, JJPAR + A_CM2(J) = GET_AREA_CM2( J ) + ENDDO + + ! Return to calling program + END SUBROUTINE INIT_VISTAS_ANTHRO +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: CLEANUP_VISTAS_ANTHRO +! +! !DESCRIPTION: Subroutine CLEANUP\_VISTAS\_ANTHRO deallocates all module +! arrays. (phs, 1/28/09) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE CLEANUP_VISTAS_ANTHRO +! +! !REVISION HISTORY: +! 28 Jan 2009 - P. Le Sager - Initial Version +!EOP +!------------------------------------------------------------------------------ +!BOC + !================================================================= + ! CLEANUP_STREETS begins here! + !================================================================= + IF ( ALLOCATED( A_CM2 ) ) DEALLOCATE( A_CM2 ) + IF ( ALLOCATED( VISTAS_WD_NOx ) ) DEALLOCATE( VISTAS_WD_NOx ) + IF ( ALLOCATED( VISTAS_WE_NOx ) ) DEALLOCATE( VISTAS_WE_NOx ) + + ! Return to calling program + END SUBROUTINE CLEANUP_VISTAS_ANTHRO + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE VISTAS_ANTHRO_MOD +!EOC diff --git a/code/xltmmp.f b/code/xltmmp.f new file mode 100644 index 0000000..555fe98 --- /dev/null +++ b/code/xltmmp.f @@ -0,0 +1,49 @@ +! $Id: xltmmp.f,v 1.1 2009/06/09 21:51:53 daven Exp $ + FUNCTION XLTMMP( I, J, IJLOOP ) RESULT( VALUE ) +! +!****************************************************************************** +! The new XLTMMP passes the value of the DAO meterological field +! TS(IIPAR,JJPAR) back to the calling subroutine. This preserves the +! functionality of the H/G/I CTM function XLTMMP. (bmy, 1/30/98, 8/4/05) +! +! NOTES +! (1 ) XLTMMP is written in Fixed-Form Fortran 90. +! (2 ) I, J are the long/lat indices of the grid box. IJLOOP is passed +! in order to maintain compatibility with the H/G/I subroutines, +! but is not used. +! (3 ) TS is passed to XLTMMP via the "CMN_TS" include file. +! (4 ) Use C-preprocessor #include statement to include CMN_SIZE, which +! has IIPAR, JJPAR, LLPAR, IGLOB, JGLOB, LGLOB. +! (4 ) Now reference TS from "dao_mod.f" instead of from common block +! header file "CMN_TS". (bmy, 6/23/00) +! (5 ) Eliminated obsolete code from 6/23/00 (bmy, 8/31/00) +! (6 ) Now declare XLTMMP as REAL*8 w/in program body. Also updated +! comments. (bmy, 9/26/01) +! (7 ) Remove obsolete commented out code from 9/01 (bmy, 10/24/01) +! (8 ) IJLOOP is now not declared optional...this facilitates compiling with +! -C on Altix (psk, bmy, 7/20/04) +! (9 ) Now make IJLOOP an optional argument; it's only kept for backwards +! compatibility w/ older code (bmy, 8/4/05) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : TS + + IMPLICIT NONE + +# include "CMN_SIZE" + + ! Arguments + INTEGER, INTENT(IN) :: I, J + INTEGER, INTENT(IN), OPTIONAL :: IJLOOP + + ! Function value + REAL*8 :: VALUE + + !================================================================= + ! XLTMMP begins here! + !================================================================= + VALUE = TS(I,J) + + ! Return to calling program + END FUNCTION XLTMMP diff --git a/code/xtra_read_mod.f b/code/xtra_read_mod.f new file mode 100644 index 0000000..d7fff03 --- /dev/null +++ b/code/xtra_read_mod.f @@ -0,0 +1,664 @@ +! $ Id: xtra_read_mod.f v2.2 2005/4/20 21:17:00 tmf Exp $ + MODULE XTRA_READ_MOD +! +!****************************************************************************** +! Module XTRA_READ_MOD contains routines that unzip, open, and read the +! GEOS-CHEM XTRA (avg 3-hour) met fields from disk. (dsa, tmf, bmy, 10/20/05) +! +! Module Routines: +! ========================================================================= +! (1 ) UNZIP_XTRA_FIELDS : Unzips & copies met field files to a temp dir +! (2 ) DO_OPEN_XTRA : Returns TRUE if it's time to read XTRA fields +! (3 ) OPEN_XTRA_FIELDS : Opens met field files residing in the temp dir +! (4 ) GET_XTRA_FIELDS : Wrapper for routine READ_XTRA +! (5 ) GET_N_XTRA : Returns # of XTRA fields for each DAO data set +! (6 ) CHECK_TIME : Tests if XTRA met field timestamps = current time +! (7 ) READ_XTRA : Reads XTRA fields from disk +! (8 ) XTRA_CHECK : Checks if we have found all of the XTRA fields +! +! GEOS-CHEM modules referenced by xtra_read_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (2 ) dao_mod.f : Module w/ arrays for DAO met fields +! (3 ) diag_mod.f : Module w/ GEOS-CHEM diagnostic arrays +! (4 ) directory_mod.f : Module w/ GEOS-CHEM data & met field dirs +! (5 ) error_mod.f : Module w/ NaN and other error check routines +! (6 ) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (7 ) file_mod.f : Module w/ file unit #'s and error checks +! (8 ) time_mod.f : Module w/ routines for computing time & date +! (9 ) transfer_mod.f : Module w/ routines to cast & resize arrays +! (10) unix_cmds_mod.f : Module w/ Unix commands for unzipping etc. +! +! NOTES: +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "xtra_read_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: GET_XTRA_FIELDS + PUBLIC :: OPEN_XTRA_FIELDS + PUBLIC :: UNZIP_XTRA_FIELDS + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE UNZIP_XTRA_FIELDS( OPTION, NYMD ) +! +!***************************************************************************** +! Subroutine UNZIP_XTRA_FIELDS invokes a FORTRAN system call to uncompress +! GEOS-CHEM GEOS-3 XTRA met field files and store the uncompressed data in a +! temporary directory, where GEOS-CHEM can read them. The original data +! files are not disturbed. (dsa, tmf, bmy, 10/20/05) +! +! Arguments as input: +! =========================================================================== +! (1 ) OPTION (CHAR*(*)) : Option +! (2 ) NYMD (INTEGER ) : YYYYMMDD of XTRA file to be unzipped (optional) +! +! NOTES: +!***************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT + USE DIRECTORY_MOD, ONLY : DATA_DIR, GEOS_3_DIR, TEMP_DIR + USE ERROR_MOD, ONLY : ERROR_STOP + USE TIME_MOD, ONLY : EXPAND_DATE + USE UNIX_CMDS_MOD, ONLY : BACKGROUND, REDIRECT, REMOVE_CMD + USE UNIX_CMDS_MOD, ONLY : UNZIP_CMD, WILD_CARD, ZIP_SUFFIX + +# include "CMN_SIZE" + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: OPTION + INTEGER, OPTIONAL, INTENT(IN) :: NYMD + + ! Local variables + CHARACTER(LEN=255) :: XTRA_STR, GEOS_DIR + CHARACTER(LEN=255) :: XTRA_FILE_GZ, XTRA_FILE + CHARACTER(LEN=255) :: UNZIP_BG, UNZIP_FG + CHARACTER(LEN=255) :: REMOVE_ALL, REMOVE_DATE + + !================================================================= + ! UNZIP_XTRA_FIELDS begins here! + !================================================================= + IF ( PRESENT( NYMD ) ) THEN + + ! Strings for directory & filename + GEOS_DIR = TRIM( GEOS_3_DIR ) + XTRA_STR = 'YYYYMMDD.xtra.' // GET_RES_EXT() + + ! Replace date tokens + CALL EXPAND_DATE( GEOS_DIR, NYMD, 000000 ) + CALL EXPAND_DATE( XTRA_STR, NYMD, 000000 ) + + ! Location of zipped XTRA file in data dir + XTRA_FILE_GZ = TRIM( DATA_DIR ) // TRIM( GEOS_DIR ) // + & TRIM( XTRA_STR ) // TRIM( ZIP_SUFFIX ) + + ! Location of unzipped XTRA file in temp dir + XTRA_FILE = TRIM( TEMP_DIR ) // TRIM( XTRA_STR ) + + ! Remove XTRA files for this date from temp dir + REMOVE_DATE = TRIM( REMOVE_CMD ) // ' ' // + & TRIM( TEMP_DIR ) // TRIM( XTRA_STR ) + + !============================================================== + ! Define the foreground and background UNZIP commands + !============================================================== + + ! Foreground unzip + UNZIP_FG = TRIM( UNZIP_CMD ) // ' ' // TRIM( XTRA_FILE_GZ ) // + & TRIM( REDIRECT ) // ' ' // TRIM( XTRA_FILE ) + + ! Background unzip + UNZIP_BG = TRIM( UNZIP_FG ) // TRIM( BACKGROUND ) + ENDIF + + !================================================================= + ! Define command to remove all XTRA files from the TEMP dir + !================================================================= + REMOVE_ALL = TRIM( REMOVE_CMD ) // ' ' // TRIM( TEMP_DIR ) // + & TRIM( WILD_CARD ) // '.xtra.' // TRIM( WILD_CARD ) + + !================================================================= + ! Perform an F90 system call to do the desired operation + !================================================================= + SELECT CASE ( TRIM( OPTION ) ) + + ! Unzip XTRA fields in the Unix foreground + CASE ( 'unzip foreground' ) + WRITE( 6, 100 ) TRIM( XTRA_FILE_GZ ) + CALL SYSTEM( TRIM( UNZIP_FG ) ) + + ! Unzip XTRA fields in the Unix background + CASE ( 'unzip background' ) + WRITE( 6, 100 ) TRIM( XTRA_FILE_GZ ) + CALL SYSTEM( TRIM( UNZIP_BG ) ) + + ! Remove XTRA field for this date in temp dir + CASE ( 'remove date' ) + WRITE( 6, 110 ) TRIM( XTRA_FILE ) + CALL SYSTEM( TRIM( REMOVE_DATE ) ) + + ! Remove all XTRA fields in temp dir + CASE ( 'remove all' ) + WRITE( 6, 120 ) TRIM( REMOVE_ALL ) + CALL SYSTEM( TRIM( REMOVE_ALL ) ) + + ! Error -- bad option! + CASE DEFAULT + CALL ERROR_STOP( 'Invalid value for OPTION!', + & 'UNZIP_XTRA_FIELDS (xtra_read_mod.f)' ) + + END SELECT + + ! FORMAT strings + 100 FORMAT( ' - Unzipping: ', a ) + 110 FORMAT( ' - Removing: ', a ) + 120 FORMAT( ' - About to execute command: ', a ) + + ! Return to calling program + END SUBROUTINE UNZIP_XTRA_FIELDS + +!------------------------------------------------------------------------------ + + FUNCTION DO_OPEN_XTRA( NYMD, NHMS ) RESULT( DO_OPEN ) +! +!****************************************************************************** +! Function DO_OPEN_XTRA returns TRUE if is time to open the XTRA met field +! file or FALSE otherwise. This prevents us from opening a file which has +! already been opened. (dsa, tmf, bmy, 10/20/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NYMD (INTEGER) : YYYYMMDD +! (2 ) NHMS (INTEGER) : and HHMMSS to be tested for A-3 file open +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: NYMD, NHMS + + ! Local variables + LOGICAL :: DO_OPEN + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER, SAVE :: LASTNYMD = -1 + INTEGER, SAVE :: LASTNHMS = -1 + + !================================================================= + ! DO_OPEN_XTRA begins here! + !================================================================= + + ! Initialize + DO_OPEN = .FALSE. + + ! Return if we have already opened the file + IF ( NYMD == LASTNYMD .and. NHMS == LASTNHMS ) THEN + DO_OPEN = .FALSE. + GOTO 999 + ENDIF + + ! Open XTRA file if it's 00:00 GMT, or on the first call + IF ( NHMS == 000000 .or. FIRST ) THEN + DO_OPEN = .TRUE. + GOTO 999 + ENDIF + + !================================================================= + ! Reset quantities for next call + !================================================================= + 999 CONTINUE + LASTNYMD = NYMD + LASTNHMS = NHMS + FIRST = .FALSE. + + ! Return to calling program + END FUNCTION DO_OPEN_XTRA + +!------------------------------------------------------------------------------ + + SUBROUTINE OPEN_XTRA_FIELDS( NYMD, NHMS ) +! +!****************************************************************************** +! Subroutine OPEN_XTRA_FIELDS opens the XTRA met fields file for date NYMD +! and time NHMS. (dsa, tmf, bmy, 10/20/05) +! +! Arguments as input: +! =========================================================================== +! (1 ) NYMD (INTEGER) : YYYYMMDD +! (2 ) NHMS (INTEGER) : and HHMMSS timestamps for XTRA file +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_RES_EXT + USE DIRECTORY_MOD, ONLY : DATA_DIR, GEOS_3_DIR, TEMP_DIR + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LUNZIP + USE FILE_MOD, ONLY : IU_XT, IOERROR, FILE_EXISTS + USE TIME_MOD, ONLY : EXPAND_DATE + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: NYMD, NHMS + + ! Local variables + LOGICAL :: DO_OPEN + LOGICAL :: IT_EXISTS + INTEGER :: IOS + CHARACTER(LEN=8) :: IDENT + CHARACTER(LEN=255) :: XTRA_FILE + CHARACTER(LEN=255) :: GEOS_DIR + CHARACTER(LEN=255) :: PATH + + !================================================================= + ! OPEN_XTRA_FIELDS begins here! + !================================================================= + + ! Open XTRA fields at the proper time, or on the first call + IF ( DO_OPEN_XTRA( NYMD, NHMS ) ) THEN + + ! Strings for directory & filename + GEOS_DIR = TRIM( GEOS_3_DIR ) + XTRA_FILE = 'YYYYMMDD.xtra.' // GET_RES_EXT() + + ! Replace date tokens + CALL EXPAND_DATE( XTRA_FILE, NYMD, NHMS ) + CALL EXPAND_DATE( GEOS_DIR, NYMD, NHMS ) + + ! If unzipping, open GEOS-4 file in TEMP dir + ! If not unzipping, open GEOS-4 file in DATA dir + IF ( LUNZIP ) THEN + PATH = TRIM( TEMP_DIR ) // TRIM( XTRA_FILE ) + ELSE + PATH = TRIM( DATA_DIR ) // + & TRIM( GEOS_DIR ) // TRIM( XTRA_FILE ) + ENDIF + + ! Close previously opened XTRA file + CLOSE( IU_XT ) + + ! Make sure the file unit is valid before we open the file + IF ( .not. FILE_EXISTS( IU_XT ) ) THEN + CALL ERROR_STOP( 'Could not find file!', + & 'OPEN_XTRA_FIELDS (xtra_read_mod.f)' ) + ENDIF + + ! Open the file + OPEN( UNIT = IU_XT, FILE = TRIM( PATH ), + & STATUS = 'OLD', ACCESS = 'SEQUENTIAL', + & FORM = 'UNFORMATTED', IOSTAT = IOS ) + + IF ( IOS /= 0 ) THEN + CALL IOERROR( IOS, IU_XT, 'open_xtra_fields:1' ) + ENDIF + + ! Echo info + WRITE( 6, 100 ) TRIM( PATH ) + 100 FORMAT( ' - Opening: ', a ) + + ENDIF + + ! Return to calling program + END SUBROUTINE OPEN_XTRA_FIELDS + +!------------------------------------------------------------------------------ + + SUBROUTINE GET_XTRA_FIELDS( NYMD, NHMS ) +! +!****************************************************************************** +! Subroutine GET_XTRA_FIELDS is a wrapper for routine READ_XTRA. +! GET_XTRA_FIELDS calls READ_XTRA properly for reading the GEOS-3 met data +! set. (dsa, tmf, bmy, 10/20/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NYMD (INTEGER) : YYYYMMDD +! (2 ) NHMS (INTEGER) : and HHMMSS of XTRA fields to be read from disk +! +! NOTES: +! (1 ) Now extract only PARDR, PARDF for MEGAN biogenics inventory and SNOW +! for dust emissions from GEOS3. (tmf, 6/23/05) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : PARDR, PARDF, SNOW + USE FILE_MOD, ONLY : IU_XT + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: NYMD, NHMS + + ! Local variables + INTEGER, SAVE :: LASTNYMD = -1, LASTNHMS = -1 + + !================================================================= + ! GET_XTRA_FIELDS begins here! + !================================================================= + + ! Skip over previously-read XTRA fields + IF ( NYMD == LASTNYMD .and. NHMS == LASTNHMS ) THEN + WRITE( 6, 100 ) NYMD, NHMS + 100 FORMAT( ' - XTRA met fields for NYMD, NHMS = ', + & i8.8, 1x, i6.6, ' have been read already' ) + RETURN + ENDIF + + ! Read PARDR, PARDF fields + CALL READ_XTRA( NYMD=NYMD, NHMS=NHMS, + & PARDR=PARDR, PARDF=PARDF, SNOW=SNOW ) + + ! Save NYMD, NHMS for next call + LASTNYMD = NYMD + LASTNHMS = NHMS + + ! Return to MAIN program + END SUBROUTINE GET_XTRA_FIELDS + +!--------------------------------------------------------------------------- + + FUNCTION CHECK_TIME( XYMD, XHMS, NYMD, NHMS ) RESULT( ITS_TIME ) +! +!****************************************************************************** +! Function CHECK_TIME checks to see if the timestamp of the XTRA field just +! read from disk matches the current time. If so, then it's time to return +! the XTRA field to the calling program. (dsa, tmf, bmy, 10/20/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) XYMD (REAL*4 or INTEGER) : (YY)YYMMDD timestamp for A-3 field in file +! (2 ) XHMS (REAL*4 or INTEGER) : HHMMSS timestamp for A-3 field in file +! (3 ) NYMD (INTEGER ) : YYYYMMDD at which A-3 field is to be read +! (4 ) NHMS (INTEGER ) : HHMMSS at which A-3 field is to be read +! +! NOTES: +!****************************************************************************** +! +# include "CMN_SIZE" + + ! Arguments + INTEGER, INTENT(IN) :: XYMD, XHMS, NYMD, NHMS + + ! Function value + LOGICAL :: ITS_TIME + + !================================================================= + ! GEOS-3, GEOS-4: XYMD and XHMS are integers + !================================================================= + IF ( XYMD == NYMD .AND. XHMS == NHMS ) THEN + ITS_TIME = .TRUE. + ELSE + ITS_TIME = .FALSE. + ENDIF + + ! Return to calling program + END FUNCTION CHECK_TIME + +!----------------------------------------------------------------------------- + + SUBROUTINE READ_XTRA( NYMD, NHMS, + & PARDR, PARDF, TSKIN, LAI, + & EVAP, RADLWG, SNOW ) +! +!****************************************************************************** +! Subroutine READ_XTRA reads GEOS-3 XTRA (3-hr avg) fields from disk. +! (dsa, tmf, bmy, 10/20/05) +! +! Arguments as input: +! ============================================================================ +! (1 ) NYMD : YYYYMMDD +! (2 ) NHMS : and HHMMSS of XTRA met fields to be accessed +! +! XTRA Met Fields as Output: +! ============================================================================ +! (1 ) PARDF : (2-D) GMAO Photosyn active diffuse radiation [W/m2] +! (2 ) PARDR : (2-D) GMAO Photosyn active direct radiation [W/m2] +! (3 ) TSKIN : (2-D) GMAO Surface ground/sea surface temp [K] +! (4 ) LAI : (2-D) GMAO Leaf area indices [unitless] +! (5 ) EVAP : (2-D) GMAO Evaporation [mm/day] +! (6 ) RADLWG : (2-D) GMAO Net upward LW rad at the ground [W/m2] +! (7 ) SNOW : (2-D) GMAO Snow cover (H2O equivalent) [mm H2O] +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE DIAG_MOD, ONLY : AD67 + USE FILE_MOD, ONLY : IOERROR, IU_XT + USE TIME_MOD, ONLY : SET_CT_XTRA, TIMESTAMP_STRING + USE TRANSFER_MOD, ONLY : TRANSFER_2D, TRANSFER_TO_1D + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND67 + + ! Arguments + INTEGER, INTENT(IN) :: NYMD, NHMS + REAL*8, INTENT(OUT), OPTIONAL :: PARDR (IIPAR,JJPAR) + REAL*8, INTENT(OUT), OPTIONAL :: PARDF (IIPAR,JJPAR) + REAL*8, INTENT(OUT), OPTIONAL :: TSKIN (IIPAR,JJPAR) + REAL*8, INTENT(OUT), OPTIONAL :: LAI (IIPAR,JJPAR) + REAL*8, INTENT(OUT), OPTIONAL :: EVAP (IIPAR,JJPAR) + REAL*8, INTENT(OUT), OPTIONAL :: RADLWG(IIPAR,JJPAR) + REAL*8, INTENT(OUT), OPTIONAL :: SNOW (IIPAR,JJPAR) + + ! Local Variables + INTEGER :: I, IJLOOP, IOS, J + INTEGER :: N_XTRA, NFOUND + INTEGER :: XYMD, XHMS + REAL*4 :: Q2(IGLOB,JGLOB) + CHARACTER(LEN=8) :: NAME + CHARACTER(LEN=16) :: STAMP + + !================================================================= + ! READ_XTRA begins here! + !================================================================= + + ! Get the number of XTRA fields stored in this data set + N_XTRA = 7 + + ! Zero the number of A-3 fields that we have found + NFOUND = 0 + + !================================================================= + ! Read the XTRA fields from disk + !================================================================= + DO + + ! Read the XTRA field name + READ( IU_XT, IOSTAT=IOS ) NAME + + ! End of file test -- make sure we have found all fields + IF ( IOS < 0 ) THEN + CALL XTRA_CHECK( NFOUND, N_XTRA ) + EXIT + ENDIF + + ! IOS > 0: True I/O error; stop w/ err msg + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_XT, 'read_xtra:1' ) + + ! CASE statement for XTRA fields + SELECT CASE ( TRIM( NAME ) ) + + !-------------------------------- + ! PARDR: Photosyn active direct radiation + !-------------------------------- + CASE ( 'PARDR' ) + READ( IU_XT, IOSTAT=IOS ) XYMD, XHMS, Q2 + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_XT, 'read_xtra:2' ) + + IF ( CHECK_TIME( XYMD, XHMS, NYMD, NHMS ) ) THEN + IF ( PRESENT( PARDR ) ) CALL TRANSFER_2D( Q2, PARDR ) + NFOUND = NFOUND + 1 + ENDIF + + !-------------------------------- + ! PARDF: Photosyn active diffuse radiation + !-------------------------------- + CASE ( 'PARDF' ) + READ( IU_XT, IOSTAT=IOS ) XYMD, XHMS, Q2 + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_XT, 'read_xtra:3' ) + + IF ( CHECK_TIME( XYMD, XHMS, NYMD, NHMS ) ) THEN + IF ( PRESENT( PARDF ) ) CALL TRANSFER_2D( Q2, PARDF ) + NFOUND = NFOUND + 1 + ENDIF + + !-------------------------------- + ! TSKIN, TGROUND: Surface ground/sea surface temp + !-------------------------------- + CASE ( 'TSKIN', 'TGROUND' ) + READ( IU_XT, IOSTAT=IOS ) XYMD, XHMS, Q2 + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_XT, 'read_xtra:4' ) + + IF ( CHECK_TIME( XYMD, XHMS, NYMD, NHMS ) ) THEN + IF ( PRESENT( TSKIN ) ) CALL TRANSFER_2D( Q2, TSKIN ) + NFOUND = NFOUND + 1 + ENDIF + + !-------------------------------- + ! EVAP: Evaporation + !-------------------------------- + CASE ( 'EVAP' ) + READ( IU_XT, IOSTAT=IOS ) XYMD, XHMS, Q2 + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_XT, 'read_xtra:5' ) + + IF ( CHECK_TIME( XYMD, XHMS, NYMD, NHMS ) ) THEN + IF ( PRESENT( EVAP ) ) CALL TRANSFER_2D( Q2, EVAP ) + NFOUND = NFOUND + 1 + ENDIF + + !-------------------------------- + ! LAI: Leaf area indices + !-------------------------------- + CASE ( 'LAI' ) + READ( IU_XT, IOSTAT=IOS ) XYMD, XHMS, Q2 + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_XT, 'read_xtra:6' ) + + IF ( CHECK_TIME( XYMD, XHMS, NYMD, NHMS ) ) THEN + IF ( PRESENT( LAI ) ) CALL TRANSFER_2D( Q2, LAI ) + NFOUND = NFOUND + 1 + ENDIF + + !-------------------------------- + ! SNOW: Snow cover (H2O equivalent) + !-------------------------------- + CASE ( 'SNOW' ) + READ( IU_XT, IOSTAT=IOS ) XYMD, XHMS, Q2 + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_XT, 'read_xtra:7' ) + + IF ( CHECK_TIME( XYMD, XHMS, NYMD, NHMS ) ) THEN + IF ( PRESENT( SNOW ) ) CALL TRANSFER_2D( Q2, SNOW ) + NFOUND = NFOUND + 1 + ENDIF + + !-------------------------------- + ! RADLWG: Net upward LW rad at the ground + !-------------------------------- + CASE ( 'RADLWG' ) + READ( IU_XT, IOSTAT=IOS ) XYMD, XHMS, Q2 + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_XT, 'read_xtra:8' ) + + IF ( CHECK_TIME( XYMD, XHMS, NYMD, NHMS ) ) THEN + IF ( PRESENT( RADLWG ) ) + & CALL TRANSFER_2D( Q2, RADLWG ) + NFOUND = NFOUND + 1 + ENDIF + + END SELECT + + !============================================================== + ! If we have found all the fields for this time, then exit + ! the loop. Otherwise, go on to the next iteration. + !============================================================== + IF ( CHECK_TIME( XYMD, XHMS, NYMD, NHMS ) .and. + & NFOUND == N_XTRA ) THEN + STAMP = TIMESTAMP_STRING( NYMD, NHMS ) + WRITE( 6, 210 ) NFOUND, STAMP + 210 FORMAT( ' - Found all ', i3, + & ' XTRA met fields for ', a ) + EXIT + ENDIF + ENDDO + + !================================================================= + ! ND67 diagnostic: A-3 surface fields: + ! + ! (19) TSKIN : Ground/sea surface temp. [hPa] + ! (20) PARDF : Photosyn active diffuse radiation [W/m2] + ! (21) PARDR : Photosyn active direct radiation [W/m2] + !================================================================= + IF ( ND67 > 0 ) THEN + IF ( PRESENT( TSKIN ) ) AD67(:,:,19) = AD67(:,:,19) + TSKIN + IF ( PRESENT( PARDF ) ) AD67(:,:,20) = AD67(:,:,20) + PARDF + IF ( PRESENT( PARDR ) ) AD67(:,:,21) = AD67(:,:,21) + PARDR + ENDIF + + ! Increment # of times READ_XTRA is called + CALL SET_CT_XTRA( INCREMENT=.TRUE. ) + + ! Return to calling program + END SUBROUTINE READ_XTRA + +!------------------------------------------------------------------------------ + + SUBROUTINE XTRA_CHECK( NFOUND, N_XTRA ) +! +!****************************************************************************** +! Subroutine XTRA_CHECK prints an error message if not all of the XTRA met +! fields are found. The run is also terminated. (bmy, 10/27/00, 6/23/03) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NFOUND (INTEGER) : # of XTRA met fields read from disk +! (2 ) N_XTRA (INTEGER) : # of XTRA met fields expected to be read from disk +! +! NOTES +! (1 ) Adapted from DAO_CHECK from "dao_read_mod.f" (bmy, 6/23/03) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + + ! Arguments + INTEGER, INTENT(IN) :: NFOUND, N_XTRA + + !================================================================= + ! XTRA_CHECK begins here! + !================================================================= + IF ( NFOUND /= N_XTRA ) THEN + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'ERROR -- not enough XTRA fields found!' + + WRITE( 6, 120 ) N_XTRA, NFOUND + 120 FORMAT( 'There are ', i2, ' fields but only ', i2 , + & ' were found!' ) + + WRITE( 6, '(a)' ) '### STOP in XTRA_CHECK (xtra_read_mod.f)' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Deallocate arrays and stop (bmy, 10/15/02) + CALL GEOS_CHEM_STOP + ENDIF + + ! Return to calling program + END SUBROUTINE XTRA_CHECK + +!------------------------------------------------------------------------------ + + END MODULE XTRA_READ_MOD