Add files via upload
This commit is contained in:
Xuesong (Steve)
16
code/XSEC1D.f
Normal file
16
code/XSEC1D.f
Normal file
@ -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
|
||||||
16
code/XSECO2.f
Normal file
16
code/XSECO2.f
Normal file
@ -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
|
||||||
16
code/XSECO3.f
Normal file
16
code/XSECO3.f
Normal file
@ -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
|
||||||
44
code/tcorr.f
Normal file
44
code/tcorr.f
Normal file
@ -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
|
||||||
372
code/toms_mod.f
Normal file
372
code/toms_mod.f
Normal file
@ -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
|
||||||
2068
code/tpcore_bc_mod.f
Normal file
2068
code/tpcore_bc_mod.f
Normal file
File diff suppressed because it is too large
Load Diff
2068
code/tpcore_bc_mod.f~
Normal file
2068
code/tpcore_bc_mod.f~
Normal file
File diff suppressed because it is too large
Load Diff
6595
code/tpcore_fvdas_mod.f90
Normal file
6595
code/tpcore_fvdas_mod.f90
Normal file
File diff suppressed because it is too large
Load Diff
4237
code/tpcore_mod.f
Normal file
4237
code/tpcore_mod.f
Normal file
File diff suppressed because it is too large
Load Diff
4838
code/tpcore_window_mod.f
Normal file
4838
code/tpcore_window_mod.f
Normal file
File diff suppressed because it is too large
Load Diff
1719
code/tracerid_mod.f
Normal file
1719
code/tracerid_mod.f
Normal file
File diff suppressed because it is too large
Load Diff
1674
code/transfer_mod.f
Normal file
1674
code/transfer_mod.f
Normal file
File diff suppressed because it is too large
Load Diff
90
code/tropopause.f
Normal file
90
code/tropopause.f
Normal file
@ -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
|
||||||
692
code/tropopause_mod.f
Normal file
692
code/tropopause_mod.f
Normal file
@ -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
|
||||||
49
code/unix_cmds_mod.f
Normal file
49
code/unix_cmds_mod.f
Normal file
@ -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
|
||||||
105
code/update.f
Normal file
105
code/update.f
Normal file
@ -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
|
||||||
|
|
||||||
175
code/uvalbedo_mod.f
Normal file
175
code/uvalbedo_mod.f
Normal file
@ -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
|
||||||
582
code/vistas_anthro_mod.f
Normal file
582
code/vistas_anthro_mod.f
Normal file
@ -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
|
||||||
49
code/xltmmp.f
Normal file
49
code/xltmmp.f
Normal file
@ -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
|
||||||
664
code/xtra_read_mod.f
Normal file
664
code/xtra_read_mod.f
Normal file
@ -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
|
||||||
Reference in New Issue
Block a user